[Fencommits] fenserve: scruffy version that can run and show HSP-processed pages
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Mar 22 19:49:14 EET 2007
Wed Mar 21 17:55:59 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* scruffy version that can run and show HSP-processed pages
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-22 19:49:14.000000000 +0200
+++ new-fenserve/FenServe.hs 2007-03-22 19:49:14.000000000 +0200
@@ -40,10 +40,15 @@
import Data.Maybe (fromMaybe, fromJust)
import Data.Typeable
+import Language.Haskell.Hsx as Hsx
+
import Network.URI (uriToString)
+import System.Directory (removeFile)
import System.Eval.Haskell (eval)
+import System.IO
import System.IO.Unsafe (unsafePerformIO)
+import qualified System.Plugins as Plugins
fs = "http://fenfire.org/2007/fenserve#"
fs_Directory = IRI "http://fenfire.org/2007/fenserve#Directory"
@@ -136,17 +141,19 @@
instance ToMessage ByteString where
toMessageBodyM = return
-asPath :: SURI -> Maybe [String]
-asPath = Just . splitPath . path
+asURI :: SURI -> Maybe SURI
+asURI = Just
main :: IO ()
main = stdHTTP
[ debugFilter
- , h asPath GET $ ok $ \uri () -> do
- (b,p) <- get; return $ Right $ fst $ runStormIO (getURI uri b) p
- , h asPath PUT $ ok $ \uri () -> do
+ , 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 uri body b) p); return $ Right "Ok."
+ modify (\(b,p) -> runStormIO (putURI pa body b) p); return $ Right "Ok."
]
bURI :: BlockId -> String
@@ -182,21 +189,51 @@
updateData :: (FromRDF a, ToRDF a) => EndoM StormIO a -> EndoM StormIO Node
updateData f node = readData node >>= f >>= writeData (bURI $ bID node)
-getURI :: [String] -> Node -> StormIO ByteString
-getURI [x] dir = readData dir >>= f . dirEntries where
+getURI :: String -> [String] -> Node -> StormIO ByteString
+getURI uri [x] dir = readData dir >>= f . dirEntries where
f (FileEntry n r : _ ) | n == x = getBlock (bID r)
- f (ExecutableEntry n c : _ ) | n == x = execute c
+ f (ExecutableEntry n c : _ ) | n == x = execute c (uri, "GET")
f (_ : es) = f es
f [] = return $ toUTF $ "not found: " ++ x
-getURI (x:xs) dir = readData dir >>= f . dirEntries where
- f (DirEntry n sub : _ ) | n == x = getURI xs sub
+getURI uri (x:xs) dir = readData dir >>= f . dirEntries where
+ f (DirEntry n sub : _ ) | n == x = getURI uri xs sub
f (_ : es) = f es
f [] = return $ toUTF $ "dir not found: " ++ x
-execute :: Node -> StormIO ByteString
-execute code = do s <- getBlock (bID code)
- let x = eval (fromUTF s) [] :: IO (Maybe String)
- return $ toUTF $ fromMaybe "error" $ unsafePerformIO x
+type Script = (String,String) -> String
+
+execute :: Node -> (String,String) -> StormIO ByteString
+execute code (uri,_method) = do
+ 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 "++
+ 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"
+ putStrLn $ "BAR"
+ hPutStr hdl s'
+ putStrLn "BAZ"
+ hClose hdl
+ putStrLn "MAKING"
+ makeResult <- Plugins.makeWith fp "Page.stub" ["-fglasgow-exts", "-fallow-overlapping-instances"]
+ putStrLn "MADE"
+ r' <- case makeResult of
+ Plugins.MakeFailure err -> return $
+ "Make failed: " ++ concat (List.intersperse "\n" err)
+ Plugins.MakeSuccess _ o -> do
+ putStrLn "LOADING"
+ loadResult <- Plugins.load o [] [] "page"
+ putStrLn "LOADED"
+ case loadResult of
+ Plugins.LoadSuccess _ v -> return v
+ Plugins.LoadFailure err -> return $ "Load failed: " ++ concat (List.intersperse "\n" err)
+ removeFile fp; return r'
+ return $ toUTF r
putURI :: [String] -> ByteString -> Node -> StormIO Node
putURI path s dir = do rid <- addBlock s; putURI' path (bIRI rid) dir where
@@ -207,7 +244,8 @@
f (ExecutableEntry n _ : es) | n == x = FileEntry n r : es
| n ++ ".code" == x = ExecutableEntry n r : es
f (e : es) = e : f es
- f [] | ".code" `List.isSuffixOf` x = [ExecutableEntry (take (length x - 5) x) r]
+ f [] | ".code" `List.isSuffixOf` x
+ = [ExecutableEntry (take (length x - 5) x) r]
| otherwise = [FileEntry x r]
putURI' (x:xs) r dir = updateData f' dir where
recurse sub = do sub' <- putURI' xs r sub; return [DirEntry x sub']
diff -rN -u old-fenserve/Page.stub new-fenserve/Page.stub
--- old-fenserve/Page.stub 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/Page.stub 2007-03-22 19:49:14.000000000 +0200
@@ -0,0 +1,38 @@
+{-
+Needs options: -fglasgow-exts -fallow-overlapping-instances
+-}
+module PageStub where
+
+page :: HTML
+
+type HTML = String
+
+genAttr :: (String, String) -> HTML
+genAttr (n,v) = " " ++ n ++ "=\"" ++ v ++ "\""
+
+genTag :: (Maybe a, String) -> [(String, String)] -> [HTML] -> HTML
+genTag (Nothing, s) attrs children =
+ "<"++s++concatMap genAttr attrs++">" ++ concat children ++ "</"++s++">"
+
+genETag :: (Maybe a, String) -> [(String, String)] -> HTML
+genETag (Nothing, s) attrs = "<"++s++concatMap genAttr attrs++" />"
+
+pcdata :: String -> HTML
+pcdata s = s
+
+data Attr = String := String
+
+toAttribute (n := v) = (n,v)
+
+class ToXML a where
+ toXMLs :: a -> HTML
+
+instance ToXML HTML where
+ toXMLs = id
+
+instance ToXML Integer where
+ toXMLs = show
+
+instance ToXML a => ToXML [a] where
+ toXMLs = concatMap toXMLs
+
diff -rN -u old-fenserve/Storm.hs new-fenserve/Storm.hs
--- old-fenserve/Storm.hs 2007-03-22 19:49:14.000000000 +0200
+++ new-fenserve/Storm.hs 2007-03-22 19:49:14.000000000 +0200
@@ -26,11 +26,12 @@
import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import qualified Data.Char as Char
+import Data.Dynamic (Typeable)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
-newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read)
+newtype BlockId = BlockId { blockId :: String } deriving (Eq,Ord,Show,Read,Typeable)
type Pool = Map BlockId ByteString
type StormIO = State Pool -- might be good to have StormI = Reader Pool?
diff -rN -u old-fenserve/demo.hs new-fenserve/demo.hs
--- old-fenserve/demo.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/demo.hs 2007-03-22 19:49:14.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:14.000000000 +0200
+++ new-fenserve/fenserve.cabal 2007-03-22 19:49:14.000000000 +0200
@@ -4,7 +4,8 @@
License-file: LICENSE
Author: Benja Fallenstein
Maintainer: fenfire-dev at nongnu.org
-Build-Depends: base, mtl, network, HAppS, fenfire, glib, plugins
+Build-Depends: base, mtl, network, HAppS, fenfire, glib, plugins,
+ haskell-src-exts
Executable: fenserve
Main-Is: FenServe.hs
diff -rN -u old-fenserve/get new-fenserve/get
--- old-fenserve/get 2007-03-22 19:49:14.000000000 +0200
+++ new-fenserve/get 2007-03-22 19:49:14.000000000 +0200
@@ -1,3 +1,3 @@
#!/bin/sh
-curl $1
+curl http://localhost:8000/$1
echo
diff -rN -u old-fenserve/put new-fenserve/put
--- old-fenserve/put 2007-03-22 19:49:14.000000000 +0200
+++ new-fenserve/put 2007-03-22 19:49:14.000000000 +0200
@@ -1,2 +1,2 @@
#!/bin/sh
-curl -X PUT -d "$2" $1
+curl -X PUT -d "$2" http://localhost:8000/$1
More information about the Fencommits
mailing list