Compare commits

...

9 Commits

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 431 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 14 KiB

@ -0,0 +1,180 @@
#lang debug racket/gui
(require pollen/private/log
pollen/private/command
pollen/setup
pollen/private/project-server
net/sendurl)
(define app-mono-fam
(for*/first ([preferred
'("Triplicate T4" "Menlo" "Consolas" "Andale Mono" "Courier")]
[mono-fam (in-list (get-face-list 'mono))]
#:when (equal? preferred mono-fam))
preferred))
(define app-font-size 14)
(define app-font (make-font #:face (send normal-control-font get-face) #:size app-font-size))
(define window (new frame% [label "Pollen Helper"]
[width 700]
[height 500]
[x 40]
[y 40]
[alignment '(left top)]
[spacing 6]
[border 6]))
(define (make-hpanel) (new horizontal-panel%
[parent window]
[alignment '(left top)]
[stretchable-height #false]))
(define hpanel-select (make-hpanel))
(define current-manager-directory (make-parameter #f))
(define current-server-stopper (make-parameter #f))
(define (set-current-manager-directory val)
(current-manager-directory val)
(send directory-msg set-label (if val (path->string val) "")))
(module+ main
(set-current-manager-directory (expand-user-path "~/git/bpt/")))
(define button-directory
(let ([str "Select project directory"])
(new button%
[label str]
[parent hpanel-select]
[callback (λ (button evt)
(define dir (get-directory str))
(when dir
(set-current-manager-directory dir)
(set-server-port (setup:project-server-port dir))))])))
(define directory-msg
(new message%
[label ""]
[parent hpanel-select]
[auto-resize #true]))
(define hpanel-server-options (make-hpanel))
(define server-option-port
(new text-field%
[parent hpanel-server-options]
[label "server port"]
[min-width 150]
[stretchable-width #false]
[init-value (number->string (setup:project-server-port))]
[callback (λ (tf evt)
(set-server-port (string->number (send tf get-value))))]))
(define (set-server-port num)
(when (number? num)
(current-server-port num)
(send server-option-port set-value (number->string num))))
(define server-option-local
(new check-box%
[parent hpanel-server-options]
[label "local only"]
[callback (λ (cb evt)
(current-server-listen-ip (and (send cb get-value) "127.0.0.1")))]))
(define hpanel-server-controls (make-hpanel))
(define dialog-alert (new dialog%
[label "Error"]
[border 6]
[spacing 6]
[parent #f]))
(define dialog-message (new message%
[parent dialog-alert]
[auto-resize #t]
[label ""]))
(define dialog-alert-button-pane
(new horizontal-pane%
[parent dialog-alert]
[alignment '(right bottom)]))
(define dialog-alert-button-ok
(new button%
[parent dialog-alert-button-pane]
[label "OK"]
[style '(border)]
[callback (λ (button evt)
(send dialog-alert show #f))]))
(define (make-alert str)
(send dialog-message set-label str)
(send dialog-alert show #t))
(define button-start
(new button%
[label "Start project server"]
[parent hpanel-server-controls]
[callback (λ (button evt)
(if (current-server-stopper)
(make-alert "Project server already running.")
(match (current-manager-directory)
[#false (make-alert "No project directory selected.")]
[dir
(message "starting project server")
;; stopper is a function that sends a break signal
;; to the web server thread, wherever it is
(define stopper
(parameterize ([current-project-root dir])
(start-server (setup:main-pagetree dir) #:return #true)))
(current-server-stopper stopper)])))]))
(define button-stop
(new button%
[label "Stop project server"]
[parent hpanel-server-controls]
[callback (λ (button evt)
(match (current-server-stopper)
[#false (make-alert "Project server not running.")]
[stopper-proc
(stopper-proc)
(current-server-stopper #false)
(message "project server stopped")]))]))
(define button-launch
(new button%
[label "Launch browser"]
[parent hpanel-server-controls]
[callback (λ (button evt)
(cond
[(current-server-stopper)
(send-url
(format "http://localhost:~a/~a"
(current-server-port)
(setup:main-pagetree (current-manager-directory)))
#false)]
[else (make-alert "Project server not running.")]))]))
(define status-box
(let* ([wb (new text-field%
[label #f]
[style '(multiple)]
[parent window]
[font (make-font #:face app-mono-fam #:size app-font-size)])]
[ed (send wb get-editor)])
(send ed set-line-spacing (* app-font-size 0.4))
(send ed set-padding 6 3 6 3)
wb))
(define status-box-ed (send status-box get-editor))
(define log-receiver-thread
(thread (λ ()
(define rcvr (make-log-receiver pollen-logger 'info 'pollen))
(for ([vec (in-producer (λ () (sync rcvr)))])
(match-define (vector _ msg _ _) vec)
(send status-box-ed insert msg)
(send status-box-ed insert "\n")))))
(send window show #t)

@ -0,0 +1,13 @@
#lang br
(require pict icns file/ico rsvg)
(define p (svg-file->pict "pollen-raw.svg"))
(send (pict->bitmap p) save-file "pollen.png" 'png)
(with-output-to-file "pollen.icns"
(λ () (void (write-bytes (pict->icns-bytes p))))
#:exists 'replace)
(write-icos (for/list ([size '(16 32 48 256)])
(argb->ico size size (pict->argb-pixels (scale p (/ size 720))))) "pollen.ico"
#:exists 'replace)

@ -0,0 +1,142 @@
#lang debug racket
(require racket/gui sugar/coerce sugar/debug)
(define current-cell-size (make-parameter 120))
(define current-dc (make-parameter #f))
(define current-target (make-parameter 'gui))
(define current-stroke-scale (make-parameter 1))
(define char-edge-size 6)
(define (pathify vs)
(define p (new dc-path%))
(define pts (map (λ (x) (list (* (current-cell-size) (sub1 (modulo x 10))) (* (current-cell-size) (- 4 (sub1 (floor (/ x 10))))) )) vs))
(send p move-to (first (car pts)) (second (car pts)))
(for-each (λ (pt) (send p line-to (first pt) (second pt))) (cdr pts))
(when (= (first vs) (last vs)) (send p close))
p)
(struct $glyph (name paths))
(define font-definition
'((a (51 54 45 15 12 21 31 33))
(b (11 51 55 25 14 13) (35 33))
(c (25 15 11 41 52 55 45))
(d (31 11 14 25 45 54 51))
(e (15 11 41 52 55 35 33))
(E (55 52 41 11 15) (31 35))
(f (11 41 52 55) (31 35))
(g (33 35 15 11 41 52 55))
(h (11 51) (15 55) (31 35))
(i (11 15) (51 55) (13 53))
(j (53 55 15 12 21 31))
(k (11 51) (11 21 54 55) (43 34 25 15))
(L (51 11 15) (53 33 35))
(l (25 15 11 41 52))
(m (11 51 54 45 15) (53 13))
(n (11 51 54 45 15))
(N (11 51 52 43 23 14 15 55))
(O (11 41 52 55 25 14 11))
(o (51 54 45 15 12 21 51))
(P (11 51 54 45 35 24 23))
(p (51 54 45 35 33 13 11 31))
(p0 (11 51 55 35 24 23))
(q (33 24 13 11 41 52 55 35 24))
(r (11 51 53 54 45 35 33 23 14 15))
(s (11 14 25 35 31 41 52 55))
(t (31 51 55 35) (53 13) (11 15))
(T (51 55) (53 13))
(u (51 21 12 15 55))
(v (55 35 13 11 51))
(w (51 21 12 15 55) (53 13))
(x (51 52 43 23 14 15) (11 12 23 43 54 55))
(X (51 41 32 34 25 15) (11 21 32 34 45 55))
(y (51 31 35)(55 25 14 11))
(z (51 55 45 34 32 21 11 15))
( (12 21 41 52 43 54 45 25 14 12))
(0 (51 54 45 15 12 21 31 51))
(1 (51 53 13) (11 15))
(2 (51 54 45 35 31 11 15))
(3 (51 54 45 15 11) (31 35))
(4 (41 21 25) (54 14))
(5 (55 51 31 35 25 14 11))
(6 (31 35 25 14 11 41 52 55))
(7 (51 55 45 22 12))
(8 (12 21 51 54 45 15 12) (31 35))
(9 (11 14 25 55 52 41 31 35))
(λ (51 52 25 15) (11 21 43))
(> (51 52 25 15))
(% (11 51) (12 52) (13 53) (14 54) (15 55))
(^ (11 51) (12 42) (13 33) (14 24))
(< (11 21 43))
(|(| (55 54 43 23 14 15))
(|)| (51 52 43 23 12 11))))
(define (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width)
(define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition))
(cond
[(equal? str "") (void)]
[else
(define gname (substring str 0 1))
(define g (findf (λ (g) (equal? ($glyph-name g) gname)) glyphs))
(when g
(define pen (make-pen #:color (->string (color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter))
(send (current-dc) set-pen pen)
(send (current-dc) set-brush "white" 'transparent)
(for-each (λ (p) (send (current-dc) draw-path p (+ xoffset (current-cell-size)) (+ yoffset (current-cell-size)))) ($glyph-paths g)))
(type (substring str 1) (+ xoffset (* (current-cell-size) char-edge-size)) yoffset #:color color-proc #:width width)]))
(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs)
(define layers (for/list ([i (in-range 0 (length attrs) 2)]) (list (list-ref attrs i) (list-ref attrs (add1 i)))))
(for-each (λ (layer) (type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer)))) layers))
(define (render text layers [stroke-scale 1] [name (gensym)])
(define lines (string-split text))
(define horiz (* (current-cell-size) (apply max (map string-length lines)) char-edge-size))
(define vert (* (current-cell-size) char-edge-size (length lines)))
(define target (make-bitmap horiz vert))
(parameterize ([current-dc (if (equal? 'svg (current-target))
(new svg-dc% [width horiz] [height vert] [output (format "/Users/MB/Desktop/~a.svg" name)] [exists 'replace])
(new bitmap-dc% [bitmap target]))]
[current-stroke-scale stroke-scale])
(when (eq? 'svg (current-target))
(send (current-dc) start-doc "start")
(send (current-dc) start-page))
(send (current-dc) set-smoothing 'smoothed)
(for* ([(line lineno) (in-indexed lines)]
[layer (in-list layers)])
(define layer-color (first layer))
(define layer-thickness (second layer))
(layer-type line #:xoffset 0 #:yoffset (* (current-cell-size) char-edge-size lineno) layer-color layer-thickness))
(make-object image-snip% target)
(when (eq? 'svg (current-target))
(send (current-dc) end-page)
(send (current-dc) end-doc))
(when (eq? 'png (current-target))
(send target save-file (format "/Users/MB/Desktop/~a.png" name) 'png))))
(define-syntax-rule (render-svg arg ...)
(parameterize ([current-target 'svg])
(render arg ...)))
(define-syntax-rule (render-png arg ...)
(parameterize ([current-target 'png])
(render arg ...)))
(define (random-select xs)
(list-ref xs (random (length xs))))
(module+ main
(current-target 'svg)
(define (do-it text name)
(render-svg text
(list (list (λ () 'Black) 11)
(list (λ () 'White) 9)
(list (λ () 'Black) 7)
(list (λ () 'White) 5)
(list (λ () 'Black) 3)
(list (λ () 'White) 1))
(/ 1 char-edge-size) name))
(do-it "P" 'pollen-raw))

@ -0,0 +1,145 @@
#lang debug racket
(require racket/gui sugar/coerce sugar/debug)
(define current-cell-size (make-parameter 30))
(define current-dc (make-parameter #f))
(define current-bitmap (make-parameter #f))
(define current-target (make-parameter 'gui))
(define current-stroke-scale (make-parameter 1))
(define char-edge-size 6)
(define (pathify vs)
(define p (new dc-path%))
(define pts
(for/list ([v (in-list vs)])
(list (* (current-cell-size) (sub1 (modulo v 10)))
(* (current-cell-size) (- 4 (sub1 (floor (/ v 10))))))))
(send/apply p move-to (car pts))
(for/last ([pt (in-list (cdr pts))])
(send/apply p line-to pt))
(when (= (first vs) (last vs)) (send p close))
p)
(struct $glyph (name paths))
(define font-definition
'((a (51 54 45 15 12 21 31 33))
(b (11 51 55 25 14 13) (35 33))
(c (25 15 11 41 52 55 45))
(d (31 11 14 25 45 54 51))
(e (15 11 41 52 55 35 33))
(E (55 52 41 11 15) (31 35))
(f (11 41 52 55) (31 35))
(g (33 35 15 11 41 52 55))
(h (11 51) (15 55) (31 35))
(i (11 15) (51 55) (13 53))
(j (53 55 15 12 21 31))
(k (11 51) (11 21 54 55) (43 34 25 15))
(L (51 11 15) (53 33 35))
(l (25 15 11 41 52))
(m (11 51 54 45 15) (53 13))
(n (11 51 54 45 15))
(N (11 51 52 43 23 14 15 55))
(O (11 41 52 55 25 14 11))
(o (51 54 45 15 12 21 51))
(P (11 51 54 45 35 24 23))
(p (51 54 45 35 33 13 11 31))
(p0 (11 51 55 35 24 23))
(q (33 24 13 11 41 52 55 35 24))
(r (11 51 53 54 45 35 33 23 14 15))
(s (11 14 25 35 31 41 52 55))
(t (31 51 55 35) (53 13) (11 15))
(T (51 55) (53 13))
(u (51 21 12 15 55))
(v (55 35 13 11 51))
(w (51 21 12 15 55) (53 13))
(x (51 52 43 23 14 15) (11 12 23 43 54 55))
(X (51 41 32 34 25 15) (11 21 32 34 45 55))
(y (51 31 35)(55 25 14 11))
(z (51 55 45 34 32 21 11 15))
( (12 21 41 52 43 54 45 25 14 12))
(0 (51 54 45 15 12 21 31 51))
(1 (51 53 13) (11 15))
(2 (51 54 45 35 31 11 15))
(3 (51 54 45 15 11) (31 35))
(4 (41 21 25) (54 14))
(5 (55 51 31 35 25 14 11))
(6 (31 35 25 14 11 41 52 55))
(7 (51 55 45 22 12))
(8 (12 21 51 54 45 15 12) (31 35))
(9 (11 14 25 55 52 41 31 35))
(λ (51 52 25 15) (11 21 43))
(> (51 52 25 15))
(% (11 51) (12 52) (13 53) (14 54) (15 55))
(^ (11 51) (12 42) (13 33) (14 24))
(< (11 21 43))
(|(| (55 54 43 23 14 15))
(|)| (51 52 43 23 12 11))))
(define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition))
(define (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width)
(send* (current-dc)
[set-brush "white" 'transparent]
[set-pen (make-pen #:color (->string (if (procedure? color-proc) (color-proc) color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter)])
(for/fold ([xoffset xoffset]
[yoffset yoffset])
([c (in-list (string->list str))])
(define g (findf (λ (g) (equal? ($glyph-name g) (string c))) glyphs))
(when g
(for ([p (in-list ($glyph-paths g))])
(send (current-dc) draw-path p
(+ xoffset (current-cell-size))
(+ yoffset (current-cell-size)))))
(values (+ xoffset (* (current-cell-size) char-edge-size)) yoffset)))
(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs)
(for ([layer (in-list (for/list ([i (in-range 0 (length attrs) 2)])
(list (list-ref attrs i) (list-ref attrs (add1 i)))))])
(type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer)))))
(define (render text layers [stroke-scale (/ 1 char-edge-size)] [name 'test])
(define lines (string-split text))
(define horiz (* (current-cell-size) (apply max (map string-length lines)) char-edge-size))
(define vert (* (current-cell-size) char-edge-size (length lines)))
(parameterize* ([current-bitmap (case (current-target)
[(svg) #false]
[else (make-bitmap horiz vert)])]
[current-dc
(case (current-target)
[(svg) (new svg-dc%
[width horiz]
[height vert]
[output (build-path
(find-system-path 'desk-dir)
(format "~a.svg" name))]
[exists 'replace])]
[else (new bitmap-dc% [bitmap (current-bitmap)])])]
[current-stroke-scale stroke-scale])
(case (current-target)
[(svg) (send* (current-dc) [start-doc ""][start-page])])
(send (current-dc) set-smoothing 'smoothed)
(for* ([(line lineidx) (in-indexed lines)]
[layer (in-list layers)])
(apply layer-type line
#:yoffset (* (current-cell-size) char-edge-size lineidx)
layer))
(case (current-target)
[(svg) (send* (current-dc) [end-page][end-doc])]
[(png) (send (current-bitmap) save-file (build-path
(find-system-path 'desk-dir)
(format "~a.png" name)) 'png)]
[(gui) (make-object image-snip% (current-bitmap))])))
(define (render-svg . args)
(parameterize ([current-target 'svg])
(apply render args)))
(define (render-png . args)
(parameterize ([current-target 'png])
(apply render args)))
(module+ main
(render "PoLEn" (for/list ([color (in-cycle '(Black White))]
[size (in-range 11 0 -2)])
(list color size))))

@ -4,6 +4,10 @@
(define raco-commands '(("pollen" (submod pollen/private/command raco) "issue Pollen command" #f)))
(define compile-omit-paths '("test" "tools" "server-extras" "scribblings/third-tutorial-files"))
;; it's redundant to test "pollen.scrbl" because it incorporates the other scribble sources by reference
(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl"))
;; don't test app.rkt because it launches the gui
(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl" "app"))
;; don't put #"p" in this list because it's not a #lang
(define module-suffixes '(#"pp" #"pm" #"pmd" #"ptree"))
(define gracket-launcher-names '("Pollen"))
(define gracket-launcher-libraries '("app/app.rkt"))

@ -8,6 +8,7 @@
"file-utils.rkt"
"log.rkt"
"../setup.rkt")
(provide start-project-server)
;; The use of dynamic-require throughout this file is intentional:
;; this way, low-dependency raco commands (like "version") are faster.
@ -158,6 +159,17 @@ version print the version" (current-server-port) (make-publish-di
(message (format "rendering ~a" (string-join (map ->string path-args) " ")))
(handle-batch-render path-args)]))))
(define (start-project-server dir
[http-port 8080]
[launch-wanted #false]
[localhost-wanted #false])
(when dir
(parameterize ([current-project-root dir]
[current-server-port (or http-port (setup:project-server-port))]
[current-server-listen-ip (and localhost-wanted "127.0.0.1")])
(message "starting project server ...")
((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted))))
(define (handle-start)
(define launch-wanted #f)
(define localhost-wanted #f)
@ -176,11 +188,7 @@ version print the version" (current-server-port) (make-publish-di
(string->number (cadr clargs))))
(when (and http-port (not (exact-positive-integer? http-port)))
(error (format "~a is not a valid port number" http-port)))
(parameterize ([current-project-root dir]
[current-server-port (or http-port (setup:project-server-port))]
[current-server-listen-ip (and localhost-wanted "127.0.0.1")])
(message "starting project server ...")
((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted)))
(start-project-server dir http-port launch-wanted localhost-wanted))
(define (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f])
(define user-publish-path

@ -58,15 +58,16 @@
;; print message to console about a request
(define/contract (logger req)
(request? . -> . void?)
(define localhost-client "::1")
(define localhost-names '("::1" "fe80::1%lo0" "127.0.0.1"))
(define url-string (url->string (request-uri req)))
(unless (ends-with? url-string "favicon.ico")
(message (match url-string
[(regexp #rx"/$") (string-append url-string " directory default page")]
[_ (string-replace url-string (setup:main-pagetree) " dashboard")])
(match (request-client-ip req)
[(== localhost-client) ""]
[client (format "from ~a" client)]))))
[client #:when (not (member client localhost-names))
(format "from ~a" client)]
[_ ""]))))
;; pass string args to route, then
;; package route into right format for web server

@ -1,7 +1,16 @@
#lang web-server/base
#lang racket/base
(require racket/runtime-path
racket/match
web-server/servlet-env
web-server/dispatch
web-server/web-server
web-server/servlet-dispatch
web-server/private/mime-types
(prefix-in files: web-server/dispatchers/dispatch-files)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
web-server/dispatchers/filesystem-map
net/url
net/sendurl
"project-server-routes.rkt"
"log.rkt"
"../setup.rkt"
@ -12,31 +21,53 @@
(define-runtime-path mime-types "server-extras/mime.types")
(define (start-server servlet-path [open-browser-window? #f])
(define-values (pollen-servlet _)
(define (make-static-dispatcher-sequence . pths)
(apply sequencer:make
(for/list ([pth (in-list pths)])
(files:make
#:path->mime-type (make-path->mime-type mime-types)
#:url->path (make-url->path (path->string pth))))))
(define-values (pollen-servlet _)
(dispatch-rules
[((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is ""
;; last element of a "/"-terminated url is ""
[((string-arg) ... "") route-index]
[((string-arg) ... (? pagetree-source?)) route-dashboard]
[((string-arg) ... "in" (string-arg) ...) route-in]
[((string-arg) ... "out" (string-arg) ...) route-out]
[else route-default]))
(message (format "welcome to Pollen ~a (Racket ~a)" pollen:version (version)))
(message (format "project root is ~a" (current-project-root)))
(define (start-server servlet-path [open-browser-window? #false] #:return [return? #false])
(define server-name (format "http://localhost:~a" (current-server-port)))
(message (format "welcome to Pollen ~a (Racket ~a)" pollen:version (version)))
(message (format "project root is ~a" (current-project-root)))
(message (format "project server is ~a (Ctrl+C to exit)" server-name))
(message (format "project dashboard is ~a/~a" server-name (setup:main-pagetree)))
(message (let ([clsi (current-server-listen-ip)])
(if clsi
(format "project server permitting access only to ~a"
(case clsi
[("127.0.0.1") "localhost"]
[else clsi]))
"project server permitting access to all clients")))
(message "ready to rock")
(define stop-func
(parameterize ([error-print-width 1000])
(serve/servlet pollen-servlet
#:launch-browser? open-browser-window?
#:servlet-path servlet-path
#:port (current-server-port)
(serve
#:dispatch (sequencer:make
(dispatch/servlet pollen-servlet)
(make-static-dispatcher-sequence
(current-project-root)
(current-server-extras-path))
(dispatch/servlet route-404))
#:listen-ip (current-server-listen-ip)
#:servlet-regexp #rx"" ; respond to top level
#:command-line? #true
#:file-not-found-responder route-404
#:mime-types-path mime-types
#:extra-files-paths (list (current-server-extras-path) (current-project-root)))))
#:port (current-server-port))))
(when open-browser-window?
(send-url (string-append server-name servlet-path)))
(if return?
stop-func
(with-handlers ([exn:break? (λ (e) (stop-func) (message "project server stopped"))])
(do-not-return))))
Loading…
Cancel
Save