Source

picoblogorg / org-http.l

Full commit
(load "@lib/http.l")
(load "org.l")
(load "picostache.l")

(allow "*Text" "*Username" "*Password")
(setq File "org/blog.org")
(setq *Dir "org")
(setq *Salt "zzzzz")

(de readLines (File)
 (make
	(in File
	 (until (eof)
		(link (pack (line)))))))

#hack to override picostache to use plists
(redef lookup (Key Lst) (cadr (seek '((X) (= Key (car X))) Lst))) 

(de read-org ()
  (let (Text (pack (in File (till NIL)))
         Lines (readLines File)
         Org (org-parse Lines 0))
		Org))

(de to-blog (X Type)
	(let (title (org-val 'name X)
				title (if (match '(~(chop "DONE ") @A) (chop title)) (pack @A) title)
				date (org-val "CLOSED" (org-val 'special X))
				dateParts (if (match '(@ @Y "-" @M "-" @D " " @Rest) (chop date)) (list (pack @Y) (pack @M) (pack @D)))
				slug (pack @Y "/" @M "/" @D "/" (replace (chop title) " " "-")))
		 (list 'title title
						'date date 
						'slug slug
						'dateParts dateParts
						'visibility Type
						'body (glue "<br>" (filter '((X) (not (match '(@A ~(chop "CLOSED:") @B) (chop X)))) (org-val 'body X))))))

(de union Lsts
	(make
		(for X Lsts
			(for C (eval X)
				(link C)))))

(de org-to-blog (Org)
   (let (Public (org-val 'children (org-find-heading "Blog" Org))
				 PublicBlog (mapcar '((X) (to-blog X "Public") ) Public)
				 Private (org-val 'children (org-find-heading "Private" Org))
				 PrivateBlog (mapcar '((X) (to-blog X "Private") ) Private))
		(union PublicBlog PrivateBlog)))

(de org-find-heading (Heading Org)
	(car (seek '((X) (= (org-val 'name (car X)) Heading)) Org)))

(de org-to-users (Org)
	(let Users (org-val 'children (org-find-heading "Users" Org))
		(mapcar '((X) 
			(let Props (org-val 'props X) 
				(list 
					 'Username (org-val 'name X) 
					 'Password (org-val 'PASSWORD Props)
					 'Group (org-val 'GROUP Props)))) Users)))	
	
(de md5 (Str Salt)
	(let Line (pipe (out '(md5sum) (prin (pack (list Str Salt)))) (pack (make (until (eof) (link (line T))))))
		(pack (car (split (chop Line) " ")))))
                        
(de crypt-string (Str Decrypt)
	(pipe (out (list 'sh "crypt.sh" (if Decrypt "-d" "-e")) (prin Str)) (pack (make (until (eof) (link (line T)))))))

(de encrypt-string (Str) (crypt-string Str NIL))

(de decrypt-string (Str) (crypt-string Str T))

#lots of opportunities for caching here
(de renderPage (Template Model)
   (let (Html (pack (readLines Template))
         TemplateTree (parse Html)
				 Content (renderTree Model TemplateTree)
				 LayoutHtml (pack (readLines "site.html"))
				 LayoutTree (parse LayoutHtml))
      (httpHead NIL NIL)
      (prinl (renderTree (list 'content Content) LayoutTree))))

(de get-username ()
	(let (Session (cdr (assoc 'Session *Cookies))
				SessionEncoded (pack (replace (chop Session) " " "+")))
				(if SessionEncoded (decrypt-string SessionEncoded))))

# trick to reload on every call
(daemon 'http (load "routes.l"))

(load "routes.l")

(de go ()
 (server 21000 "!list-all") )