[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