You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
141 lines
5.6 KiB
Racket
141 lines
5.6 KiB
Racket
#lang racket/base
|
|
(require "core.rkt")
|
|
(require net/url-structs net/base64 racket/file racket/format racket/list sugar/unstable/string)
|
|
(provide (all-defined-out))
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
(require racket/contract sugar)
|
|
|
|
(define/contract (base64-font-string? x)
|
|
(any/c . -> . boolean?)
|
|
((->string x) . starts-with? . "data:"))
|
|
|
|
(module+ test
|
|
(check-true (base64-font-string? "data:foobar"))
|
|
(check-false (base64-font-string? "foobar")))
|
|
|
|
|
|
(define/contract (font-format p)
|
|
(pathish? . -> . (or/c string? #f))
|
|
(case (get-ext (->path p))
|
|
[("eot") "embedded-opentype"]
|
|
[("woff") "woff"]
|
|
[("woff2") "woff2"]
|
|
[("ttf" "otf") "truetype"] ; yep, in this CSS declaration, otf is considered 'truetype'
|
|
[("svg") "svg"]
|
|
[else (raise-argument-error 'font-format "valid font type" p)]))
|
|
|
|
(module+ test
|
|
(check-equal? (font-format "foo.eot") "embedded-opentype")
|
|
(check-equal? (font-format "foo.woff") "woff")
|
|
(check-equal? (font-format "foo.woff2") "woff2")
|
|
(check-equal? (font-format "foo.ttf") "truetype")
|
|
(check-equal? (font-format "foo.otf") "truetype")
|
|
(check-equal? (font-format "foo.svg") "svg")
|
|
(check-exn exn:fail? (λ () (font-format "foo"))))
|
|
|
|
|
|
(define/contract (font-mime-type p)
|
|
(pathish? . -> . (or/c string? #f))
|
|
(case (get-ext (->path p))
|
|
[("eot") "application/vnd.ms-fontobject"]
|
|
[("woff") "application/font-woff"]
|
|
[("woff2") "application/font-woff2"]
|
|
[("ttf") "application/x-font-truetype"]
|
|
[("otf") "application/x-font-opentype"]
|
|
[("svg") "image/svg+xml"]
|
|
[else (raise-argument-error 'font-mime-type "valid font type" p)]))
|
|
|
|
(module+ test
|
|
(check-equal? (font-mime-type "foo.eot") "application/vnd.ms-fontobject")
|
|
(check-equal? (font-mime-type (->url "foo.woff?bar=ino")) "application/font-woff")
|
|
(check-equal? (font-mime-type (->url "foo.woff2?bar=ino")) "application/font-woff2")
|
|
(check-equal? (font-mime-type "foo.ttf") "application/x-font-truetype")
|
|
(check-equal? (font-mime-type "foo.otf") "application/x-font-opentype")
|
|
(check-equal? (font-mime-type "foo.svg") "image/svg+xml")
|
|
(check-exn exn:fail? (λ () (font-mime-type "foo"))))
|
|
|
|
|
|
(define/contract (path->base64-font-string p)
|
|
(pathish? . -> . base64-font-string?)
|
|
(define path (->path p))
|
|
;; for CSS, base64 encode needs to be done with no line separator
|
|
(format "data:~a;charset=utf-8;base64,~a" (font-mime-type p) (base64-encode (file->bytes path) #"")))
|
|
|
|
(define (valid-font-style? x)
|
|
(and (string? x) (member x '("normal" "italic" "oblique")) #t))
|
|
|
|
(module+ test
|
|
(check-true (valid-font-style? "normal"))
|
|
(check-true (valid-font-style? "oblique"))
|
|
(check-false (valid-font-style? "foobar")))
|
|
|
|
(define (valid-font-weight? x)
|
|
(define str (format "~a" x))
|
|
(and (string? str) (member str `("normal" "bold" ,@(map ~a (range 100 1000 100)))) #t))
|
|
|
|
(module+ test
|
|
(check-true (valid-font-weight? "normal"))
|
|
(check-true (valid-font-weight? "100"))
|
|
(check-true (valid-font-weight? "300"))
|
|
(check-true (valid-font-weight? "900"))
|
|
(check-true (valid-font-weight? 100))
|
|
(check-true (valid-font-weight? 300))
|
|
(check-true (valid-font-weight? 900))
|
|
(check-false (valid-font-weight? "italic"))
|
|
(check-false (valid-font-weight? "1000")))
|
|
|
|
(define (valid-font-stretch? x)
|
|
(and (string? x) (member x '("normal"
|
|
"ultra-condensed"
|
|
"extra-condensed"
|
|
"condensed"
|
|
"semi-condensed"
|
|
"semi-expanded"
|
|
"expanded"
|
|
"extra-expanded"
|
|
"ultra-expanded")) #t))
|
|
|
|
(module+ test
|
|
(check-true (valid-font-stretch? "normal"))
|
|
(check-true (valid-font-stretch? "extra-condensed"))
|
|
(check-false (valid-font-stretch? "italic"))
|
|
(check-false (valid-font-stretch? "nonsense")))
|
|
|
|
(define/contract (font-face-declaration font-family
|
|
src-url
|
|
#:local [local-name #f]
|
|
#:font-style [font-style "normal"]
|
|
#:font-weight [font-weight "normal"]
|
|
#:font-stretch [font-stretch "normal"]
|
|
#:font-display [font-display "auto"]
|
|
#:unicode-range [unicodes #f]
|
|
#:base64 [base64? #f])
|
|
((string? (or/c urlish? base64-font-string?))
|
|
(#:font-style valid-font-style?
|
|
#:font-weight valid-font-weight?
|
|
#:font-stretch valid-font-stretch?
|
|
#:font-display string?
|
|
#:unicode-range (or/c #f string?)
|
|
#:base64 boolean?
|
|
#:local (or/c #f string?))
|
|
. ->* . string?)
|
|
(let* ([url (->url src-url)]
|
|
[url-value (if base64? (path->base64-font-string src-url) (->path url))]
|
|
[src (format "url('~a') format('~a')" url-value (font-format src-url))]
|
|
[src (string-append (if local-name (format "local(~v), " local-name) "") src)]
|
|
[font-weight (format "~a" font-weight)])
|
|
(string-append "@font-face {\n"
|
|
(join-css-strings (append
|
|
(map make-css-string
|
|
'(font-family font-style font-weight font-stretch font-display src)
|
|
(list font-family font-style font-weight font-stretch font-display src))
|
|
(if unicodes
|
|
(list (make-css-string 'unicode-range unicodes))
|
|
null)))
|
|
"}")))
|
|
|
|
(define ffd font-face-declaration)
|
|
|