Commits

Joe Bogner  committed 8789380

add admin pages to create/edit

  • Participants
  • Parent commits cc07b76

Comments (0)

Files changed (7)

 {{#org}}
-<h3><a href="!article?{{slug}}">{{title}}</a> on {{date}}</h3>
+<h3><a data-Key="{{key}}" href="!article?{{slug}}">{{title}}</a> on {{date}}</h3>
 {{/org}}
 (load "org.l")
 (load "picostache.l")
 
-(allow "*Text" "*Username" "*Password")
+(allow "*Text" "*Username" "*Password" "*Title" "*ID" "*Visibility")
 # (setq File "example.org")
 # (setq *Dir ".")
 
 # you can store blog in a subdir so that it's independently version controlled from the source
-(setq File "org/blog.org")
-(setq *Dir "org")
+(setq File "orgg/blog.org")
+(setq *Dir "orgg")
 
 # change the salt!
 (setq *Salt "zzzzz")
 (de read-org ()
   (let (Text (pack (in File (till NIL)))
          Lines (readLines File)
+				 *Key 0
          Org (org-parse Lines 0))
 		Org))
 
 	(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))
+				key (org-val 'key 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
 						'slug slug
 						'dateParts dateParts
 						'visibility Type
+						'key key
 						'body (glue "<br>" (filter '((X) (not (match '(@A ~(chop "CLOSED:") @B) (chop X)))) (org-val 'body X))))))
 
 (de union Lsts
 (load "routes.l")
 
 (de go ()
- (server 21000 "!list-all") )
+ (server 21000 "!article-list") )
 
 (de org-flatten (Lst)
    (make
-      (recur (Lst)
+      (recur (Lst Par)
          (for Header Lst
-            (link Header)
-            (recurse (org-val 'children Header))))))
+            (link (cons 'parentKey (cons (org-val 'key Par) Header)))
+            (recurse (org-val 'children Header) Header)))))
 
 (de org-header-to-text (Header)
    (let (Name (org-val 'name Header)
 				 *Key 0)
          (org-parse Lines 0)))
 
-
 (de org-delete-by-key (Tree Key)
+	(org-replace-by-key Tree Key NIL))
+
+(de org-replace-by-key (Tree Key New)
    (make 
       (recur (Tree)
          (for X Tree
-            (unless (= (org-val 'key X) Key)
+						(if (and New (= (text (org-val 'key X)) (text Key)))
+							(link New))
+            (unless (= (text (org-val 'key X)) (text Key))
                (link (make 
                   (for (Prop X Prop (cddr Prop))
                      (unless (= (car Prop) 'children)
                         (link 'children)
                         (link (make (recurse (org-val 'children X)))))))))))
 
+(de org-add-child-by-key (Tree Key Child)
+   (make 
+      (recur (Tree)
+         (for X Tree
+						 (link (make 
+								(for (Prop X Prop (cddr Prop))
+									 (unless (= (car Prop) 'children)
+											(link (car Prop))
+											(link (cadr Prop))))
+											(link 'children)
+											(link (make 
+												(if  (= (org-val 'key X) Key)
+													(link Child))
+													(recurse (org-val 'children X))))))))))
+
 # not implemented
 (de org-move-by-key (Tree Key Steps) NIL)
 
 {{#next}}
 &nbsp; <b>Next:</b> <a href="!article?{{slug}}">{{title}}</a>
 {{/next}}
-{{/article}}
+{{#loggedin}}
+<br>
+<a href="/!article-edit?{{.}}">edit</a> 
+{{/loggedin}}
+<form action="{{Action}}" method="post">
+<style>
+label { display: block; float: left; width: 100px; }
+br { clear: both }
+</style>
+
+{{#Article}}
+<input type="hidden" name="*ID" value="{{key}}"/>
+<label> Visibility: </label> 
+<select name="*Visibility"><option value="Blog">Public</option><option value="Private">Private</option></select><br>
+<label>Title:</label> <input type="text" name="*Title" value="{{title}}"><br>
+<textarea name="*Text" style="width:800px;height:200px">{{body}}</textarea>
+<br/>
+<input type="submit" name="submit">
+{{/Article}}
+</form>
-(de list-all()
-	(let (Org (read-org)
-              Blog (org-to-blog Org)
-              Items (reverse (by '((X) (org-val 'date X)) sort Blog))
-              Articles (if (get-username) Items (filter '((X) (= "Public" (org-val 'visibility X)))  Items)))
-           (renderPage "list.html" (list 'org Articles))))
 
 (de _authenticate (User Pass)
 	(let (Users (org-to-users (read-org))
 				(renderPage "login.html" '(flash ("Invalid username or password"))))
 			(when User
 				(cookie 'Session (encrypt-string (str User)))
-				(redirect "!list-all")))))
+				(redirect "!article-list")))))
 
 (de logout()
 		(cookie 'Session NIL)
 		(redirect "!login"))
+
+(de article-list ()
+	(let (Org (read-org)
+              Blog (org-to-blog Org)
+              Items (reverse (by '((X) (org-val 'date X)) sort Blog))
+              Articles (if (get-username) Items (filter '((X) (= "Public" (org-val 'visibility X)))  Items)))
+           (renderPage "list.html" (list 'org Articles))))
 	
-(de article(p)
+(de article (p)
 	(let (Org (read-org)
               Blog (org-to-blog Org)
-							Articlex (find '((X) (= (org-val 'slug X) p)) Blog)
               Items (reverse (by '((X) (org-val 'date X)) sort Blog))
               Articles (if (get-username) Items (filter '((X) (= "Public" (org-val 'visibility X)))  Items))
 							Prev NIL
-							Next NIL)
+							Key NIL
+							Next NIL
+							Auth NIL)
 						(for (X Articles X (cdr X))
 							(T (= (org-val 'slug (car X)) p) (prog (setq Next (cadr X)) (setq Article (car X))))
 							(setq Prev (car X)))
-           (renderPage "page.html" (list 'article (list Article) 'next (list Next) 'prev (list Prev)))))
+					 (setq Key (org-val 'key Article))
+					 (setq Auth (if (get-username) (list Key)))
+           (renderPage "page.html" (list 'loggedin Auth 'article (list Article) 'next (list Next) 'prev (list Prev)))))
 
 (de admin() 
 	(let Username (get-username)
          (push 'Model 'text)
          (httpHead NIL NIL)
          (prinl (renderTree Model TemplateTree))))
+
+
+(de write-blog (Text)
+ (out File (prin Text))
+ (commit-blog))
+
+(de commit-blog ()
+ (chdir *Dir
+	(let Msg (in (list 'git "commit" "-a" "-m" "web update") (line))
+	 (out 2 (prin Msg)))))
+
+
+(de blog-heading-to-visibility (Heading)
+	(if (= Heading "Blog") "Public" "Private"))
+
+(de article-edit (sID)
+	(when (get-username)
+	 (let (Org (org-flatten (read-org))
+				 Heading (car (seek '((X) (= sID (text (org-val 'key (car X))))) Org))
+				 ParentKey (org-val 'parentKey Heading)
+				 ParentHeading (car (seek '((X) (= ParentKey (org-val 'key (car X)))) Org))
+				 Visibility (blog-heading-to-visibility (org-val 'name ParentHeading))
+				 Article (to-blog Heading Visibility)
+				 Body (chop (pack (mapcar '((X) (pack X "^J"))  (cdr (org-val 'body Heading)))))
+				 Body (pack (head (- (length Body) 1) Body)) # remove extra linefeed
+				 ArticleModel (list 'key sID 'title (org-val 'title Article) 'body Body)) 
+		(renderPage "post.html" (list 'Action "!article-update" 'Article (list ArticleModel))))))
+
+(de article-new ()
+	(when (get-username)
+		(renderPage "post.html" (list 'Action "!article-create" 'Article (list 1)))))
+
+(de _article-find-parent-key (Org Visibility)
+ (let Heading (org-find-heading Visibility Org)
+		(org-val 'key Heading)))
+
+(de _article-make-entry (Existing)
+	(let (Time (if Existing (org-val "CLOSED" (org-val 'special Existing))
+								(pack "[" (dat$ (date) "-") " " (head 3 (chop (day (date)))) " " (tim$ (time)) "]"))
+				Text (pack (diff (chop *Text) "^M"))
+				Text (mapcar pack (split (chop Text) "^J"))
+				Body (cons (pack "CLOSED: "  Time) Text))
+		 (list 'level 2 'name *Title 'body Body children NIL 'props NIL)))
+
+(de _article-new-id (Visibility)
+ (let (Org (read-org)
+			 Heading (org-find-heading Visibility Org)
+			 NewHeading (car (org-val 'children Heading)))
+	(org-val 'key NewHeading )))
+
+(de article-create ()
+	(when (and *Post (get-username))
+		(let (Org (read-org)
+					Visibility *Visibility
+					ParentKey (_article-find-parent-key Org Visibility)
+					Entry (_article-make-entry)
+					NewID NIL
+					NewOrg (org-add-child-by-key Org ParentKey Entry)
+					Text (org-to-text NewOrg))
+		 (write-blog Text)
+		 (redirect (pack "!article-edit?" (_article-new-id Visibility))))))
+
+(de article-update  ()
+	(when (and *Post (get-username))
+		(let (Org (org-flatten (read-org))
+					sID *ID
+					Heading (car (seek '((X) (= sID (text (org-val 'key (car X))))) Org))
+					Key (org-val 'key Heading)
+					Entry (_article-make-entry Heading)
+					NewID NIL
+					NewOrg (org-replace-by-key (read-org) Key Entry)
+					Text (org-to-text NewOrg))
+			 (write-blog Text)
+			 (redirect (pack "!article-edit?" sID)))))
+
+(de article-delete ()
+	(when (and *Post (get-username))
+		(let (Org (org-flatten (read-org))
+					sID *ID
+					Heading (car (seek '((X) (= sID (text (org-val 'key (car X))))) Org))
+					Key (org-val 'key Heading)
+					NewOrg (org-delete-by-key (read-org) Key)
+					Text (org-to-text NewOrg))
+			 (write-blog Text)
+			 (redirect "!article-list"))))
+
 (load "org-http.l")
 (load "routes.l")
 
+(de skip (Title . Rest)
+	(prinl Title " - SKIPPED"))
+
 (de should (Title . Rest)
 	(prin Title)
 	(unless (eval (car Rest))
 		(prinl))
 	(prinl))
 
-(de post Route
+(de http-post Route
  (pack (pipe
 	(eval Route)
 	(make (until (eof) (link (pack (line) "^J") ))))))
 
+(de http-post-p Route
+ (pack (pipe
+	(eval (car Route))
+	(make (until (eof) (link (pack (line) "^J") ))))))
+
 (should "get list of users"
 	(let Users (org-to-users (read-org))
 		(> (length Users) 0)))
 				*Username "test"
 				*Password "test"
 				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
-				Html (chop (post login)))
-		(match '(@ ~(chop "Location: !list-all") @) Html)))
+				Html (chop (http-post login)))
+		(match '(@ ~(chop "Location: !article-list") @) Html)))
 
 (should "show a message on bad login"
 	(let (*Post "Y" 
 				*Username "test"
 				*Password "NOPE!"
 				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
-				Html (chop (post login)))
+				Html (chop (http-post login)))
 		(match '(@ ~(chop "Invalid username or password") @) Html)))
+
+
+(de create-test-file ()
+	(let (Org (org-parse-text "* Blog^J** Post1^JCLOSED: 2012-01-01 Fri 01:00^Jtest^J* Private^J** Private1^JCLOSED: 2012-01-01 Fri 02:00^Jprivate")
+				Text (org-to-text Org))
+	 (out File (prin Text))
+	 Org))
+
+
+(should "render a list"
+	(let (File "test.org" 
+				Org (create-test-file)
+				Html (chop (http-post article-list)))
+		(match '(@ ~(chop "Post1") @) Html)))
+
+
+(should "show post form"
+	(let (File "test.org" 
+				User '(Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)	
+				Session (encrypt-string (str User))
+				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
+				*Cookies (list (cons 'Session Session))
+				Org (create-test-file)
+				Html (chop (http-post article-new)))
+		(match '(@ ~(chop "textarea") @) Html)))
+
+
+(should "post record"
+	(let (File "test.org" 
+				User '(Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)	
+				Session (encrypt-string (str User))
+				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
+				*Cookies (list (cons 'Session Session))
+				Org (create-test-file)
+				*Post "Y" 
+				*Text "hello world"
+				*Title "Post2"
+				commit-blog '((X))
+				PostHtml (chop (http-post article-create))
+				NewID (match '(@ ~(chop "!article-edit?") @ID "^J" @M) PostHtml)
+				Html (chop (http-post article-list)))
+			NewID))
+
+
+(should "show edit form"
+	(let (File "test.org" 
+				User '(Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)	
+				Session (encrypt-string (str User))
+				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
+				*Cookies (list (cons 'Session Session))
+				Org (create-test-file)
+				Html (chop (http-post-p (article-edit 1))))
+		(match '(@ ~(chop "textarea") @) Html)))
+
+
+(should "update a record"
+	(let (File "test.org" 
+				User '(Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)	
+				Session (encrypt-string (str User))
+				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
+				*Cookies (list (cons 'Session Session))
+				Org (create-test-file)
+				*Post "Y" 
+				*Text "hello world"
+				*Title "Post2"
+				commit-blog '((X))
+				PostHtml (chop (http-post-p (article-update "1")))
+				NewID (match '(@ ~(chop "!article-edit?") @ID "^J" @M) PostHtml)
+				Html (chop (http-post article-list)))
+			NewID))
+
+(should "delete a record"
+	(let (File "test.org" 
+				User '(Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)	
+				Session (encrypt-string (str User))
+				org-to-users '((X) '((Username "test" Password "28275a6d4cea51f96b9507893d5f0ad5" Group NIL)))
+				*Cookies (list (cons 'Session Session))
+				Org (create-test-file)
+				*Post "Y" 
+				*Text "hello world"
+				*Title "Post2"
+				*Visibility "Blog"
+				commit-blog '((X))
+				PostHtml (chop (http-post article-create))
+				NewID (match '(@ ~(chop "!article-edit?") @ID "^J" @M) PostHtml)
+				Html (chop (http-post article-list))
+				Saved (match '(@ ~(chop "Post2") @) Html)
+				*ID (car @ID)
+				DeleteResult (http-post article-delete)
+				Html (chop (http-post article-list))
+				Deleted (not (match '(@ ~(chop "Post2") @) Html)))
+			(and Saved Deleted)))