[Fencommits] fenserve: links to add fields in the item view

[Tuukka Hastrup]

Wed May 23 17:02:29 EEST 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * links to add fields in the item view
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-23 17:03:00.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-23 17:03:00.000000000 +0300
@@ -261,11 +261,17 @@
                         ty <- lookM m "type"
                         return (read exp, read old, read ty)
 
-addField cat name = do
-    state <- get
-    let fs = stateSchema state Map.! cat
-    put $ state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state) }
-    view
+addField req state = ("item/"++item,state') where
+    state' = state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state),
+                     stateItems = Map.map addField' (stateItems state) }
+    fs = stateSchema state Map.! cat
+    addField' item@(Item fields cats) 
+                  | cat `Set.member` cats 
+                  = Item (Map.union fields (Map.singleton name "")) cats
+                  | otherwise = item
+    Just cat = lookM req "category"
+    Just item = lookM req "item"
+    Just name = lookM req "field" 
 
 addCategory (c:cs) s = ("table",
     s { stateSchema = Map.insert (toLower c : cs) [] $ stateSchema s})
@@ -420,7 +426,10 @@
 showItem item req s = let Item fields cats = stateItems s Map.! read item in (
     (("<form method=post>"++returnTo)++) . (++"<p><input type=submit></form>") .
     concatFor (Set.toList cats) $ \cat -> let cfs = stateSchema s Map.! cat in
-        (("<p>"++cat++":<br>")++) . concatFor cfs $ \field ->
+        (("<p>"++cat++":<br>")++) 
+        . (++ "<a href='/addField?item="++item++"&category="++cat
+           ++ "'>[add field to "++cat++"]</a><br>") 
+        . concatFor cfs $ \field ->
             field ++ ": <input name='" ++ quote field ++ "' "
          ++ "value='" ++ quote (fields Map.! field) ++ "'><br>",
     s) where returnTo = flip (maybe "") (lookM req "returnTo") $ \uri ->
@@ -467,7 +476,16 @@
                , h ["delItem"] POST $ seeOther $ \() -> runRedirect delItem
                
                , h [""] GET  $ ok $ \() () -> view
-               , h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
+               , h ["addField"] GET $ ok $ \() req -> 
+                   let Just cat = lookM req "category"
+                       Just item = lookM req "item"
+                   in respond $
+                     "<h2>Add field to category "++cat++"</h2>\
+                     \<form method=post>Field: <input name=field>\
+                     \<input type=hidden name=category value='"++cat++"'>\
+                     \<input type=hidden name=item value='"++item++"'>\
+                     \<input type=submit value='Submit'></form>"
+               , h ["addField"] POST $ seeOther $ \() -> runRedirect addField
                , h ["addCategory"]   GET  $ ok $ \() () -> respond $
                      "<h2>Add category</h2>\
                      \<form method=post>Name: <input name=name>\