[Fencommits] fenserve: more refactoring

[Benja Fallenstein]

Thu May 31 17:20:53 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * more refactoring
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-31 17:21:08.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-31 17:21:08.000000000 +0300
@@ -55,7 +55,20 @@
     forM [1..n] $ \i -> lookM req ("arg" ++ show i)
 
 
-addField req state = (returnTo,state') where
+addFieldGet = runGet
+  ( h2 ("Add field to category ", lookE "category")
+  , formP ""
+      ( "Field: " & textfield "name" ""
+      , channel ["category", "item"]
+      , hidden "returnTo" $ fromMaybe ("item/"++lookE "item") (lookIM "returnTo")
+      , submit "Submit" ) )
+      
+addFieldPost = runPost (lookE "returnTo")
+  [ u_schema $ Map.adjust (++ [lookE "name"]) (lookE "category")
+  , u_items $ Map.map $ fIf' (`hasCat` (lookE "category")) $ 
+        u_fields $ insertIfNew (lookE "name") "" ]
+
+{-addField req state = (returnTo,state') where
     state' = state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state),
                      stateItems = Map.map addField' (stateItems state) }
     fs = stateSchema state Map.! cat
@@ -66,7 +79,7 @@
     Just cat = lookM req "category"
     Just item = lookM req "item"
     Just name = lookM req "field" 
-    returnTo = fromMaybe ("item/"++item) (lookM req "returnTo")
+    returnTo = fromMaybe ("item/"++item) (lookM req "returnTo")-}
 
 addCategory req s = ("table",
     s { stateSchema = Map.insert (uncapitalize name) ["name"] $ stateSchema s}) where
@@ -96,7 +109,12 @@
         
 runGet page = ok $ \() () -> respond $ case evaluate (html $ header & page) of
     Right s -> s; Left e -> "Internal server error: " ++ show e
-
+    
+runPost uri fs = seeOther $ \() () -> 
+    case evaluate (foldl1 (flip (.)) fs ?state, uri) of
+        Right (s',u) -> put s' >> respond (u, html $ link u "link")
+        Left e -> respond $ ("", "Internal server error: " ++ show e)
+    
 potionPage fun args name s = (makePage title expandLink body, s) where
     exp = Call fun (map (Just . Str) $ args)
     title = let ?state=s; ?link=False; ?name=name in renderExp exp id string
@@ -216,7 +234,7 @@
 
 showTable = makePage ("List of "++plural cat++" in the database") ""
   ( tag "table" [P "border" "1"]
-      ( tag "tr" [] $ catFor cols $ \col -> tag "th" [] $ capitalize col)
+      ( tag "tr" [] $ catFor cols $ \col -> tag "th" [] $ capitalize col
       , tag "tr" [] $ tag "td" [P "colspan" $ length cols, 
                                 P "style" "text-align: center"]
           ( hif (null items) $ ital ( "There are no ", plural cat, 
@@ -227,11 +245,11 @@
               , button $ bold ("[New ", cat, "]") ) )
 
       , catFor (Map.toList allItems) $ \(id, Item fields cats) ->
-            if cat `Set.member` cats then tag "tr" [] $
+            hif (cat `Set.member` cats) $ tag "tr" [] $
                 catFor cols $ \col -> tag "td" [] $ 
                     qlink ("item/"++show id) [P "returnTo" "table"]
-                          (fields Map.! col)
-              else HTML "" )
+                          (fields Map.! col) ) )
+
     where cat = lookI "cat" (head $ Map.keys schema)
           items = flip filter (Map.toList allItems) $
                       \(_, Item _ cats) -> cat `Set.member` cats
@@ -310,15 +328,9 @@
                , h ["delItem"] POST $ seeOther $ \() -> runRedirect delItem
                
                , h [""] GET  $ seeOther $ \() -> runRedirect $ \() s -> ("potion/" ++ (case head $ stateSidebarPages s of (fn,args) -> fn ++ concat ["/"++a | a <- args]), s)
-               , h ["addField"] GET $ ok $ \() () -> respond $ html $
-                     ( h2 ("Add field to category ", lookE "category")
-                     , formP "" ( "Field: " & textfield "field" ""
-                                , channel ["category", "item"]
-                                , hidden "returnTo" $ lookI "returnTo" $
-                                      "item/"++lookE "item"
-                                , submit "Submit" ) )
-               , h ["addField"] POST $ seeOther $ \() -> runRedirect addField
-               , h ["addCategory"]   GET  $ ok $ \() () -> respond $ html $
+               , h ["addField"] GET $ addFieldGet
+               , h ["addField"] POST $ addFieldPost
+               , h ["addCategory"] GET $ runGet
                      ( h2 "Add category"
                      , formP "" ( "Name: " & textfield "name" ""
                                 , submit "Submit" ) )
diff -rN -u old-fenserve/fendata/PotionTypes.hs new-fenserve/fendata/PotionTypes.hs
--- old-fenserve/fendata/PotionTypes.hs	2007-05-31 17:21:08.000000000 +0300
+++ new-fenserve/fendata/PotionTypes.hs	2007-05-31 17:21:08.000000000 +0300
@@ -45,6 +45,9 @@
 data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
     deriving (Read, Show, Typeable, Data)
     
+hasCat :: Item -> String -> Bool
+hasCat i c = c `Set.member` itemCategories i
+    
 u_fields f i = i { itemFields = f (itemFields i) }
 u_categories f i = i { itemCategories = f (itemCategories i) }
 
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs	2007-05-31 17:21:08.000000000 +0300
+++ new-fenserve/fendata/Utils.hs	2007-05-31 17:21:08.000000000 +0300
@@ -8,14 +8,29 @@
 import Data.Char (toUpper, toLower)
 import Data.List (intersperse)
 import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 
+type Endo a = a -> a
+type Op a   = a -> a -> a
+
+
+fIf :: (a -> Bool) -> Op (a -> b)
+fIf p f g x = if p x then f x else g x
+
+fIf' :: (a -> Bool) -> Endo (a -> a)
+fIf' p f = fIf p f id
+
 for :: [a] -> (a -> b) -> [b]
 for = flip map
 
 concatFor :: [a] -> (a -> [b]) -> [b]
 concatFor = flip concatMap
 
+insertIfNew :: Ord k => k -> v -> Endo (Map k v)
+insertIfNew k v = Map.alter (Just . fromMaybe v) k
+
 
 escape' = concatMap escapeMore . escape where
   escapeMore '[' = "%5b"; escapeMore ']' = "%5d";