[Fencommits] fenserve: cache compiled code. nice, this makes it quite fast after the code is compiled :)

[Benja Fallenstein]

Sun Mar 25 22:58:08 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * cache compiled code. nice, this makes it quite fast after the code is compiled :)
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs	2007-03-25 22:58:21.000000000 +0300
+++ new-fenserve/FenServe.hs	2007-03-25 22:58:21.000000000 +0300
@@ -27,19 +27,21 @@
 import HAppS hiding (query, Handler)
 
 import Control.Monad (liftM)
+import Control.Monad.Error (throwError, runErrorT)
 import Control.Monad.State (State, StateT, runStateT,
                             get, gets, put, modify, execState)
-import Control.Monad.Trans (lift)
+import Control.Monad.Trans (lift, liftIO)
 
 import qualified Data.ByteString as ByteString
 import Data.ByteString (ByteString)
 import Data.Generics
+import Data.IORef
 import qualified Data.List as List
 import qualified Data.Map as Map
 import Data.Map (Map)
 import qualified Data.Set as Set
 import Data.Set (Set)
-import Data.Maybe (fromMaybe, fromJust)
+import Data.Maybe (fromMaybe, fromJust, isJust)
 import Data.Typeable
 
 import Language.Haskell.Hsx as Hsx
@@ -270,12 +272,20 @@
            "qualified Data.ByteString as ByteString",
            "qualified Data.List as List",
            "qualified Data.Map as Map"]
+           
+codeCache :: IORef (Map BlockId Handler)
+codeCache = unsafePerformIO $ newIORef Map.empty
 
 execute :: Node -> Request -> FenServe Result
-execute code req = do
-    s <- getBlock (bID code)
-    let errH stage msg = return $ (,) Nothing $ \req -> return $ 
-            mkResult 500 "text/plain" $ toUTF $ stage ++ " failed:\n" ++ msg
+execute code req = getBlock (bID code) >>= \s ->
+                   let f (Left msg) = return $ mkResult 500 "text/plain" $ toUTF $ msg
+                       f (Right h) = h req
+                    in f $ unsafePerformIO $ runErrorT $ do
+
+    cached <- liftM (Map.lookup $ bID code) $ liftIO $ readIORef codeCache
+    if isJust cached then return (fromJust cached) else do
+
+    let err stage msg = throwError (stage ++ " failed:\n" ++ msg)
         mname = "Page_" ++ (blockId $ bID code)
         s2 = "module " ++ mname ++ " where\n" ++
                      concatMap (\i -> "import "++i++"\n") imports ++
@@ -283,36 +293,31 @@
                      -- the 'dummyAssignment' is to make sure that
                      -- pages can't import anything -- imports are
                      -- syntactically disallowed except at the beginning
-    (m,h) <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ s2 of
-        ParseFailed (SrcLoc file line col) err -> errH "HSP preprocessing" $ 
-            "At "++show line++":"++show col++" in "++file++": "++err
-        ParseOk parsed -> return $ unsafePerformIO $ do
-           let s' = Hsx.prettyPrintWithMode (Hsx.defaultMode 
-                       {Hsx.linePragmas=True}) $ Hsx.transform parsed
-                       
-           putStrLn (unlines $ take 10 $ lines s')
-
-           let fp = "/tmp/"++mname++".hs"
-           hdl <- openFile fp WriteMode
-           hPutStr hdl s'
-           hClose hdl
-           let dir = "dist/build"
-           homedir <- getEnv "HOME"
-           makeResult <- Plugins.make fp ["-fglasgow-exts", "-fallow-overlapping-instances"]
-           h' <- case makeResult of
-               Plugins.MakeFailure err -> 
-                   errH "Make" $ concat (List.intersperse "\n" err)
-               Plugins.MakeSuccess _ o -> do
-                   loadResult <- Plugins.load o [] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
-                   case loadResult of
-                       Plugins.LoadSuccess m v -> return (Just m,v)
-                       Plugins.LoadFailure err ->
-                           errH "Load" $ concat (List.intersperse "\n" err)
-           Plugins.makeCleaner fp; return h'
-    result <- h req -- run the loaded handler
-    case m of Just m' -> unsafePerformIO $ do --Plugins.unload m'
-                                              return (return result)
-              Nothing -> return result
+                     
+    parsed <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ s2 of
+            ParseFailed (SrcLoc file line col) e -> err "HSP preprocessing" $ 
+                "At "++show line++":"++show col++" in "++file++": "++e
+            ParseOk parsed -> return parsed
+
+    let s' = Hsx.prettyPrintWithMode (Hsx.defaultMode {Hsx.linePragmas=True}) $
+                 Hsx.transform parsed
+        fp = "/tmp/"++mname++".hs"
+
+    hdl <- liftIO $ openFile fp WriteMode
+    liftIO $ hPutStr hdl s'
+    liftIO $ hClose hdl
+    homedir <- liftIO $ getEnv "HOME"
+    makeResult <- liftIO $ Plugins.make fp ["-fglasgow-exts", "-fallow-overlapping-instances"]
+    o <- case makeResult of
+        Plugins.MakeFailure e -> err "Make" $ concat (List.intersperse "\n" e)
+        Plugins.MakeSuccess _ o -> return o
+    loadStatus <- liftIO $ Plugins.load o [] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
+    h <- case loadStatus of
+        Plugins.LoadFailure e -> err "Load" $ concat (List.intersperse "\n" e)
+        Plugins.LoadSuccess _ h -> return h
+    liftIO $ Plugins.makeCleaner fp
+    liftIO $ modifyIORef codeCache (Map.insert (bID code) h)
+    return h
 
 
 -------------------------------------------------------------------------