implement new scripts goodies

scripts/ansi-color.rkt

@@ -0,0 +1,228 @@
+#lang racket/base
+
+;; original source: https://github.com/renatoathaydes/ansi-color
+;; modified to provide font-style because i need that bold
+
+(require racket/match)
+
+(provide color-display
+         color-displayln
+         ansi-color?
+         with-colors
+         background-color
+         foreground-color
+         font-style
+         erase-line)
+
+;; Color and decoration escape definitions
+
+(define reset "\033[0m")
+(define erase-line "\033[K")
+
+(define (bkg-color256 code)
+  (string-append "\033[48;5;" (number->string code) "m"))
+
+(define (fore-color256 code)
+  (string-append "\033[38;5;" (number->string code) "m"))
+
+(define decoration-map
+  #hasheq(
+          (underline . "\033[4m")
+          (bold . "\033[1m")
+          (reversed . "\033[7m")))
+
+(define fore-color-map
+  #hasheq(
+          (black . "\033[30m")
+          (red . "\033[31m")
+          (green . "\033[32m")
+          (yellow . "\033[33m")
+          (blue . "\033[34m")
+          (magenta . "\033[35m")
+          (cyan . "\033[36m")
+          (white . "\033[37m")
+          (b-black . "\033[30;1m")
+          (b-red . "\033[31;1m")
+          (b-green . "\033[32;1m")
+          (b-yellow . "\033[33;1m")
+          (b-blue . "\033[34;1m")
+          (b-magenta . "\033[35;1m")
+          (b-cyan . "\033[36;1m")
+          (b-white . "\033[37;1m")))
+
+(define bkg-color-map
+  #hasheq(
+          (black . "\033[40m")
+          (red . "\033[41m")
+          (green . "\033[42m")
+          (yellow . "\033[43m")
+          (blue . "\033[44m")
+          (magenta . "\033[45m")
+          (cyan . "\033[46m")
+          (white . "\033[47m")
+          (b-black . "\033[40;1m")
+          (b-red . "\033[41;1m")
+          (b-green . "\033[42;1m")
+          (b-yellow . "\033[43;1m")
+          (b-blue . "\033[44;1m")
+          (b-magenta . "\033[45;1m")
+          (b-cyan . "\033[46;1m")
+          (b-white . "\033[47;1m")))
+
+;; customization parameters
+
+(define background-color (make-parameter ""
+  (lambda (arg) (as-escape-seq #t arg))))
+
+(define foreground-color (make-parameter ""
+  (lambda (arg) (as-escape-seq #f arg))))
+
+(define font-style (make-parameter ""
+  (lambda (arg) (as-style-seq arg))))
+
+(define no-reset (make-parameter #f))
+
+;; implementation
+
+(define (ansi-color? x)
+  (or
+      (and (integer? x) (<= x 255) (>= x 0))
+      (and (symbol? x)  (hash-has-key? fore-color-map x))))
+
+(define (as-escape-seq bkg? arg)
+  (define (raise-arg-error)
+    (raise-arguments-error 'color
+      "Cannot convert argument to color (not a valid symbol or integer in the 0-255 range)"
+      "color"
+      arg))
+  (define map (if bkg? bkg-color-map fore-color-map))
+  (match arg
+    [(? null?) ""]
+    ["" ""]
+    [(? symbol? s) (hash-ref map s (lambda () (raise-arg-error)))]
+    [(? integer? x)
+      #:when (and (<= x 255) (>= x 0))
+        ((if bkg? bkg-color256 fore-color256) x)]
+    [_ (raise-arg-error)]))
+
+(define (as-style-seq arg)
+  (define (raise-arg-error)
+    (raise-arguments-error 'style
+      "Cannot convert argument to style (not a valid symbol)"
+      "style"
+      arg))
+  (match arg
+    ["" ""]
+    [(? null?) ""]
+    [(? symbol? s) (hash-ref decoration-map s (lambda () (raise-arg-error)))]
+    [_ (raise-arg-error)]))
+
+(define (needs-reset? bkg fore style)
+  (cond [(no-reset) #f]
+        [else (not (and (equal? "" bkg)
+                        (equal? "" fore)
+                        (equal? "" style)))]))
+
+(define (color-display datum [out (current-output-port)])
+  (let* ([bkg (background-color)]
+         [fore (foreground-color)]
+         [style (font-style)]
+         [-reset (if (needs-reset? bkg fore style) reset "")])
+    (display (string-append bkg fore style datum -reset) out)))
+
+(define (color-displayln datum [out (current-output-port)])
+  (color-display datum out)
+  (newline out))
+
+(define with-colors
+  (case-lambda
+    [(bkg-color fore-color proc)
+     (parameterize ([background-color bkg-color]
+                    [foreground-color fore-color]
+                    [no-reset #t])
+       (color-display "") ; sets the colors in the terminal
+       (proc)
+       (display reset))]  ; reset colors in the terminal
+    [(fore-color proc)
+     (with-colors null fore-color proc)]))
+
+
+;; TESTS
+
+(module+ test
+    
+  (require rackunit)
+
+  (check-eq? (needs-reset? "" "" "") #f)
+  (check-eq? (needs-reset? "red" "" "") #t)
+  (check-eq? (needs-reset? "" "blue" "") #t)
+  (check-eq? (needs-reset? "red" "green" "") #t)
+  (check-eq? (needs-reset? "red" "green" "underline") #t)
+  (check-eq? (needs-reset? "" "" "underline") #t)
+  (check-eq? (parameterize ([no-reset #t])
+              (needs-reset? "" "" "")) #f)
+  (check-eq? (parameterize ([no-reset #t])
+              (needs-reset? "red" "green" "reversed")) #f)
+  
+  (check-eq? (ansi-color? 'red) #t)
+  (check-eq? (ansi-color? 'white) #t)
+  (check-eq? (ansi-color? 'black) #t)
+  (check-eq? (ansi-color? 'b-red) #t)
+  (check-eq? (ansi-color? 'b-white) #t)
+  (check-eq? (ansi-color? 'b-black) #t)
+  (check-eq? (ansi-color? 'some) #f)
+  (check-eq? (ansi-color? 'foo-bar) #f)
+  (check-eq? (ansi-color? 0) #t)
+  (check-eq? (ansi-color? 1) #t)
+  (check-eq? (ansi-color? 10) #t)
+  (check-eq? (ansi-color? 200) #t)
+  (check-eq? (ansi-color? 255) #t)
+  (check-eq? (ansi-color? 256) #f)
+  (check-eq? (ansi-color? -1) #f)
+  (check-eq? (ansi-color? -10) #f)
+  (check-eq? (ansi-color? "blue") #f)
+  (check-eq? (ansi-color? #t) #f)
+
+  (define (wrap-in-color color text)
+    (string-append (hash-ref fore-color-map color) text reset))
+
+  (define (get-output proc)
+    (let ([out (open-output-string)])
+      (parameterize ([current-output-port out])
+        (proc)
+        (get-output-string out))))
+
+  ; tests for color-display
+  (let ([hello-uncolored (get-output (lambda () (color-display "hello")))]
+        [world-fore-red (get-output (lambda ()
+                                      (parameterize ([background-color 'red])
+                                        (color-display "world"))))]
+        [tree-fore-blue (get-output (lambda ()
+                                      (parameterize ([foreground-color 'blue])
+                                        (color-display "tree"))))]
+        [animal-yellow-black (get-output (lambda ()
+                                          (parameterize ([background-color 'yellow]
+                                                          [foreground-color 'black])
+                                            (color-display "animal"))))]
+        [something-bold (get-output (lambda ()
+                                      (parameterize ([font-style 'bold])
+                                        (color-display "something"))))])
+  
+    (check-equal? hello-uncolored "hello")
+    (check-equal? world-fore-red "\033[41mworld\033[0m")
+    (check-equal? tree-fore-blue "\033[34mtree\033[0m")
+    (check-equal? animal-yellow-black "\033[43m\033[30manimal\033[0m")
+    (check-equal? something-bold "\033[1msomething\033[0m"))
+
+  ; tests for with-colors
+  (let ([blue-and-white (get-output (lambda () (with-colors 'blue 'white (lambda () (display "b-a-w")))))]
+        [red-and-green  (get-output (lambda () (with-colors 'red 'green (lambda () (display "r-a-g")))))]
+        [blue           (get-output (lambda () (with-colors 'blue (lambda () (display "b")))))]
+        [white          (get-output (lambda () (with-colors 'white (lambda () (display "w")))))])
+
+    (check-equal? blue-and-white "\033[44m\033[37mb-a-w\033[0m")
+    (check-equal? red-and-green "\033[41m\033[32mr-a-g\033[0m")
+    (check-equal? blue "\033[34mb\033[0m")
+    (check-equal? white "\033[37mw\033[0m"))
+
+)

scripts/aoc-lib.rkt

@@ -1,16 +1,18 @@
 #lang racket
 
 (require net/uri-codec net/http-client)
-(provide aoc-fetch-input aoc-submit-answer)
+(provide aoc-fetch-input aoc-fetch-challenge aoc-submit-answer)
 
 (define *host* "adventofcode.com")
 
 (define/contract (puzzle-path year day endpoint)
-  (-> string? string? (or/c "input" "answer") path?)
+  (-> string? string? (or/c "input" "answer" false/c) path?)
-  (build-path "/" year "day" day endpoint))
+  (define base (build-path "/" year "day" day))
+  (if endpoint (build-path base endpoint) base))
 
 (define (make-headers session)
-  (list (string-append "Cookie: session=" session)))
+  (list (string-append "Cookie: session=" session)
+        "Content-Type: application/x-www-form-urlencoded"))
 
 (define (aoc-request year day endpoint session [method 'GET] [data #f])
   (define (parse-headers hlist)
@@ -21,9 +23,9 @@
                (bytes->string/utf-8 v))]
         [x (cons 'unknown x)])))
 
-  (define (do-request path headers)
+  (define (do-request path headers method data)
     (define-values [status headers-out content]
-      (http-sendrecv *host* path #:ssl? #t #:headers headers))
+      (http-sendrecv *host* path #:ssl? #t #:headers headers #:method method #:data data))
     (define headers-out/parsed (parse-headers headers-out))
 
     (match status
@@ -33,13 +35,13 @@
                                  (error "got 302 with no location"))))
        (printf "got redirect to ~a\n" location)
        (close-input-port content)
-       (do-request location headers)]
+       (do-request location headers 'GET #f)]
       [(pregexp #px"^HTTP/1\\.[10] 404")
        (error "endpoint returned 404\n response: " (port->bytes content))]
       [stat
        (error "endpoint returned unexpected data\n status: " stat "\n response: "
               (port->bytes content))]))
-  (do-request (path->string (puzzle-path year day endpoint)) (make-headers session)))
+  (do-request (path->string (puzzle-path year day endpoint)) (make-headers session) method data))
 
 (define/contract (aoc-fetch-input year day session)
   (-> string? string? string? input-port?)
@@ -53,7 +55,11 @@
     (port->bytes (aoc-request year day "answer" session 'POST (alist->form-urlencoded data))))
 
   (match resp
-    [(pregexp #px"Both parts of this puzzle are complete") 'day-complete]
     [(pregexp #px"That's the right answer") 'answer-correct]
     [(pregexp #px"That's not the right answer") 'answer-incorrect]
+    [(pregexp #px"Did you already complete it?") 'already-completed]
     [x x]))
+
+(define/contract (aoc-fetch-challenge year day session)
+  (-> string? string? string? input-port?)
+  (aoc-request year day #f session))

scripts/get-challenge

@@ -0,0 +1,91 @@
+#!/usr/bin/env racket
+#lang racket
+
+(require html xml "ansi-color.rkt" "aoc-lib.rkt")
+
+;; finds a given element of an xexpr
+(define (find-element el doc)
+  (match doc
+    [(list (== el) _ ...) doc]
+    [(list tag attrs children ...)
+     (ormap (curry find-element el) children)]
+    [_ #f]))
+
+(struct style-ast [fg bg fs children] #:transparent)
+;; convert xexpr tree to an ast with lower-level styling
+(define (xexpr->style-ast doc)
+  (match doc
+    [(? string?) (style-ast #f #f #f doc)]
+    [(list 'script _ ...) #f]
+    [(list-no-order 'p (list 'span (list-no-order '(class "share")) _ ...) _ ...) #f]
+    [(list 'li _ children ...)
+     (define out-children (filter identity (map xexpr->style-ast children)))
+     (style-ast #f #f #f (cons (style-ast #f #f #f "- ") out-children))]
+    [(list tag attrs children ...)
+     (define-values [fg bg fs]
+       (match* (tag attrs)
+         [('main _) (values #f #f #f)]
+         [('article _) (values #f #f #f)]
+         [('p (list-no-order '(class "day-success") _ ...)) (values 'yellow #f 'bold)]
+         [('p _) (values #f #f #f)]
+         [('pre _) (values #f #f #f)]
+         [('h2 _) (values #f #f 'bold)]
+         [('ul _) (values #f #f #f)]
+         [('a _) (values 'green #f #f)]
+         [('code _) (values 'white 234 #f)]
+         [('span _) (values #f #f #f)]
+         [('em (list-no-order '(class "star") _ ...)) (values 'yellow #f 'bold)]
+         [('em _) (values #f #f 'bold)]
+         [(_ _)
+          (printf "warning: unhandled ~a ~a\n" tag attrs)
+          (#f #f #f)]))
+     (define inner-children (filter identity (map xexpr->style-ast children)))
+     (define new-children
+       (if ((or/c 'h2 'pre 'p) tag)
+         (let ([nls (list (style-ast #f #f #f "\n") (style-ast #f #f #f "\n"))])
+           (append nls inner-children nls))
+         inner-children))
+     (style-ast fg bg fs new-children)]))
+
+
+(define (output-style-ast ast)
+  (define num-newlines (make-parameter #f))
+
+  (define (helper ast [prev-bg ""] [prev-fg ""] [prev-fs ""])
+    (match-define (style-ast fg bg fs children) ast)
+    (when bg (background-color bg))
+    (when fg (foreground-color fg))
+    (when fs (font-style fs))
+    (match children
+      ["\n"
+       (unless (or (false? (num-newlines)) (>= (num-newlines) 2))
+         (num-newlines (add1 (num-newlines)))
+         (display "\n"))]
+      [(? string? str)
+       (num-newlines 0)
+       (if (string-contains? str "\n")
+         (for ([i (in-naturals)] [line (in-list (string-split (string-trim str "\n") "\n"))])
+           (color-display (format (if (zero? i) "~a~a" "\n~a~a") erase-line line)))
+         (color-display str))]
+      [_ (map (lambda (item) (helper item (or bg prev-bg) (or fg prev-fg) (or fs prev-fs)))
+              children)])
+    (when prev-bg (background-color prev-bg))
+    (when prev-fg (foreground-color prev-fg))
+    (when prev-fs (font-style prev-fs)))
+
+  (num-newlines #f)
+  (helper ast))
+
+(command-line
+  #:program "get-challenge"
+  #:args (day)
+  (define in (aoc-fetch-challenge (getenv "AOC_YEAR") day (getenv "AOC_SESSION")))
+  (use-html-spec #f)
+  (define doc-xmls (read-html-as-xml in))
+  (close-input-port in)
+  (define doc `(top-element ,@(map xml->xexpr doc-xmls)))
+
+  (define main (find-element 'main doc))
+  (define ast (xexpr->style-ast main))
+  ; (pretty-write ast)
+  (output-style-ast ast))

scripts/template.rktrkt

@@ -2,6 +2,13 @@
 
 ;; solution for day @day
 
+;; helper functions here
+
+(module+ test
+  (require rackunit)
+  ;; tests here
+  (void))
+
 (module+ main
   (define input (file->... "inputs/@day"))
   ;; part 1