[Fencommits] fenserve: 'add to sidebar' button; change logo URI

[Benja Fallenstein]

Thu May 24 22:00:12 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * 'add to sidebar' button; change logo URI
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-24 22:00:37.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-24 22:00:37.000000000 +0300
@@ -46,7 +46,7 @@
     deriving (Read, Show, Typeable, Data)
 
 data Type = Type { typeQuestion :: String }
-    deriving (Read, Show, Typeable, Data, Eq)
+    deriving (Read, Show, Typeable, Data, Eq, Ord)
 
 catType name = Type ("which " ++ name ++ "?")
 string = Type "which text?"
@@ -56,7 +56,7 @@
          | FieldFun String String
          | CatFun String
          | AddItemFun String [String]
-    deriving (Read, Show, Typeable, Data)
+    deriving (Read, Show, Typeable, Data, Eq, Ord)
 
 readFun :: MyState -> String -> Fun
 readFun s n | ((r,""):_) <- reads n = r
@@ -99,7 +99,7 @@
          | Forall Int Exp Exp
          | Concat [Maybe Exp]
          | Str String
-    deriving (Read, Show, Typeable, Data)
+    deriving (Read, Show, Typeable, Data, Eq, Ord)
 
 expType (Call fun _) = funType $ readFun ?state fun
 expType (Var _) = error "no type inference yet"
@@ -111,7 +111,7 @@
             (Exp -> Exp) -> Exp -> Type -> a -> HTML
 editLink f old t s | not ?link = toHTML s | otherwise =
   flip (tag "a") s [("class", "editLink"), ("href",
-      "edit?exp="++(show $ f $ Var (-1))++"&old="++show old++"&type="++show t
+      "/edit?exp="++(show $ f $ Var (-1))++"&old="++show old++"&type="++show t
     ++maybe "" ("&name="++) ?name)]
                   
 renderMaybeExp (Just exp) cx ty = renderExp' exp cx ty
@@ -188,7 +188,8 @@
 
 data MyState = MyState { stateItems :: Map Id Item,
                      stateSchema :: Map String [String],
-                     statePotions :: Map String Fun }
+                     statePotions :: Map String Fun,
+                     stateSidebarPages :: [Exp] }
              deriving (Read, Show, Typeable, Data)
 
 instance Binary MyState where
@@ -211,6 +212,7 @@
         (Map.fromList [
             ("Blog_post_archive", Fun [] [HTML "Blog post archive"] potion)
         ])
+        [Call "Blog_post_archive" []]
 
 potion = Forall 0 (Call (show $ CatFun "post") []) $
     Concat (map Just [Str "<h2>", Call (show $ FieldFun "post" "title") v, Str "</h2>",
@@ -314,8 +316,8 @@
         Left e -> respond $ ("", "Internal server error: " ++ show e)
 
 potionGet exp args name s =
-        ( if expandable then makePage rendered expandLink body else
-              makePage "Custom page" "" $
+        ( if expandable then makePage s rendered expandLink body else
+              makePage s "Custom page" "" $
               tag "div" [("style", "border: 1px solid black; \
                           \margin-bottom: 1em; padding: 1em; \
                           \padding-bottom: 0; font-weight: bold")]
@@ -327,7 +329,10 @@
     rendered = let ?state=s; ?link=True; ?name=name in renderExp exp id string
     env = Map.fromList $ zip [0..length args-1] args
     expanded = expand s exp; expandable = isJust expanded
-    expandLink = para $ bold $ link ("/potion?exp="++show e++"&name="++n) "[edit page]"
+    expandLink = (para $ link ("/potion?exp="++show e++"&name="++n) "[edit page]")
+             +++ if exp `elem` stateSidebarPages s then HTML "" else
+                 (para $ formP "/addToSidebar" (hidden "exp" (show exp)
+                                            +++ button "[add to sidebar]"))
         where Just (e,n) = expanded
     saveLinks = formP "addpotion" $ (+++hidden "exp" (show exp)) $
                 (+++link ("makefun?exp="++show exp) "[Save as...]") $
@@ -413,6 +418,11 @@
     f (c:cs) part = f cs (c:part)
     f "" part = ([reverse part], [])
 
+addToSidebar :: Request -> MyState -> (String, MyState)
+addToSidebar msg s = ("/potion?exp="++show exp, s') where
+    s' = s { stateSidebarPages = stateSidebarPages s ++ [read exp] }
+    Just exp = lookM msg "exp"
+
 commaList :: ToHTML a => [a] -> HTML
 commaList [] = toHTML ""
 commaList [x] = toHTML x
@@ -485,16 +495,21 @@
     s' = s { stateItems = Map.delete id $ stateItems s }
     Just id = fmap read $ lookM msg "item"
     
-makePage title sidebar body =
+makePage state title sidebar body =
     --(tag "title" [] title +++) .
     tag "body" [] $
     tag "div" [("class", "header")]
-      (etag "img" [("src", "http://flowerpot.kaijanaho.fi/~benja/tmp/logo.jpg"),
+      (etag "img" [("src", "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg"),
                    ("class", "logo")] +++
        h1 ("Fendata | " +++ title)) +++
     tag "div" [("class", "main")] (
         tag "div" [("class", "sidebar")] (
-            para "Welcome to Fendata!" +++ sidebar) +++
+            para "Welcome to Fendata!" +++
+            catFor (stateSidebarPages state) (\exp ->
+                let ?state=state; ?link=False; ?name=Nothing
+                 in para $ bold $ link ("/potion?exp="++show exp) $
+                    renderExp exp id string) +++
+            sidebar) +++
         tag "div" [("class", "content")] body) +++
     tag "div" [("class", "footer")]
         ("Fendata (c) 2007 by Benja Fallenstein and Tuukka Hastrup. " +++
@@ -542,5 +557,6 @@
                      \<input type=submit value='Submit'></form>"
                , h ["addCategory"]   POST $ seeOther $ \() -> runRedirect addCategory
                , h ["addpotion"] POST $ seeOther $ \() -> runRedirect addPotion
+               , h ["addToSidebar"] POST $ seeOther $ \() -> runRedirect addToSidebar
                ]