main.fnl (16799B)
1 (import-macros { : define-tests : expect : expect= } :assert) 2 (local lfs (require :lfs)) 3 (local lcmark (require :lcmark)) 4 (local cqueues (require :cqueues)) 5 (local url (require :net.url)) 6 (local unistd (require :posix.unistd)) 7 (local magick (require :graphicsmagick)) 8 9 (local server (require :server)) 10 (local textile (require :textile)) 11 (local site (require :site)) 12 (local rss (require :rss)) 13 14 (local { : to-html } (require :html)) 15 (local { : string-stream : prepend : %% : trace : clone } (require :lib)) 16 (local { : Path } (require :path)) 17 18 (local { : view } (require :fennel)) 19 20 (local cripslock-dir (case (os.getenv "CRIPSLOCK_DIR") p (Path p))) 21 22 23 (fn route-request [method path matchers] 24 (accumulate [matched nil 25 _ pred (ipairs matchers) 26 &until matched] 27 (pred method path))) 28 29 (local route-matchers 30 [ 31 #(if (= $2 "/") [ :home { :limit 5 } ]) 32 #(if (= $2 "/refresh") [ :refresh {} ]) 33 #(if (string.match $2 "/news.rss") 34 (let [{: path : query} (url.parse $2) 35 topic (string.match path "^/topic/([%w_-]+)/")] 36 (and (or topic (= path "/news.rss")) 37 [ :rss { 38 :topic topic 39 :limit (tonumber (or query.limit 10)) 40 :offset (tonumber (or query.offset 0)) 41 }]))) 42 #(case (string.match $2 "^/(%d+)/(%d+)/") 43 (year month) 44 [ :month { :year (tonumber year) :month (tonumber month) } ] 45 foo (print :fo foo) 46 ) 47 #(case (string.match $2 "^/static/images/(%g+)") 48 path 49 (let [{ : path : query } (url.parse path) 50 w (case query.w 51 "full" nil 52 pixels (tonumber pixels) 53 nil 1024)] 54 [ :image { : path :width w }])) 55 #(case (string.match $2 "^/(static/%g+)") 56 path 57 [ :static { : path } ]) 58 59 #(let [{ : path : query } (url.parse $2)] 60 (if (= path "/search") 61 (let [terms query.terms] 62 [ :search {:terms terms }]))) 63 64 #(let [{ : path : query } (url.parse $2) 65 { : order : direction } query 66 direction (. { :ascending :ascending 67 :descending :descending } direction)] 68 (case (string.match path "^/topic/([%w_-]+)$") 69 slug [ :topic { : slug :order 70 (and order (doto {} (tset order direction))) } ])) 71 72 #(case (string.match $2 "^/([%w_]+)$") 73 slug [ :show { : slug }]) 74 ]) 75 76 (define-tests :route-request 77 (expect= (route-request :get "/" route-matchers) 78 [:home {:limit 5}]) 79 80 (expect= (route-request :get "/pagename" route-matchers) 81 [ :show { :slug "pagename" } ]) 82 83 (expect= (route-request :get "/2004/7/" route-matchers) 84 [ :month {:year 2004 :month 7 } ]) 85 86 (expect= (route-request :get "/static/cripslock.css" route-matchers) 87 [ :static {:path "static/cripslock.css" } ]) 88 89 (expect= (route-request :get "/static/images/broken.png" route-matchers) 90 [ :image {:path "broken.png" :width 1024} ]) 91 (expect= (route-request :get "/static/images/broken.png?w=42" route-matchers) 92 [ :image {:path "broken.png" :width 42} ]) 93 (expect= (route-request :get "/static/images/broken.png?w=full" route-matchers) 94 [ :image {:path "broken.png" } ]) 95 96 (expect= (route-request :get "/static/README" route-matchers) 97 [ :static {:path "static/README" } ]) 98 99 (expect= (route-request :get "/foo/static/README" route-matchers) nil) 100 (expect= (route-request :get "foo/static/README" route-matchers) nil) 101 102 (expect= (route-request :get "/topic/cripslock" route-matchers) 103 [ :topic {:slug "cripslock" } ]) 104 105 (expect= (route-request :get "/news.rss" route-matchers) 106 [ :rss {:limit 10 :offset 0 }]) 107 (expect= (route-request :get "/news.rss?offset=42" route-matchers) 108 [ :rss {:limit 10 :offset 42 }]) 109 (expect= (route-request :get "/news.rss?limit=9&offset=42" route-matchers) 110 [ :rss {:limit 9 :offset 42 }]) 111 112 (expect= (route-request :get "/topic/fish/news.rss" route-matchers) 113 [ :rss {:limit 10 :offset 0 :topic "fish"}]) 114 (expect= (route-request :get "/topic/fish//news.rss?offset=42" route-matchers) 115 [ :rss {:limit 10 :offset 42 :topic "fish" }]) 116 (expect= (route-request :get "/topic/fish////news.rss?limit=9&offset=42" route-matchers) 117 [ :rss {:limit 9 :offset 42 :topic "fish" }]) 118 119 (expect= (route-request :get "/topic/cripslock?order=date&direction=ascending" route-matchers) 120 [ :topic {:slug "cripslock" :order { :date :ascending }} ]) 121 ) 122 123 124 (fn content-type-for-path [pathname] 125 (if 126 (string.match pathname "%.css$") "text/css" 127 (string.match pathname "%.gif$") "image/gif" 128 (string.match pathname "%.html$") "text/html" 129 (string.match pathname "%.jpeg$") "image/jpeg" 130 (string.match pathname "%.jpg$") "image/jpeg" 131 (string.match pathname "%.svg$") "image/svg+xml" 132 (string.match pathname "%.txt$") "text/plain" 133 "application/octet-stream")) 134 135 (fn page-header [stream title] 136 (stream:write_chunk 137 (string.format 138 "<!DOCTYPE html>\n<html><head> 139 <link href=\"/static/css/default.css\" rel=\"stylesheet\"> 140 <link href=\"/static/css/boxy.css\" rel=\"stylesheet\"> 141 <link href=\"/news.rss\" rel=\"alternate\" title=\"RSS\" type=\"application/rss+xml\"><title>%s @ telent</title> 142 <script src=\"/static/boxy.js\" ></script> 143 <style> 144 img.floated { width: 40%%; float: right; clear: right; border: 1px #555 solid; background-color: #eee; padding: 2px; } 145 </style> 146 </head> 147 <body> 148 <header><a href=\"/\"><div class=\"title\">diary @ telent</div></a></header> 149 <div id=boxy></div> 150 <article>" 151 title))) 152 153 154 (fn stream-from-cq-stream [stream] 155 { :write #(stream:write_chunk $2 false) }) 156 157 158 (fn page-footer [stream] 159 (let [y (os.date "%Y") 160 s (stream-from-cq-stream stream)] 161 (to-html 162 [[:footer {:style "margin-top: 1em; clear: both;"}] 163 [:div 164 "Powered by " 165 [[:a {:href "https://gti.telent.net/dan/cripslock"}] 166 "cripslock"] 167 ". Copyright © 2001-" y " Daniel Barlow " 168 [[:a {:href "https://creativecommons.org/licenses/by-nc-nd/4.0/"}] 169 "CC BY-NC-ND"]]] 170 s))) 171 172 (fn month-name [m] 173 (. ["Jan" "Feb" "Mar" "Apr" "May" "Jun" 174 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] 175 m)) 176 177 (fn all-months [site] 178 (let [h 179 (accumulate [months {} 180 (_ post) (pairs (site:search {}))] 181 (let [{ : year : month } (os.date "*t" post.date)] 182 (tset months year 183 (doto 184 (or (. months year) {}) 185 (tset month month))) 186 months)) 187 years (doto (icollect [y _ (pairs h)] y) (table.sort #(> $1 $2)))] 188 (icollect [_ y (ipairs years)] 189 (let [ms (. h y) 190 links (fcollect [i 1 12 &into [:li [:b y]]] 191 (case (. ms i) 192 m [:span " " [[:a {:href (string.format "/%d/%d/" y m)}] 193 (month-name m) ]])) 194 ] 195 links)))) 196 197 198 199 (fn topics-html [topics] 200 (let [[min max] 201 (accumulate [[min max] [99999 0] 202 _ [count topic] (pairs topics)] 203 [(math.min min count) (math.max max count)]) 204 scale 205 (if (= min max) 206 #16 207 (fn [c] 208 (+ 15 209 (math.floor (* c (/ (- 24.0 12) (- max min)))))))] 210 [:div 211 [:h2 "Topics"] 212 (doto 213 (icollect [_ [count topic] 214 (pairs topics)] 215 [[:span {:class "topic"}] 216 " " 217 [[:a { :style (%% "font-size: %dpx" (scale count)) 218 :href (.. "/topic/" topic) }] 219 topic]]) 220 (table.insert 1 :div))])) 221 222 (fn sidebar [stream collection terms] 223 (let [s (stream-from-cq-stream stream) 224 topics (collection:weighted-topics) 225 ladder (all-months collection)] 226 (stream:write_chunk "<aside> 227 <div> <p> There are many more Daniel Barlows on the internet than 228 there were when I started writing this, This one is a computer 229 programmer, inline skater, cyclist, motorcyclist, occasional human 230 being. 231 232 <p> Shorter, swifter, and less 233 well-formed opinions are also available in the Fediverse at <a 234 href=\"https://axillae.telent.net/\">@dan@axillae.telent.net</a> 235 </div>") 236 (to-html 237 [[:div {:id :search}] 238 [:h2 "Search"] 239 [:p "Google has given up on me (it's mutual). Search previous entries."] 240 [[:form {:method :get :action "/search" }] 241 [[:input {:name :terms :type :text :value (or terms "")}]] 242 [[:input {:name :go :value "Search" :type :submit}]]]] 243 s) 244 (to-html (topics-html topics) s) 245 (to-html 246 [[:div {:id :archive}] 247 [:h2 "The Archive"] 248 (doto ladder (table.insert 1 :ul))] 249 s) 250 (stream:write_chunk "</ul></aside>"))) 251 252 253 (fn send-post [stream collection post excerpt?] 254 (let [path post.full-path 255 s (stream-from-cq-stream stream)] 256 (print :path path) 257 (post:div collection s))) 258 259 (fn send-search-results [stream format collection results] 260 (each [_ p (ipairs results)] 261 (send-post stream collection p (= format :excerpts)))) 262 263 (fn send-home-page [stream collection] 264 (server.headers stream { }) 265 (page-header stream "Recently") 266 (let [posts 267 (collection:search 268 { 269 :filter nil 270 :order {:date :descending} 271 :offset 0 272 :limit 5 273 })] 274 (send-search-results stream :posts collection posts)) 275 (sidebar stream collection) 276 (page-footer stream) 277 (stream:write_chunk "" true )) 278 279 (fn send-month-page [stream collection year month] 280 (server.headers stream { }) 281 (let [h1 (string.format "%s %d" (month-name month) year) 282 after (os.time {: year : month :day -2 }) 283 before (os.time {: year :month (+ month 1) :day 2 }) 284 (prevmonth nextmonth) 285 (case month 286 1 (values { :m 12 :y (- year 1) } { :m 2 :y year }) 287 12 (values { :m 11 :y year } { :m 1 :y (+ year 1) }) 288 n (values { :m (- n 1) :y year } { :m (+ n 1) :y year })) 289 link #(string.format "/%d/%d/" $1.y $1.m) 290 params { 291 :filter {:older before :newer after} 292 :order {:date :ascending} 293 :offset 0 294 } 295 posts (collection:search params) 296 s (stream-from-cq-stream stream)] 297 (page-header stream h1) 298 (send-search-results stream :posts collection posts) 299 (to-html 300 [[:div {:class "nav"}] 301 [:span 302 [[:a {:href (link prevmonth)}] 303 "⟪ " (month-name prevmonth.m) " " prevmonth.y]] 304 " " 305 [:span 306 [[:a {:href (link nextmonth)}] 307 (month-name nextmonth.m) " " nextmonth.y " ⟫"]]] 308 s) 309 310 (sidebar stream collection) 311 (page-footer stream) 312 (stream:write_chunk "" true ))) 313 314 (fn send-post-page [stream collection post] 315 (let [path post.full-path] 316 (server.headers stream { }) 317 (page-header stream post.title) 318 (send-post stream collection post) 319 (sidebar stream collection) 320 (page-footer stream) 321 (stream:write_chunk "" true))) 322 323 (fn send-topic-page [stream collection slug order] 324 (let [post (collection:get slug) 325 order (or order { :title :ascending }) 326 results (collection:search {:filter {:topic slug} 327 : order }) 328 s (stream-from-cq-stream stream)] 329 (server.headers stream { }) 330 (page-header stream (.. "Topic: " slug)) 331 (if post 332 (send-post stream collection post) 333 (to-html [:h1 slug] s)) 334 335 (to-html 336 [:div 337 [:h2 "In this topic"] 338 [[:div {:style "text-align: right"}] 339 "sort by " 340 [:span [[:a {:href "?order=date&direction=descending"}] "date"]] 341 " | " 342 [:span [[:a {:href "?order=title&direction=ascending"}] "title"]]] 343 (prepend :ul 344 (icollect [_ p (ipairs results)] 345 [:li 346 [[:a { :href p.url-path}] p.title] 347 ", " 348 (os.date "%d %b %Y" p.date) 349 ]))] 350 s) 351 (sidebar stream collection) 352 (page-footer stream) 353 (stream:write_chunk "" true))) 354 355 (fn send-search-page [stream collection terms] 356 (let [order { :similarity :descending } 357 results (collection:search {:filter {:terms terms} 358 : order }) 359 s (stream-from-cq-stream stream)] 360 (server.headers stream { }) 361 (page-header stream (.. "Searched for " terms)) 362 363 (to-html 364 [:div 365 [:h2 "Results"] 366 [[:div {:style "text-align: right"}] 367 "sort by " 368 [:span [[:a {:href "?order=date&direction=descending"}] "date"]] 369 " | " 370 [:span [[:a {:href "?order=title&direction=ascending"}] "title"]]] 371 (prepend :ul 372 (icollect [_ p (ipairs results)] 373 [:li 374 [[:a { :href p.url-path}] p.title] 375 ", " 376 (os.date "%d %b %Y" p.date) 377 ]))] 378 s) 379 (sidebar stream collection terms) 380 (page-footer stream) 381 (stream:write_chunk "" true))) 382 383 (fn send-rss [stream collection { : offset : limit : topic }] 384 (let [posts 385 (collection:search 386 { 387 :filter (and topic { : topic }) 388 :order {:date :descending} 389 :offset offset 390 :limit limit 391 })] 392 (server.headers stream 393 { :content-type "application/rss+xml; charset=utf-8" }) 394 (rss.feed stream "https://ww.telent.net" collection posts))) 395 396 (fn existing-file [name] 397 (let [n (tostring name)] 398 (and (unistd.access n) n))) 399 400 401 402 (fn write-scaled-image [path stream target-width] 403 (if target-width 404 (let [wand (magick.newMagickWand) 405 image (wand:readImage path) 406 w (wand:getImageWidth) 407 h (wand:getImageHeight) 408 target-height (// (* h target-width) w)] 409 (if (> w target-width) 410 (wand:scaleImage target-width target-height)) 411 (stream:write_body_from_string (wand:writeImageBlob))) 412 (with-open [f (io.open path :r)] 413 (stream:write_body_from_file f)))) 414 415 416 (fn dispatch [route stream collection] 417 (print (view route)) 418 (case route 419 [:show { : slug }] 420 (case (collection:get slug) 421 post (send-post-page stream collection post) 422 nil (server.headers stream { ":status" :404 } true)) 423 [:rss { : limit : offset : topic }] 424 (send-rss stream collection { : limit : offset : topic }) 425 [:refresh _] 426 (do 427 (print "refreshing") 428 (collection:refresh)) 429 [:month { : month : year }] 430 (send-month-page stream collection year month) 431 [:image { : path : width }] 432 (let [path (/ (Path "static/images") path) 433 realpath 434 (or (existing-file (collection:static-file path)) 435 (existing-file (/ cripslock-dir path)))] 436 (if realpath 437 (do 438 (server.headers stream 439 { :content-type (content-type-for-path realpath) }) 440 (write-scaled-image realpath stream width)) 441 (do 442 (server.headers stream 443 { :content-type "text/plain" 444 ":status" "404" 445 }) 446 (stream:write_body_from_string "Not found")))) 447 448 [:static { : path }] 449 (let [realpath 450 (or (existing-file (collection:static-file path)) 451 (existing-file (/ cripslock-dir path)))] 452 453 (with-open [f (io.open realpath :r)] 454 (server.headers stream 455 { :content-type (content-type-for-path realpath) }) 456 (stream:write_body_from_file f))) 457 [:home { : limit }] 458 (send-home-page stream collection) 459 [:search { : terms }] 460 (send-search-page stream collection terms) 461 [:topic { : slug &as p }] 462 (send-topic-page stream collection slug p.order) 463 464 )) 465 466 (fn http-handler [collection _ stream] 467 (let [req-headers (assert (stream:get_headers)) 468 path (req-headers:get ":path") 469 method (req-headers:get ":method") 470 route (route-request method path route-matchers)] 471 (server.log-request req-headers stream) 472 (if route 473 (dispatch route stream collection) 474 (server.headers stream { ":status" :404 } true)))) 475 476 (fn run [path port] 477 (let [event-loop (cqueues.new) 478 collection (site.for-pathname path) 479 myserver (server.new 480 { :onstream (partial http-handler collection) 481 :port (and port (tonumber port)) 482 })] 483 (event-loop:wrap #(myserver:loop)) 484 (event-loop:wrap #(collection:watch)) 485 (event-loop:loop))) 486 487 488 {: run }