[Fencommits] fenserve: some progress
Benja Fallenstein
benja.fallenstein at gmail.com
Tue May 15 20:14:20 EEST 2007
Tue May 15 20:13:45 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* some progress
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-15 20:14:19.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-15 20:14:19.000000000 +0300
@@ -1,10 +1,10 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
import HAppS hiding (Body, getPath)
-import Control.Monad.State hiding (State)
+import Control.Monad.State
import Data.Generics (Typeable)
import Data.Binary hiding (get,put)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromJust)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -19,10 +19,12 @@
deriving (Read, Show, Typeable)
catType name = Type ("which " ++ name ++ "?")
+string = Type "which string?"
data Fun = Fun [Type] [String] Exp
| FieldFun String String
| CatFun String
+ | AddItemFun String [String]
deriving (Read, Show, Typeable)
funTypes (Fun ts _ _) = ts
@@ -55,34 +57,51 @@
isComplete (Str _) = True
type Env = Map Int Value
-type Value = [String]
+type Value = String
-runExp :: (?state :: State) => Env -> Exp -> Value
-runExp env (Call fn args) = runFun fn $
- map (runExp env . fromMaybe (error "foo")) args
-runExp env (Forall v exp body) = [concatMap f (runExp env exp)] where
- f val = head $ runExp (Map.insert v [val] env) body
-runExp env (Var i) = env Map.! i
-runExp env (HTML exps) = [concatMap (head . runExp env) exps]
-runExp _ (Str s) = [s]
+runExp :: Env -> Exp -> StateT MyState [] Value
+runExp env (Call fn args) = do vals <- mapM (runExp env . fromJust) args
+ runFun fn vals
+runExp env (Forall v exp body) = do state <- get
+ let xs = evalStateT (runExp env exp) state
+ rs <- forM xs $ \x ->
+ runExp (Map.insert v x env) body
+ return $ concat rs
+runExp env (Var i) = return $ env Map.! i
+runExp env (HTML exps) = do rs <- mapM (runExp env) exps
+ return $ concat rs
+runExp _ (Str s) = return s
runFun (Fun _ _ body) args =
runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
-runFun (FieldFun cat name) [items] = map (f . read) items where
- f item = itemFields (stateItems ?state Map.! item) Map.! name
-runFun (CatFun cat) [] =
- [show n | (n, Item _ cs) <- Map.toList (stateItems ?state), cat `Set.member` cs]
-
-data State = State { stateItems :: Map Id Item,
- stateSchema :: Map String [String] }
+runFun (FieldFun cat name) [item] = do
+ state <- get
+ return $ itemFields (stateItems state Map.! read item) Map.! name
+runFun (CatFun cat) [] = do
+ state <- get
+ msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state), cat `Set.member` cs]
+runFun (AddItemFun cat fields) vals = do
+ s <- get; let items = stateItems s
+ let catFs = stateSchema s Map.! cat
+ m = Map.fromList $ [(f,"") | f <- catFs] ++ zip fields vals
+ item = Item m (Set.singleton cat)
+ put s { stateItems = Map.insert (nextId items) item items }
+ return "Done."
+
+nextId :: Map Id a -> Id
+nextId m = if Map.null m then 0 else fst (Map.findMax m) + 1
+
+data MyState = MyState { stateItems :: Map Id Item,
+ stateSchema :: Map String [String],
+ statePotions :: Map String Fun }
deriving (Read, Show, Typeable)
-instance Binary State where
+instance Binary MyState where
-instance StartState State where
- startStateM = return $ flip State
- (Map.fromList [("post", ["title", "author", "body", "date"])]) $
- Map.fromList [
+instance StartState MyState where
+ startStateM = return $ flip MyState
+ (Map.fromList [("post", ["title", "author", "body", "date"])])
+ (Map.fromList [
(0, Item (Map.fromList [("title", "Hello world!"),
("author", "Me"),
("body", "Here we come."),
@@ -93,7 +112,12 @@
("body", "Here I come."),
("date", "2007-05-15")])
(Set.fromList ["post"]))
- ]
+ ])
+ (Map.fromList [
+ ("list", Fun [] ["List of all posts"] potion)
+ , ("addPostForm", Fun [] ["foo"] addPostForm)
+ , ("addPost", addPost)
+ ])
potion = Forall 0 (Call (CatFun "post") []) $
HTML [Str "<h2>", Call (FieldFun "post" "title") v, Str "</h2>\n",
@@ -102,8 +126,20 @@
Str "<hr>"]
where v = [Just $ Var 0]
+addPostForm = Str "<h2>Add entry</h2>\n\
+ \<form action=/potion/addPost method=post>\n\
+ \<input type=hidden name=count value=3>\n\
+ \Title: <input name=arg1><br>\n\
+ \Author: <input name=arg2><br>\n\
+ \Body:<br><textarea name=arg3></textarea>\n\
+ \<input type=submit>\n\
+ \</form>"
+
+addPost = Fun [string, string, string] ["","","",""] $
+ Call (AddItemFun "post" ["title","author","body"]) [Just (Var i) | i <- [0..2]]
+
view = do
- (state :: State) <- get
+ (state :: MyState) <- get
let category (name,fields) = "<h3>" ++ name ++ "</h3>\n"
++ concatMap field fields
++ "<p>Add field: "
@@ -126,6 +162,10 @@
instance FromMessage String where
fromMessageM m = lookM m "name"
+instance FromMessage [Value] where
+ fromMessageM m = do let n = maybe 0 read (lookM m "count")
+ forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+
addField cat name = do
state <- get
let fs = stateSchema state Map.! cat
@@ -138,9 +178,19 @@
view
main = stdHTTP [ debugFilter
- , h ["potion"] GET $ ok $ \() () -> do
+ , h (Prefix ["potion"]) GET $ ok $ \[p] args -> do
s <- get
- respond $ head $ let ?state=s in runExp Map.empty potion
+ let fun = statePotions s Map.! p
+ respond $ head $ evalStateT (runFun fun args) s
+ , h (Prefix ["potion"]) POST $ ok $ \[p] args -> do
+ s <- get
+ let fun = statePotions s Map.! p
+ (r,s') = case runStateT (runFun fun args) s of
+ [result] -> result
+ xs -> ("Wrong number of results: "++show xs, s)
+ put s'
+ respond r
+
, h () GET $ ok $ \() () -> view
, h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
, h ["addcat"] POST $ ok $ \() name -> addCategory name
More information about the Fencommits
mailing list