[Fencommits] fenserve: more progress, protect against data corruption when there is an error inside the app

[Benja Fallenstein]

Tue May 15 21:49:11 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * more progress, protect against data corruption when there is an error inside the app
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-15 21:49:33.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-15 21:49:33.000000000 +0300
@@ -10,6 +10,9 @@
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import qualified System.IO.Unsafe
+import qualified Control.Exception
+
 type Id = Int
 
 data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
@@ -216,24 +219,28 @@
     f (Just (Var j)) | j == i = repl
     f x = x
 
+--run :: (a -> MyState -> (String, MyState)) -> a -> blah
+run f x = do
+    state <- get; let r = f x state
+    case System.IO.Unsafe.unsafePerformIO $ Control.Exception.catch (Control.Exception.evaluate (length (show r) `seq` Right r)) (\e -> return $ Left e) of
+        Right (s, state') -> do put state'; respond s
+        Left e -> respond $ "Internal server error: " ++ show e
+
 main = stdHTTP [ debugFilter
-               , h (Prefix ["potion"]) GET $ ok $ \() (exp,args) -> do
-                     s <- get
+               , 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 -> ""
-                     respond $ let ?state=s in renderExp exp ++ lnk ++ "<hr>\n"
-                            ++ (head $ evalStateT (runExp env exp) s)
-               , h (Prefix ["potion"]) POST $ ok $ \() (exp,args) -> do
-                     s <- get
+                     in (let ?state=s in renderExp exp ++ lnk ++ "<hr>\n"
+                           ++ (head $ evalStateT (runExp env exp) s), 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)
-                     put s'
-                     respond $ let ?state=s in renderExp exp ++ "<hr>\n" ++ r
+                     in (let ?state=s in renderExp exp ++ "<hr>\n" ++ r, s')
 
                , h () GET  $ ok $ \() () -> view
                , h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name