[Fencommits] fenserve: simple item editing interface (in Haskell)

[Benja Fallenstein]

Wed May 23 00:28:06 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * simple item editing interface (in Haskell)
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-23 00:28:22.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-23 00:28:22.000000000 +0300
@@ -4,7 +4,7 @@
 import Control.Monad.State
 import Data.Generics (Typeable, Data, everywhere, mkT)
 import Data.Binary hiding (get,put)
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, fromMaybe)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -389,9 +389,26 @@
 showTable :: () -> MyState -> (String, MyState)
 showTable () s = (
     concatFor (Map.toList $ stateItems s) $ \(_, Item fields _) ->
-        ("<p>"++) . concatFor (Map.toList fields) $ \(f:fs,v) ->
+        ("<p>"++) . (++"<hr>") . concatFor (Map.toList fields) $ \(f:fs,v) ->
             "<b>" ++ (toUpper f : fs) ++ ":</b> " ++ v ++ "<br>",
     s)
+    
+showItem :: String -> () -> MyState -> (String, MyState)
+showItem item () s = let Item fields cats = stateItems s Map.! read item in (
+    ("<form method=post>"++) . (++"<p><input type=submit></form>") .
+    concatFor (Set.toList cats) $ \cat -> let cfs = stateSchema s Map.! cat in
+        (("<p>"++cat++":<br>")++) . concatFor cfs $ \field ->
+            field ++ ": <input name='" ++ quote field ++ "' "
+         ++ "value='" ++ quote (fields Map.! field) ++ "'><br>",
+    s)
+    
+updateItem :: String -> Request -> MyState -> (String, MyState)
+updateItem item_s req s = (fst $ showItem item_s () s', s') where
+    item = read item_s
+    s' = s { stateItems = Map.insert item (Item fields' cats) (stateItems s) }
+    Item fields cats = stateItems s Map.! item
+    fields' = flip Map.mapWithKey fields $ \k v -> fromMaybe v (lookM req k)
+    
 
 main = stdHTTP [ debugFilter
                , h ["potion"] GET $ ok $ \() -> run $ 
@@ -406,6 +423,8 @@
                , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
                , h ["makefun"] GET $ ok $ \() -> run makeFun
                , h ["table"] GET $ ok $ \() -> run showTable
+               , h (Prefix ["item"]) GET $ ok $ \[item] -> run (showItem item)
+               , h (Prefix ["item"]) POST $ ok $ \[item] -> run (updateItem item)
                
                , h [""] GET  $ ok $ \() () -> view
                , h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name