[Fencommits] fenserve: refactor, creating a new Main module so that Page.stub can import FenServe
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:13 EET 2007
Wed Mar 21 20:47:46 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor, creating a new Main module so that Page.stub can import FenServe
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:13.000000000 +0200
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
-module Main where
+module FenServe where
-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
@@ -24,7 +24,7 @@
import Fenfire.Utils
import qualified Fenfire.Raptor as Raptor
-import HAppS hiding (query)
+import HAppS hiding (query, Handler)
import Control.Monad (liftM)
import Control.Monad.State (State, get, gets, put, modify, execState)
@@ -45,6 +45,7 @@
import Network.URI (uriToString)
import System.Directory (removeFile)
+import System.Environment (getEnv)
import System.Eval.Haskell (eval)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
@@ -77,6 +78,9 @@
type Ptr = (Node, Pool)
+type Response = Result
+type Handler = Request -> State Ptr Response
+
instance ToRDF Directory where
toRDF (Dir node entries) = do
l <- toRDF entries
@@ -140,27 +144,6 @@
instance ToMessage ByteString where
toMessageBodyM = return
-
-asURI :: SURI -> Maybe SURI
-asURI = Just
-
-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."] }
-
-main :: IO ()
-main = stdHTTP
- [ localhostOnlyFilter
- , 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
- , h asURI PUT $ ok $ \uri () -> do
- let pa = splitPath (path uri)
- Request { rqBody=Body body } <- getEvent
- modify (\(b,p) -> runStormIO (putURI pa body b) p); return $ Right "Ok."
- ]
bURI :: BlockId -> String
bURI (BlockId bid) = "blk:" ++ bid
@@ -213,31 +196,33 @@
s <- getBlock (bID code)
r <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ fromUTF s of
ParseFailed (SrcLoc file line col) err ->
- return $ "HSP preprocessing failed at "++
+ return $ "<pre>HSP preprocessing failed at "++
show line++":"++show col++" in "++file++": "++err
ParseOk parsed -> return $ unsafePerformIO $ do
- putStrLn "STARTING"
+ --putStrLn "STARTING"
let s' = Hsx.prettyPrintWithMode (Hsx.defaultMode
{Hsx.linePragmas=True}) $ Hsx.transform parsed
- putStrLn "FOO"
+ --putStrLn "FOO"
(fp,hdl) <- openTempFile "/tmp/" "fenserve.page"
- putStrLn $ "BAR"
+ --putStrLn $ "BAR"
hPutStr hdl s'
- putStrLn "BAZ"
+ --putStrLn "BAZ"
hClose hdl
- putStrLn "MAKING"
- makeResult <- Plugins.makeWith fp "Page.stub" ["-fglasgow-exts", "-fallow-overlapping-instances"]
- putStrLn "MADE"
+ --putStrLn "MAKING"
+ let dir = "dist/build/fenserve/fenserve-tmp"
+ 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 $
- "Make failed: " ++ concat (List.intersperse "\n" err)
+ "<pre>Make failed: " ++ concat (List.intersperse "\n" err)
Plugins.MakeSuccess _ o -> do
- putStrLn "LOADING"
- loadResult <- Plugins.load o [] [] "page"
- putStrLn "LOADED"
+ --putStrLn "LOADING"
+ loadResult <- Plugins.load o [dir] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "page"
+ --putStrLn "LOADED"
case loadResult of
Plugins.LoadSuccess _ v -> return v
- Plugins.LoadFailure err -> return $ "Load failed: " ++ concat (List.intersperse "\n" err)
+ Plugins.LoadFailure err -> return $ "<pre>Load failed: " ++ concat (List.intersperse "\n" err)
removeFile fp; return r'
return $ toUTF r
diff -rN -u old-fenserve/Main.hs new-fenserve/Main.hs
--- old-fenserve/Main.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/Main.hs 2007-03-22 19:49:13.000000000 +0200
@@ -0,0 +1,51 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Main where
+
+-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
+-- This file is part of Fenfire.
+--
+-- Fenfire is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by
+-- the Free Software Foundation; either version 2 of the License, or
+-- (at your option) any later version.
+--
+-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+-- Public License for more details.
+--
+-- You should have received a copy of the GNU General
+-- Public License along with Fenfire; if not, write to the Free
+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+-- MA 02111-1307 USA
+
+import FenServe
+import Storm
+
+import HAppS hiding (query, Handler)
+
+import Control.Monad.State (State, get, gets, put, modify, execState)
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+asURI :: SURI -> Maybe SURI
+asURI = Just
+
+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."] }
+
+main :: IO ()
+main = stdHTTP
+ [ localhostOnlyFilter
+ , 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
+ , h asURI PUT $ ok $ \uri () -> do
+ let pa = splitPath (path uri)
+ Request { rqBody=Body body } <- getEvent
+ modify (\(b,p) -> runStormIO (putURI pa body b) p); return $ Right "Ok."
+ ]
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:13.000000000 +0200
@@ -3,8 +3,23 @@
-}
module PageStub where
+import HAppS hiding (Handler)
+
+import Storm (toUTF)
+import FenServe
+
+import qualified Data.Map
+
page :: HTML
+handler :: Handler
+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") }
+
type HTML = String
genAttr :: (String, String) -> HTML
diff -rN -u old-fenserve/demo.hs new-fenserve/demo.hs
--- old-fenserve/demo.hs 2007-03-22 19:49:12.000000000 +0200
+++ new-fenserve/demo.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,7 +0,0 @@
-
-<body>
-<h1>Hello, world!</h1>
-<p>I can generate & send HTML, how cool is that?</p>
-<p>Cooler to me than to others, I expect. :-)</p>
-<p>Look, numbers: <% show [1..10] %>!</p>
-</body>
diff -rN -u old-fenserve/demo.page new-fenserve/demo.page
--- old-fenserve/demo.page 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/demo.page 2007-03-22 19:49:13.000000000 +0200
@@ -0,0 +1,7 @@
+
+<body>
+<h1>Hello, world!</h1>
+<p>I can generate & send HTML, how cool is that?</p>
+<p>Cooler to me than to others, I expect. :-)</p>
+<p>Look, numbers: <% show [1..10] %>!</p>
+</body>
diff -rN -u old-fenserve/fenserve.cabal new-fenserve/fenserve.cabal
--- old-fenserve/fenserve.cabal 2007-03-22 19:49:12.000000000 +0200
+++ new-fenserve/fenserve.cabal 2007-03-22 19:49:12.000000000 +0200
@@ -8,5 +8,5 @@
haskell-src-exts
Executable: fenserve
-Main-Is: FenServe.hs
+Main-Is: Main.hs
Extra-Libraries: raptor
More information about the Fencommits
mailing list