[Fencommits] fenserve: crude code to allow executable resources to import other resources
Benja Fallenstein
benja.fallenstein at gmail.com
Sun Apr 1 15:01:10 EEST 2007
Sun Apr 1 15:00:35 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* crude code to allow executable resources to import other resources
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-04-01 15:01:08.000000000 +0300
+++ new-fenserve/FenServe.hs 2007-04-01 15:01:08.000000000 +0300
@@ -26,8 +26,8 @@
import HAppS hiding (query, Handler)
-import Control.Monad (liftM)
-import Control.Monad.Error (throwError, runErrorT)
+import Control.Monad (liftM, when, forM)
+import Control.Monad.Error (ErrorT, throwError, runErrorT)
import Control.Monad.State (State, StateT, runStateT,
get, gets, put, modify, execState)
import Control.Monad.Trans (lift, liftIO)
@@ -48,8 +48,8 @@
import Network.URI (uriToString, parseURIReference)
-import System.Directory (removeFile)
-import System.Environment (getEnv)
+import System.Directory (doesFileExist, createDirectoryIfMissing)
+import System.Environment (getEnv, getProgName)
import System.Eval.Haskell (eval)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
@@ -313,46 +313,74 @@
codeCache :: IORef (Map BlockId Handler)
codeCache = unsafePerformIO $ newIORef Map.empty
+getCodeDir :: IO FilePath
+getCodeDir = fmap (++"_code/") getProgName
+
+realize :: Node -> FilePath -> ErrorT String FenServe FilePath
+realize code codeDir = do
+ let err stage msg = throwError (stage ++ " failed:\n" ++ msg)
+ mname = "Block_"++(blockId $ bID code); fp = codeDir++mname++".hs"
+
+ liftIO $ createDirectoryIfMissing True codeDir
+ dfe <- liftIO $ doesFileExist fp
+ when (not dfe) $ do
+ code2 <- lift $ getBlock (bID code)
+
+ let (imps, body) = span (List.isPrefixOf "import ") $ lines $fromUTF code2
+
+ imps' <- forM imps $ \uri -> do
+ icode <- lift $ wget (drop (length "import ") uri)
+ bid <- lift $ addBlock icode
+ realize (bIRI bid) codeDir
+ return ("Block_" ++ blockId bid)
+
+ let code3 = "module " ++ mname ++ " where\n" ++
+ concatMap (\i -> "import "++i++"\n") (imps'++imports) ++
+ "dummyAssignment = 0\n" ++ unlines body
+ -- the 'dummyAssignment' is to make sure that
+ -- pages can't import anything -- imports are
+ -- syntactically disallowed except at the beginning
+
+ parsed <- case Hsx.parseModuleWithMode (Hsx.ParseMode fp) $ code3 of
+ ParseFailed (SrcLoc file line col) e ->
+ err "HSP preprocessing" $
+ "At "++show line++":"++show col++" in "++file++": "++e
+ ParseOk parsed -> return parsed
+
+ let code4 = Hsx.prettyPrintWithMode
+ (Hsx.defaultMode {Hsx.linePragmas=True}) $
+ Hsx.transform parsed
+
+ hdl <- liftIO $ openFile fp WriteMode
+ liftIO $ hPutStr hdl code4
+ liftIO $ hClose hdl
+
+ return fp
+
execute :: Node -> Request -> FenServe Result
-execute code req = getBlock (bID code) >>= \s ->
- let f (Left msg) = return $ mkResult 500 "text/plain" $ toUTF $ msg
+execute code req = let f (Left msg) = return $ mkResult 500 "text/plain" $ toUTF $ msg
f (Right h) = h req
- in f $ unsafePerformIO $ runErrorT $ do
+ f' m = m >>= f
+ in f' $ runErrorT $ do
+
+ let err stage msg = throwError (stage ++ " failed:\n" ++ msg)
cached <- liftM (Map.lookup $ bID code) $ liftIO $ readIORef codeCache
if isJust cached then return (fromJust cached) else do
+
+ codeDir <- liftIO getCodeDir
+ fp <- realize code codeDir
- let err stage msg = throwError (stage ++ " failed:\n" ++ msg)
- mname = "Page_" ++ (blockId $ bID code)
- s2 = "module " ++ mname ++ " where\n" ++
- concatMap (\i -> "import "++i++"\n") imports ++
- "dummyAssignment = 0\n" ++ fromUTF s
- -- the 'dummyAssignment' is to make sure that
- -- pages can't import anything -- imports are
- -- syntactically disallowed except at the beginning
-
- parsed <- case Hsx.parseModuleWithMode (Hsx.ParseMode "Page.hs") $ s2 of
- ParseFailed (SrcLoc file line col) e -> err "HSP preprocessing" $
- "At "++show line++":"++show col++" in "++file++": "++e
- ParseOk parsed -> return parsed
-
- let s' = Hsx.prettyPrintWithMode (Hsx.defaultMode {Hsx.linePragmas=True}) $
- Hsx.transform parsed
- fp = "/tmp/"++mname++".hs"
-
- hdl <- liftIO $ openFile fp WriteMode
- liftIO $ hPutStr hdl s'
- liftIO $ hClose hdl
homedir <- liftIO $ getEnv "HOME"
- makeResult <- liftIO $ Plugins.make fp ["-fglasgow-exts", "-fallow-overlapping-instances"]
+ makeResult <- liftIO $ Plugins.makeAll fp ["-fglasgow-exts", "-fallow-overlapping-instances","-i","-i"++codeDir]
o <- case makeResult of
Plugins.MakeFailure e -> err "Make" $ concat (List.intersperse "\n" e)
Plugins.MakeSuccess _ o -> return o
- loadStatus <- liftIO $ Plugins.load o [] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
+ loadStatus <- liftIO $ Plugins.load o [codeDir] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
h <- case loadStatus of
Plugins.LoadFailure e -> err "Load" $ concat (List.intersperse "\n" e)
Plugins.LoadSuccess _ h -> return h
- liftIO $ Plugins.makeCleaner fp
+ --liftIO $ Plugins.makeCleaner fp
liftIO $ modifyIORef codeCache (Map.insert (bID code) h)
return h
diff -rN -u old-fenserve/Makefile new-fenserve/Makefile
--- old-fenserve/Makefile 2007-04-01 15:01:08.000000000 +0300
+++ new-fenserve/Makefile 2007-04-01 15:01:08.000000000 +0300
@@ -20,7 +20,7 @@
./dist/build/fenserve/fenserve $(ARGS)
reset:
- rm -rf fenserve_state fenserve_storm fenserve_error.log
+ rm -rf fenserve_state fenserve_storm fenserve_error.log fenserve_code
clean:
runhaskell Setup.hs clean
diff -rN -u old-fenserve/board-demo.page new-fenserve/board-demo.page
--- old-fenserve/board-demo.page 2007-04-01 15:01:08.000000000 +0300
+++ new-fenserve/board-demo.page 2007-04-01 15:01:08.000000000 +0300
@@ -1,45 +1,4 @@
-dc = "http://purl.org/dc/elements/1.1/"
-dcterms = "http://purl.org/dc/terms/"
-sioc = "http://rdfs.org/sioc/ns#"
-content = "http://purl.org/rss/1.0/modules/content/"
-
-dc_title = IRI $ dc ++ "title"
-dc_description = IRI $ dc ++ "description"
-dc_creator = IRI $ dc ++ "creator"
-dcterms_created = IRI $ dcterms ++ "created"
-dcterms_modified = IRI $ dcterms ++ "modified"
-content_encoded = IRI $ content ++ "encoded"
-sioc_reply_of = IRI $ sioc ++ "reply_of"
-sioc_has_container = IRI $ sioc ++ "has_container"
-
-mlit x = maybe x literalStr
-postTitle p = mlit "(No title)" $ query (p, dc_title, X) ?graph
-postAuthor p = mlit "(unknown author)" $ query (p, dc_creator, X) ?graph
-postDate p = mlit "(unknown date)" $ query (p, dcterms_modified, X) ?graph
-postContent p = mlit "" $ query (p, content_encoded, X) ?graph
-boardTitle b = mlit "(No title)" $ query (b, dc_title, X) ?graph
-boardDesc b = mlit "" $ query (b, dc_description, X) ?graph
-
-boardPosts :: (?graph :: Graph) => Node -> [Node]
-boardPosts board = [post | post <- query (X, sioc_has_container, board) ?graph,
- not $ query (post, sioc_reply_of, Any) ?graph]
-
-postReplies post = query (X, sioc_reply_of, post) ?graph :: [Node]
-
-lit s = Literal s Plain
-blog = IRI "ex:blog"; post = IRI "ex:post"
-
-example = toGraph (IRI "bah:graph") [
- (blog, dc_title, lit "Benja's Blog"),
- (blog, dc_description, lit "Benja Fallenstein"),
- (post, dc_title, lit "Hi there!"),
- (post, content_encoded, lit $ unHTML $ <p>Test post. <i>All cool.</i></p>),
- (post, dcterms_created, lit "someday"),
- (post, dcterms_modified, lit "someday"),
- (post, dc_creator, lit "Benja"),
- (post, sioc_has_container, blog) ]
-
-blockquote html = <blockquote><% html %></blockquote>
+import /board-lib
repl :: Eq a => [a] -> [a] -> [a] -> [a]
repl pat r l | pat `List.isPrefixOf` l = r ++ repl pat r (drop (length pat) l)
diff -rN -u old-fenserve/board-lib.code new-fenserve/board-lib.code
--- old-fenserve/board-lib.code 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/board-lib.code 2007-04-01 15:01:08.000000000 +0300
@@ -0,0 +1,42 @@
+dc = "http://purl.org/dc/elements/1.1/"
+dcterms = "http://purl.org/dc/terms/"
+sioc = "http://rdfs.org/sioc/ns#"
+content = "http://purl.org/rss/1.0/modules/content/"
+
+dc_title = IRI $ dc ++ "title"
+dc_description = IRI $ dc ++ "description"
+dc_creator = IRI $ dc ++ "creator"
+dcterms_created = IRI $ dcterms ++ "created"
+dcterms_modified = IRI $ dcterms ++ "modified"
+content_encoded = IRI $ content ++ "encoded"
+sioc_reply_of = IRI $ sioc ++ "reply_of"
+sioc_has_container = IRI $ sioc ++ "has_container"
+
+mlit x = maybe x literalStr
+postTitle p = mlit "(No title)" $ query (p, dc_title, X) ?graph
+postAuthor p = mlit "(unknown author)" $ query (p, dc_creator, X) ?graph
+postDate p = mlit "(unknown date)" $ query (p, dcterms_modified, X) ?graph
+postContent p = mlit "" $ query (p, content_encoded, X) ?graph
+boardTitle b = mlit "(No title)" $ query (b, dc_title, X) ?graph
+boardDesc b = mlit "" $ query (b, dc_description, X) ?graph
+
+boardPosts :: (?graph :: Graph) => Node -> [Node]
+boardPosts board = [post | post <- query (X, sioc_has_container, board) ?graph,
+ not $ query (post, sioc_reply_of, Any) ?graph]
+
+postReplies post = query (X, sioc_reply_of, post) ?graph :: [Node]
+
+lit s = Literal s Plain
+blog = IRI "ex:blog"; post = IRI "ex:post"
+
+example = toGraph (IRI "bah:graph") [
+ (blog, dc_title, lit "Benja's Blog"),
+ (blog, dc_description, lit "Benja Fallenstein"),
+ (post, dc_title, lit "Hi there!"),
+ (post, content_encoded, lit $ unHTML $ <p>Test post. <i>All cool.</i></p>),
+ (post, dcterms_created, lit "someday"),
+ (post, dcterms_modified, lit "someday"),
+ (post, dc_creator, lit "Benja"),
+ (post, sioc_has_container, blog) ]
+
+blockquote html = <blockquote><% html %></blockquote>
More information about the Fencommits
mailing list