From 66c51b0e714fa8a1c80784108191270babc8525e Mon Sep 17 00:00:00 2001 From: unwox Date: Sun, 31 Aug 2025 17:51:57 +0600 Subject: implement shop --- lib.fnl | 222 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 222 insertions(+) create mode 100644 lib.fnl (limited to 'lib.fnl') diff --git a/lib.fnl b/lib.fnl new file mode 100644 index 0000000..cb437a2 --- /dev/null +++ b/lib.fnl @@ -0,0 +1,222 @@ +(fn now [] + (os.date "%Y-%m-%d %H:%M:%S")) + +(fn improve-typography [text] + (var result + (-> text + (string.gsub "(\n|\r)" " ") + (string.gsub "%s+" " "))) + (let [nbsp-replaces ["на" "На" "и" "И" "в" "В" "о" "О" "с" "С" "со" "Со" "до" + "До" "для" "Для" "а" "А" "но" "Но" "на" "На" "я" "Я" "мы" + "Мы" "над" "Над" "под" "Под" "г." "Г." "ул." "Ул." + "д." "Д." "%d+"]] + (each [_ v (ipairs nbsp-replaces)] + (set result + (-> result + (string.gsub (.. "( " v ") ") "%1 ") + (string.gsub (.. "(%s" v ") ") " %1 ") + (string.gsub (.. "^(" v ") ") "%1 "))))) + result) + +(fn test-improve-typography [] + (assert (= (improve-typography "Я лежу на пляжу!") + "Я лежу на пляжу!")) + (assert (= (improve-typography "500 рублей мы сняли со счета!") + "500 рублей мы сняли со счета!")) + (assert (= (improve-typography "500 рублей мы + сняли со счета!") + "500 рублей мы сняли со счета!"))) + +(fn starts-with? [str start] + (= (string.sub str 1 (# start)) start)) + +(fn ends-with? [str end] + (= (string.sub str (- (# end))) end)) + +(fn trim-left [str pattern] + (local pattern (or pattern "%s")) + (str:match (.. "^" pattern "*(.-)$"))) + +(fn trim-right [str pattern] + (local pattern (or pattern "%s")) + (str:match (.. "^(.-)" pattern "*$"))) + +(fn trim [str pattern] + (local pattern (or pattern "%s")) + (str:match (.. "^" pattern "*(.-)" pattern "*$"))) + +(fn file-exists? [path] + (local f (io.open path "r")) + (and (~= f nil) (io.close f))) + +(fn parse-values [val] + (assert (= (type val) "string") "val must be string") + (accumulate [result {} k v (string.gmatch val "([%w-]+)=([%w-%%]+)")] + (do + (tset result k v) + result))) + +(fn handle-upload [db file description thumbnail-width] + (local description (or description "")) + ;; FIXME: check mimetype if we will allow uploads from users! + (let [type (_G.must (luna.fs.mimetype file.path)) + sanitized-name (-> file.name + (string.gsub "^[%./\\]+" "") + (string.gsub "[^a-zA-Z0-9-_.]" "_") + (string.gsub "%.+" ".")) + final-name (.. (_G.must (luna.crypto.random-string 8)) "-" sanitized-name) + thumbnail-name (.. "static/files/" final-name "-thumbnail.jpg") + thumbnail (if thumbnail-width + (_G.must + (luna.image.create-thumbnail + file.path thumbnail-name thumbnail-width)) + "")] + (_G.must + (luna.db.exec db + "INSERT INTO files(name, creation_time, type, size, description, thumbnail) + VALUES (?, ?, ?, ?, ?, ?)" + [final-name (now) type file.size description thumbnail-name])) + ;; FIXME: also handle file collisions + (os.execute (.. "mv " file.path " ./static/files/" final-name)) + + final-name)) + +(fn order-id [request] + (let [cookies-header (. request.headers :Cookie) + cookies (if cookies-header (parse-values cookies-header) {})] + cookies.order)) + +(fn with-tx [db f] + (let [tx (_G.must (luna.db.begin db))] + (local (ok? result) (pcall f tx)) + (if ok? + (do + (luna.db.commit tx) + result) + (do + (luna.db.rollback tx) + (error result))))) + +(fn empty-table? [t] + (= (next t) nil)) + +(fn empty? [v] + (or (= v nil) (= v ""))) + +(fn split [str delimiter] + (assert delimiter "delimiter must be specified") + (if (empty? str) + [] + (do + (local result {}) + (local len (# str)) + (var cursor 1) + (var (start end) (str:find delimiter)) + (while start + (when (< cursor start) + (table.insert result (str:sub cursor (- start 1)))) + (set cursor (+ end 1)) + (set (start end) (str:find delimiter cursor))) + (when (<= cursor len) + (table.insert result (str:sub cursor len))) + result))) + +(fn concat [...] + (local res []) + (var cur 1) + (each [_ t (pairs [...])] + (each [_ v (pairs t)] + (tset res cur v) + (set cur (+ 1 cur)))) + res) + +(fn merge [...] + (local res []) + (each [_ t (pairs [...])] + (each [k v (pairs t)] + (tset res k v))) + res) + +(fn append [t e] + (table.insert t e) + t) + +(fn equal-tables? [t1 t2] + (assert (= (type t1) "table") "t1 must be a table") + (assert (= (type t2) "table") "t2 must be a table") + + (if (~= (# t1) (# t2)) + false + (accumulate [res true + k1 v1 (pairs t1) &until (not res)] + (and (. t2 k1) (= v1 (. t2 k1)))))) + +(fn basket [db order-id] + (local items + (_G.must + (luna.db.query-assoc + db + "SELECT order_lines.id, + products.name, + products.title, + products.price_per AS \"price-per\", + STRING_AGG(product_images.name, ',') AS \"images\", + order_lines.quantity + FROM order_lines + INNER JOIN products ON products.name = order_lines.product_name + LEFT JOIN product_images ON products.name = product_images.product_name + WHERE order_lines.order_id = ? + GROUP BY order_lines.id + ORDER BY product_images.position" + [order-id]))) + (if (and (. items 1) (not (empty-table? (. items 1)))) + (icollect [_ item (ipairs items)] + (do + (when (. item :images) + (tset item :images (split (. item :images) ","))) + item)) + [])) + +(fn string->number [str] + (if str + (tonumber (pick-values 1 (str:gsub "[^0-9.]" ""))) + nil)) + +(fn authenticate-request [db request] + (let [cookies-header (. request.headers :Cookie) + cookies (if cookies-header (parse-values cookies-header) {}) + session-id cookies.auth] + (if (not (empty? session-id)) + (let [sessions + (_G.must + (luna.db.query-assoc + db + "SELECT id FROM auth_sessions + WHERE id = ? + AND expires_at > STRFTIME('%Y-%m-%d %H:%M:%S', DATETIME('now'))" + [session-id]))] + (< 0 (# sessions))) + false))) + +{: improve-typography + : starts-with? + : ends-with? + : trim + : trim-left + : trim-right + : file-exists? + : parse-values + : order-id + : handle-upload + : with-tx + : append + : equal-tables? + : empty-table? + : split + : concat + : merge + : empty? + : now + : basket + : string->number + : authenticate-request} -- cgit v1.2.3