[Fencommits] fenserve: refactor to make code resources' interface be a Handler that takes a request and returns a response

Benja Fallenstein benja.fallenstein at gmail.com
Thu Mar 22 19:49:12 EET 2007


Wed Mar 21 21:11:00 EET 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * refactor to make code resources' interface be a Handler that takes a request and returns a response
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs	2007-03-22 19:49:12.000000000 +0200
+++ new-fenserve/FenServe.hs	2007-03-22 19:49:12.000000000 +0200
@@ -78,8 +78,12 @@
 
 type Ptr = (Node, Pool)
 
-type Response = Result
-type Handler = Request -> State Ptr Response
+type Handler = Request -> StormIO Result --State Ptr Result
+
+mkResult :: Int -> String -> ByteString -> Result
+mkResult code mimeType body = Result {
+    rsCode=code, rsFlags=nullRsFlags, rsBody=[body], rsHeaders = Headers $
+        Map.singleton (toUTF "Content-type") (toUTF mimeType) }
 
 instance ToRDF Directory where
     toRDF (Dir node entries) = do
@@ -178,32 +182,31 @@
 updateData :: (FromRDF a, ToRDF a) => EndoM StormIO a -> EndoM StormIO Node
 updateData f node = readData node >>= f >>= writeData (bURI $ bID node)
 
-getURI :: String -> [String] -> Node -> StormIO ByteString
-getURI uri [x] dir = readData dir >>= f . dirEntries where
+getURI :: Request -> [String] -> Node -> StormIO ByteString
+getURI req [x] dir = readData dir >>= f . dirEntries where
     f (FileEntry n r : _ )       | n == x = getBlock (bID r)
-    f (ExecutableEntry n c : _ ) | n == x = execute c (uri, "GET")
+    f (ExecutableEntry n c : _ ) | n == x = execute c req
     f (_                   : es) = f es
     f []                         = return $ toUTF $ "not found: " ++ x
-getURI uri (x:xs) dir = readData dir >>= f . dirEntries where
-    f (DirEntry n sub : _ ) | n == x = getURI uri xs sub
+getURI req (x:xs) dir = readData dir >>= f . dirEntries where
+    f (DirEntry n sub : _ ) | n == x = getURI req xs sub
     f (_              : es) = f es
     f []                    = return $ toUTF $ "dir not found: " ++ x
     
-type Script = (String,String) -> String
-    
-execute :: Node -> (String,String) -> StormIO ByteString
-execute code (uri,_method) = do
+execute :: Node -> Request -> StormIO ByteString
+execute code req = do
     s <- getBlock (bID code)
-    r <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ fromUTF s of
-        ParseFailed (SrcLoc file line col) err -> 
-            return $ "<pre>HSP preprocessing failed at "++
-                     show line++":"++show col++" in "++file++": "++err
+    let errH stage msg = return $ \req -> return $
+            mkResult 500 "text/plain" $ toUTF $ stage ++ " failed:\n" ++ msg
+    h <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ fromUTF s of
+        ParseFailed (SrcLoc file line col) err -> errH "HSP preprocessing" $ 
+            "At"++show line++":"++show col++" in "++file++": "++err
         ParseOk parsed -> return $ unsafePerformIO $ do
            --putStrLn "STARTING"
            let s' = Hsx.prettyPrintWithMode (Hsx.defaultMode 
                        {Hsx.linePragmas=True}) $ Hsx.transform parsed
            --putStrLn "FOO"
-           (fp,hdl) <- openTempFile "/tmp/" "fenserve.page"
+           (fp,hdl) <- openTempFile "/tmp" "fenserve.page"
            --putStrLn $ "BAR"
            hPutStr hdl s'
            --putStrLn "BAZ"
@@ -213,18 +216,20 @@
            homedir <- getEnv "HOME"
            makeResult <- Plugins.makeWith fp "Page.stub" ["-i"++dir, "-fglasgow-exts", "-fallow-overlapping-instances"]
            --putStrLn "MADE"
-           r' <- case makeResult of
-               Plugins.MakeFailure err -> return $
-                   "<pre>Make failed: " ++ concat (List.intersperse "\n" err)
+           h' <- case makeResult of
+               Plugins.MakeFailure err -> 
+                   errH "Make" $ concat (List.intersperse "\n" err)
                Plugins.MakeSuccess _ o -> do
                    --putStrLn "LOADING"
-                   loadResult <- Plugins.load o [dir] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "page"
+                   loadResult <- Plugins.load o [dir] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
                    --putStrLn "LOADED"
                    case loadResult of
                        Plugins.LoadSuccess _ v -> return v
-                       Plugins.LoadFailure err -> return $ "<pre>Load failed: " ++ concat (List.intersperse "\n" err)
-           removeFile fp; return r'
-    return $ toUTF r
+                       Plugins.LoadFailure err ->
+                           errH "Load" $ concat (List.intersperse "\n" err)
+           removeFile fp; return h'
+    response <- h req
+    return $ ByteString.concat $ rsBody response
 
 putURI :: [String] -> ByteString -> Node -> StormIO Node
 putURI path s dir = do rid <- addBlock s; putURI' path (bIRI rid) dir where
diff -rN -u old-fenserve/Main.hs new-fenserve/Main.hs
--- old-fenserve/Main.hs	2007-03-22 19:49:12.000000000 +0200
+++ new-fenserve/Main.hs	2007-03-22 19:49:12.000000000 +0200
@@ -34,8 +34,7 @@
 
 localhostOnlyFilter = Handle $ \req -> do
     if fst (rqPeer req) == "localhost" then request req else respond $ return $
-        Result { rsCode=403, rsHeaders=Headers Map.empty, rsFlags=nullRsFlags,
-                 rsBody=[toUTF "403 Forbidden: Try from localhost."] }
+        mkResult 403 "text/html" $ toUTF "403 Forbidden: Try from localhost"
 
 main :: IO ()
 main = stdHTTP
@@ -43,7 +42,8 @@
   , debugFilter
   , h asURI GET $ ok $ \uri () -> do
       let pa = splitPath (path uri)
-      (b,p) <- get; return $ Right $ fst $ runStormIO (getURI (show uri) pa b) p
+      rq <- getEvent
+      (b,p) <- get; return $ Right $ fst $ runStormIO (getURI rq pa b) p
   , h asURI PUT $ ok $ \uri () -> do 
       let pa = splitPath (path uri)
       Request { rqBody=Body body } <- getEvent
diff -rN -u old-fenserve/Page.stub new-fenserve/Page.stub
--- old-fenserve/Page.stub	2007-03-22 19:49:12.000000000 +0200
+++ new-fenserve/Page.stub	2007-03-22 19:49:12.000000000 +0200
@@ -16,9 +16,7 @@
 handler = pageHandler page
 
 pageHandler :: HTML -> Handler
-pageHandler html _request = return $ Result {
-    rsCode=200, rsFlags=nullRsFlags, rsBody=[toUTF html], rsHeaders = Headers $
-        Data.Map.singleton (toUTF "Content-type") (toUTF "text/html") }
+pageHandler html _request = return $ mkResult 200 "text/html" (toUTF html)
 
 type HTML = String
 




More information about the Fencommits mailing list