[Fencommits] fenserve: potion saving

[Tuukka Hastrup]

Sun May 20 22:25:07 EEST 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * potion saving
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-20 22:26:06.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-20 22:26:06.000000000 +0300
@@ -311,6 +311,17 @@
     , s) where link new s = "<a href='potion?exp=" ++ show (subst (-1) new exp)
                          ++ "'>" ++ s ++ "</a>"
 
+makeFun :: Request -> MyState -> (String, MyState)
+makeFun msg s = 
+    ("<form action='addpotion' method='post'>\
+     \  <p><input name='name' value=''>\
+     \  <p><textarea name='template' rows='3' cols='80'>\
+     \  </textarea>\
+     \  <p><input type='submit' value='Submit'>\
+     \  <input type='hidden' name='exp' value='"++quote (show exp)++"'>\
+     \</form>", s) where
+  Just (exp :: Exp) = fmap read $ lookM msg "exp"
+
 editTemplate :: Request -> MyState -> (String, MyState)
 editTemplate msg s = 
     ("/potion?exp=" ++ concatMap escapeMore (escape (show (subst (-1) new exp)))
@@ -328,7 +339,13 @@
   f ('$':cs) = Str "" : (Var 0) : f cs
   f (c:cs) = (Str (c:r):rs) where (Str r:rs) = f cs
   f "" = [Str ""]
-  
+
+addPotion :: Request -> MyState -> (String, MyState)
+addPotion msg s = ("/", s { statePotions = newPotions }) where
+    Just name = lookM msg "name"
+    Just exp = fmap read $ lookM msg "exp"
+    potion = Fun [] [name] exp -- XXX
+    newPotions = Map.insert name potion $ statePotions s
 
 main = stdHTTP [ debugFilter
                , h (Prefix ["potion"]) GET $ ok $ \() -> run $ \(exp,args) s ->
@@ -336,7 +353,8 @@
                          lnk = case expand s exp of
                              Just e -> " [<a href='?exp="++quote (show e)++"'>"
                                     ++ "expand definition</a>]"
-                             Nothing -> ""
+                             Nothing -> " [<a href='makefun?exp="
+                                     ++ quote (show exp) ++ "'>save</a>]"
                      in (let ?state=s; ?link=True in renderExp exp id string ++ lnk ++ "<hr>\n"
                            ++ if (isComplete exp)
                                 then (head $ evalStateT (runExp env exp) s)
@@ -349,9 +367,10 @@
                      in (let ?state=s; ?link=True in renderExp exp id action ++ "<hr>\n" ++ r, s')
                , h (Prefix ["edit"]) GET $ ok $ \() -> run edit
                , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
-
+               , h ["makefun"] GET $ ok $ \() -> run makeFun
                , h () GET  $ ok $ \() () -> view
                , h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
                , h ["addcat"]   POST $ ok $ \() name -> addCategory name
+               , h ["addpotion"] POST $ seeOther $ \() -> runRedirect addPotion
                ]