site.fnl (12279B)
1 (import-macros { : define-tests : expect : expect= : expect-near} :assert) 2 (local lfs (require :lfs)) 3 (local { : realpath } (require :posix.stdlib)) 4 (local { : view } (require :fennel)) 5 (local cqueues (require :cqueues)) 6 (local notify (require :cqueues.notify)) 7 (local { : stem } (require :stem)) 8 9 (local textile (require :textile)) 10 (local lcmark (require :lcmark)) 11 (local { : to-html } (require :html)) 12 (local { : clone : prepend : parse-timestamp : trace : %% } (require :lib)) 13 (local { : Path } (require :path)) 14 15 16 (fn markup-bare-urls [str] 17 (pick-values 18 1 19 (string.gsub 20 str 21 "()(https-%:%/%/%g+)()" 22 (fn [s url e] 23 (if (and 24 (or (= s 1) (not (= (string.sub str (- s 1) (- s 1)) "("))) 25 (or (= e (# str)) (not (= (string.sub str e e) ")")))) 26 (%% "[%s](%s)" url url) 27 url))))) 28 29 (define-tests :markup-bare-urls 30 (expect= (markup-bare-urls " http://www.example.com ") 31 " [http://www.example.com](http://www.example.com) " 32 ) 33 (expect= (markup-bare-urls "http://www.example.com") 34 "[http://www.example.com](http://www.example.com)" 35 ) 36 (expect= (markup-bare-urls "hello http://www.example.com now") 37 "hello [http://www.example.com](http://www.example.com) now" 38 ) 39 (expect= (markup-bare-urls "hello https://www.example.net http://www.example.com now") 40 "hello [https://www.example.net](https://www.example.net) [http://www.example.com](http://www.example.com) now" 41 ) 42 (expect= (markup-bare-urls "[title](http://www.example.com now)") 43 "[title](http://www.example.com now)") 44 ) 45 46 (fn translate-markdown [site md] 47 ;; lcmark/cmark doesn't have any extension points that allow us 48 ;; to add actual new syntax so we're just going to postprocess 49 (let [subst-links 50 (fn [slug title] 51 (let [post (site:get slug)] 52 (if post 53 (%% "<a href=%q class=internal>%s</a>" 54 slug 55 (or title (. post :title))) 56 (or title slug))))] 57 (-> md 58 ; markup-bare-urls 59 (lcmark.convert "html" { :yaml_parser #($1) 60 }) 61 ;; this is brittle and yuck 62 (string.gsub "<img src=" "<img class=\"boxyimg floated\" src=") 63 64 (string.gsub "%[%[([%w_-]+)|(.-)%]%]" subst-links) 65 (string.gsub "%[%[([%w_-]+)%]%]" subst-links)))) 66 67 (fn post-header [post stream] 68 (stream:write 69 (string.format 70 "<div style=\"clear: both\" class=\"entry\" 71 data-slug=%q data-path=%q> 72 <h1 class=\"title\">%s<span class=\"permalink\"><a href=%q>#</a></span></h1> 73 <h2 class=\"date\">%s</h2> 74 " 75 post.slug post.path 76 post.title 77 post.url-path 78 (os.date "%c" post.date))) 79 (to-html 80 [:div 81 "Topics: " 82 (prepend 83 :span 84 (icollect [_ topic (pairs post.topics)] 85 [[:span {:class "topic"}] 86 " " 87 [[:a { :href (.. "/topic/" topic) }] topic]]))] 88 stream)) 89 90 (fn post-body [post site stream excerpt?] 91 (let [path post.full-path] 92 (with-open [f (io.open path :r)] 93 (when f 94 (f:seek :set post.body-offset) 95 (if (string.match path "%.textile$") 96 (each [_ el (ipairs (textile.parse f)) 97 &until (and excerpt? (> (f:seek :cur 0) 500))] 98 (to-html el stream)) 99 (stream:write 100 (translate-markdown site (f:read (if excerpt? 600 "*a"))))) 101 (when (and excerpt? (= (f:read 0) "")) 102 (to-html [[:div {:class :continuelink}] [:div [[:a { :href post.url-path}] "... continue reading"]]] stream)) 103 )))) 104 105 (fn post-div [post site stream excerpt?] 106 (post-header post stream) 107 (post-body post site stream excerpt?) 108 (stream:write "</div>")) 109 110 111 (fn frontmatter [stream] 112 (var bail? false) 113 (collect [l (stream:lines) 114 &until (or (= l "") bail?)] 115 (let [(k v) (string.match l "(.-): *(.+)")] 116 (if k 117 (values (string.lower k) v) 118 (set bail? true))))) 119 120 (define-tests :frontmatter 121 (with-open [stream (io.open "tests/post-with-headers.textile" :r)] 122 (let [headers (frontmatter stream)] 123 (expect= headers.title "What I miss most about Lisp") 124 (expect= headers.author "Daniel Barlow") 125 ;; headers names are downcased 126 (expect= headers.x-parrot "norweigan blue") 127 (expect= headers.date "Sat Apr 30 23:23:33 2011") 128 ;; leaves stream position at first body line 129 (expect= (stream:read "l") "first content line")))) 130 131 (fn slug-for [title] 132 (-> title 133 (string.gsub "[^A-Za-z0-9]+" "_") 134 (string.gsub "_+$" "") 135 string.lower)) 136 137 (fn count-terms [s] 138 (let [terms {}] 139 (each [w (string.gmatch s "%w+")] 140 (let [lowercase (stem (w:lower))] 141 (tset terms lowercase (+ (or (. terms lowercase) 0) 1)))) 142 (let [most-common-count 143 (accumulate [max 0 144 term count (pairs terms)] 145 (if (> count max) count max))] 146 (each [term count (pairs terms)] 147 (tset terms term (/ count most-common-count)))) 148 terms)) 149 150 (define-tests :terms 151 (expect= (count-terms "apple banana. sofa") 152 {:appl 1.0 :banana 1.0 :sofa 1.0}) 153 (expect= (count-terms "apple sofa Apple") 154 {:appl 1.0 :sofa 0.5}) 155 (expect= (count-terms "sit sitting") 156 {:sit 1.0}) 157 ) 158 159 (fn read-stemmed-terms [stream] (count-terms (stream:read "*a"))) 160 161 (fn index-posts [path] 162 (collect [name (lfs.dir path)] 163 (let [fullname (.. path "/" name) 164 (attr err) (lfs.attributes fullname)] 165 (when (not attr) (print :err err)) 166 (if (and attr 167 (= attr.mode :file) 168 (or 169 (string.match name "%.textile$") 170 (string.match name "%.md$"))) 171 (with-open [f (io.open fullname)] 172 (let [fields (frontmatter f) 173 title (or fields.subject fields.title) 174 slug (or fields.slug (slug-for title)) 175 topics 176 (if fields.topics 177 (collect [w (string.gmatch fields.topics "(%g+)")] 178 (values w w)) 179 {})] 180 (values slug 181 (doto fields 182 (tset :path name) 183 (tset :full-path fullname) 184 (tset :url-path (.. "/" slug)) 185 (tset :slug slug) 186 (tset :title title) 187 (tset :topics topics) 188 (tset :body post-body) 189 (tset :div post-div) 190 (tset :body-offset (f:seek :cur 0)) 191 (tset :terms (or (read-stemmed-terms f) 192 (error (.. "no terms in " name)))) 193 (tset :date (and fields.date (parse-timestamp fields.date))))))))))) 194 195 ;; for each term in each document, 196 ;; idf is log(number of docs with the term/number of docs) 197 198 (fn doc-frequencies [posts] 199 (let [df {}] 200 (each [_ post (pairs posts)] 201 (each [term _ (pairs post.terms)] 202 (tset df term (+ 1 (or (. df term) 0))))) 203 df)) 204 205 (define-tests :doc-frequencies 206 (let [posts (index-posts "tests/posts/") 207 freqs (doc-frequencies posts)] 208 (expect= freqs.year 1) 209 (expect= (. freqs (stem "windmill")) 1) 210 (expect= (. freqs (stem "porsche")) 1) 211 (expect= (. freqs (stem "bike")) 2) 212 (expect= (. freqs (stem "duck")) 3))) 213 214 215 (fn safe-relative-path [basedir name] 216 (.. (-> basedir Path tostring) 217 (-> name Path (: :canonicalise) (: :relativise) tostring))) 218 219 (define-tests :safe-relative-path 220 (expect= (safe-relative-path "/doc/root/" "/index.html") "/doc/root/index.html")) 221 222 223 224 (fn topics [posts] 225 (let [counts {}] 226 (each [_ post (pairs posts)] 227 (each [_ t (pairs post.topics)] 228 (tset counts t t))) 229 counts)) 230 231 (fn weighted-topics [posts] 232 (let [counts {}] 233 (each [_ post (pairs posts)] 234 (each [_ t (pairs post.topics)] 235 (tset counts t (case (. counts t) n (+ n 1) nil 1)))) 236 (doto 237 (icollect [topic count (pairs counts)] 238 [count topic]) 239 (table.sort (fn [a b] (> (. a 1) (. b 1))))))) 240 241 (fn dot-product [a b] 242 (accumulate [sum 0 243 term fa (pairs a)] 244 (let [fb (. b term)] 245 (if fb 246 (+ sum (* fa fb)) 247 sum)))) 248 249 (fn magnitude [v] 250 (math.sqrt 251 (accumulate [product 0 252 _ l (pairs v)] 253 (+ product (* l l))))) 254 255 (fn similarity [a b] 256 (/ (dot-product a b) (* (magnitude a) (magnitude b)))) 257 258 (define-tests :similarity 259 (expect-near (magnitude {:a 1 :b 1}) (math.sqrt 2)) 260 (expect= (similarity {:a 1} {:b 1}) 0.0) 261 (expect= (similarity {:a 1} {:a 1}) 1.0) 262 ;; haven't verified these two 263 (expect-near (similarity {:a 1 :b 0.5} {:a 2 :b 6 :c 2}) 0.67419986246324) 264 (expect-near (similarity {:a 3 :p 2} {:p 0.5}) 0.55470019622523) 265 ) 266 267 268 (fn filter-terms [posts df terms] 269 (let [terms (collect [term (string.gmatch terms "(%w+)")] 270 (values (stem term) 1)) 271 docs (accumulate [sum 0 _ _ (pairs posts)] (+ sum 1))] 272 273 (icollect [_ post (pairs posts)] 274 (let [tfidf (collect [term tf (pairs post.terms)] 275 (values term (* tf (math.log (/ docs (. df term)))))) 276 sim (similarity terms tfidf)] 277 (if (> sim 0) 278 (doto (clone post) (tset :similarity sim))))))) 279 280 (define-tests :filter-terms 281 (let [posts (index-posts "tests/posts") 282 df (doc-frequencies posts) 283 matches (filter-terms posts df "motorbike")] 284 (expect= (# matches) 2) 285 (let [names (icollect [_ p (pairs matches)] p.path)] 286 (table.sort names) 287 (expect= 288 names ["20260102_Magic_DNS.md" "e0b74727-b5b3-4091-92f3-936a758b286b.md"] 289 )))) 290 291 ;; which fields are we allowing to sort result on 292 (local order-fields 293 (collect [_ k (ipairs [:date :title :similarity])] (values k k))) 294 295 (fn search-posts [posts df { : filter : order : offset : limit &as opts }] 296 (let [topics (topics posts) 297 posts (if (and filter filter.terms) (filter-terms posts df filter.terms) posts) 298 posts 299 (icollect [_ post (pairs posts)] 300 (when 301 (and (not (. topics post.slug)) 302 (case filter 303 { : newer : older } 304 (and post.date (> post.date newer) (< post.date older)) 305 { : topic } 306 (. post.topics topic) 307 _ true)) 308 post))] 309 (if order 310 (let [(field dir) ((pairs order) order) 311 field (or (. order-fields field) :date) 312 cmp (fn [a b] 313 (let [aa (or (. a field) 0) 314 bb (or (. b field) 0)] 315 (< aa bb)))] 316 (table.sort 317 posts 318 (if (= dir :ascending) cmp #(cmp $2 $1))))) 319 (if (or limit offset) 320 (let [some-posts [] 321 start (+ 1 (or offset 0)) 322 stop (if limit (+ start (- limit 1)) (# posts))] 323 (table.move posts start stop 1 some-posts) 324 some-posts) 325 posts))) 326 327 (fn watch-changes [site] 328 (let [n (notify.opendir site.path notify.ALL)] 329 (while true 330 (each [_ p (ipairs (site:search {}))] 331 ;; inotify(7) says adding the same file twice is ok, it just 332 ;; updates the existing watch 333 (n:add p.path)) 334 (case (n:get) 335 (flags name) 336 (do 337 (print "file change event" flags name) 338 ;; wait half a second before reloading in case there are 339 ;; more events 340 (while (= (cqueues.poll n 0.5) n) 341 (print "also" (n:get))) 342 (print "reloading posts" site.path) 343 (site:refresh)))))) 344 345 (fn for-pathname [path] 346 (var posts {}) 347 (var frequencies {}) 348 (doto 349 { 350 :get #(. posts $2) 351 :search #(search-posts posts frequencies $2) 352 :path path 353 :static-file (fn [_ name] 354 (safe-relative-path path name)) 355 :topics #(topics posts) 356 :weighted-topics #(weighted-topics posts) 357 :refresh (fn [self] 358 (set posts (index-posts path)) 359 (set frequencies (doc-frequencies posts)) 360 self) 361 :watch watch-changes 362 } 363 (: :refresh))) 364 365 366 { : for-pathname }