[Fencommits] fenserve: fix the handling of path infos

[Tuukka Hastrup]

Sun May 20 23:53:54 EEST 2007  Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
  * fix the handling of path infos
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-20 23:55:34.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-20 23:55:34.000000000 +0300
@@ -241,6 +241,10 @@
                         exp <- lookM m "exp"
                         return (read exp, vals)
 
+instance FromMessage [Value] where
+    fromMessageM m = do let n = maybe 0 read (lookM m "count")
+                        forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+
 instance FromMessage (Exp, Exp, Type) where
     fromMessageM m = do exp <- lookM m "exp"
                         old <- lookM m "old"
@@ -290,6 +294,27 @@
         Right (s, state') -> do put state'; respond (s, "<a href='"++quote s++"'>link</a>")
         Left e -> respond $ ("", "Internal server error: " ++ show e)
 
+potionGet exp args s = (let ?state=s; ?link=True in 
+                        renderExp exp id string ++ lnk ++ "<hr>\n"
+                     ++ if (isComplete exp)
+                        then (head $ evalStateT (runExp env exp) s)
+                        else "(Incomplete expression.)"
+                       , s) where
+    env = Map.fromList $ zip [0..length args-1] args
+    lnk = case expand s exp of
+              Just e -> " [<a href='?exp="++quote (show e)++"'>"
+                     ++ "expand definition</a>]"
+              Nothing -> " [<a href='makefun?exp="
+                      ++ quote (show exp) ++ "'>save</a>]"
+
+potionPost exp args s = (let ?state=s; ?link=True in 
+                         renderExp exp id action ++ "<hr>\n" ++ r
+                        , s') where
+    env = Map.fromList $ zip [0..length args-1] args
+    (r,s') = case runStateT (runExp env exp) s of
+                 [result] -> result
+                 xs -> ("Wrong number of results: "++show xs, s)
+
 edit :: (Exp,Exp,Type) -> MyState -> (String, MyState)
 edit (exp,old@(HTML olds),ty) s = let ?state = s; ?link = False in
     ("<form action='editTemplate' method='get'>\
@@ -354,27 +379,18 @@
     f "" name = [reverse name]
 
 main = stdHTTP [ debugFilter
-               , h (Prefix ["potion"]) GET $ ok $ \() -> run $ \(exp,args) s ->
-                     let env = Map.fromList $ zip [0..length args-1] args
-                         lnk = case expand s exp of
-                             Just e -> " [<a href='?exp="++quote (show e)++"'>"
-                                    ++ "expand definition</a>]"
-                             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)
-                                else "(Incomplete expression.)", s)
-               , h (Prefix ["potion"]) POST $ ok $ \() -> run $ \(exp,args) s ->
-                     let env = Map.fromList $ zip [0..length args-1] args
-                         (r,s') = case runStateT (runExp env exp) s of
-                             [result] -> result
-                             xs -> ("Wrong number of results: "++show xs, s)
-                     in (let ?state=s; ?link=True in renderExp exp id action ++ "<hr>\n" ++ r, s')
-               , h (Prefix ["edit"]) GET $ ok $ \() -> run edit
+               , h ["potion"] GET $ ok $ \() -> run $ 
+                   \(exp,args) s -> potionGet exp args s
+               , h ["potion"] POST $ ok $ \() -> run $ 
+                   \(exp,args) s -> potionPost exp args s
+               , h (Prefix ["potion"]) GET $ ok $ \[fun] -> run $ 
+                   \(args) s -> potionGet (Call fun (map (Just . Str) args)) args s
+               , h (Prefix ["potion"]) POST $ ok $ \[fun] -> run $ 
+                   \(args) s -> potionPost (Call fun (map (Just . Str) args)) args s
+               , h ["edit"] GET $ ok $ \() -> run edit
                , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
                , h ["makefun"] GET $ ok $ \() -> run makeFun
-               , h () GET  $ ok $ \() () -> view
+               , 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