56 lines
1.9 KiB
Racket
56 lines
1.9 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/date racket/match racket/pretty racket/string
|
|
net/url-string xml)
|
|
|
|
(provide get-date parse-url get-user-agent-header sxml->xexpr check-xexpr)
|
|
|
|
(define (get-date)
|
|
(parameterize ([date-display-format 'rfc2822])
|
|
;; aaaaaaaaaaaaaaaaaaaaa
|
|
(regexp-replace
|
|
#px"[^ ]+$"
|
|
(date->string (seconds->date (* 0.001 (current-inexact-milliseconds)) #f) #t)
|
|
"GMT")))
|
|
|
|
(define (parse-url fetch-url)
|
|
(printf " fetching page: ~a\n" fetch-url)
|
|
(define parsed-url (if (string? fetch-url) (string->url fetch-url) fetch-url))
|
|
(match parsed-url
|
|
[(url scheme user host port path-absolute? path query fragment)
|
|
(define ssl? (string=? (string-downcase scheme) "https"))
|
|
(values parsed-url ssl? host
|
|
(or port (if ssl? 443 80))
|
|
(format "/~a" (string-join (map path/param-path path) "/")))]))
|
|
|
|
(define (get-user-agent-header)
|
|
(format "User-Agent: Racket/~a (net/http-client) static-generator/0.1 trans/rights" (version)))
|
|
|
|
(define (sxml->xexpr sxml)
|
|
(define (sxml-attr->xexpr-attr attr)
|
|
(match attr
|
|
[(list (? symbol?) (? string?)) attr]
|
|
[(list (? symbol? s)) (list s (symbol->string s))]
|
|
[_ (error "invalid sxml attr" attr)]))
|
|
(match sxml
|
|
[(? string?) sxml]
|
|
['(& nbsp) "\u00a0"]
|
|
[(list '& _) (error "unhandled &-code" sxml)]
|
|
[(list (? symbol? tag) (cons '@ attrs) body ...)
|
|
(cons tag (cons (map sxml-attr->xexpr-attr attrs) (map sxml->xexpr body)))]
|
|
[(list (? symbol? tag) body ...)
|
|
(cons tag (cons '() (map sxml->xexpr body)))]))
|
|
|
|
(define (check-xexpr x)
|
|
(define (check-detailed-xexpr x)
|
|
(match x
|
|
[(? string?) (void)]
|
|
[(list tag (list (list (? symbol?) (? string?)) ...) body ...)
|
|
(void (map check-detailed-xexpr body))]
|
|
[_ (printf "problem:\n") (pretty-write x)]))
|
|
(unless (xexpr? x)
|
|
(check-detailed-xexpr x)
|
|
(error "not xexpr!"))
|
|
x)
|
|
|