[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