[Fencommits] fenserve: start reimplementation of fenserve, currently broken
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Apr 5 03:26:45 EEST 2007
Thu Apr 5 03:26:30 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* start reimplementation of fenserve, currently broken
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-04-05 03:26:45.000000000 +0300
+++ new-fenserve/FenServe.hs 2007-04-05 03:26:45.000000000 +0300
@@ -20,11 +20,12 @@
-- MA 02111-1307 USA
import Storm
+import StormData
import Fenfire.RDF
import Fenfire.Utils
import qualified Fenfire.Raptor as Raptor
-import HAppS hiding (query, Handler)
+import HAppS hiding (query, Handler, getPath)
import Control.Monad (liftM, when, forM)
import Control.Monad.Error (ErrorT, throwError, runErrorT)
@@ -70,19 +71,11 @@
fs_mimeType = IRI "http://fenfire.org/2007/fenserve#mimeType"
fs_language = IRI "http://fenfire.org/2007/fenserve#language"
+fs_type = IRI "http://fenfire.org/2007/fenserve#type"
+
storm = "http://fenfire.org/2007/storm"
storm_depends = IRI "http://fenfire.org/2007/storm#depends"
-data Entry = DirEntry { entrySubdir :: Node }
- | FileEntry { entryRepr :: Node }
- | ExecutableEntry { entryCode :: Node }
- deriving (Show, Read)
-
-entryNode (DirEntry n) = n; entryNode (FileEntry n) = n; entryNode (ExecutableEntry n) = n
-
-data Directory = Dir { dirNode :: Node, dirEntries :: [(String,Entry)] }
- deriving (Show, Read)
-
type FenServe = StateT Node StormIO
runFenServe :: FenServe a -> Node -> Maybe FilePath -> IO (a, Node, Pool)
@@ -93,69 +86,29 @@
getBlock = lift . getBlock
addBlock = lift . addBlock
-writeEmptyState :: FenServe Node
-writeEmptyState = postData "blk:/" $ Dir (IRI "new:block") []
-
-type Handler = Request -> FenServe 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
- l <- toRDFList toRDFEntry entries
- tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
- tellTs [ (node, storm_depends, entryNode $ snd e) | e <- entries ]
- return node
- where toRDFEntry (name, entry) = do e <- toRDF entry; n <- toRDF name
- tellTs [(e,fs_filename,n)]; return e
-
-instance FromRDF Directory where
- readRDF g node = do
- let l = query' (node, fs_entries, X) g
- tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
- entries <- readRDFList readRDFEntry g l
- return $ Dir node entries
- where readRDFEntry g n = do
- let nameR = query' (n, fs_filename, X) g
- name <- readRDF g nameR; entry <- readRDF g n
- tellTs [ (n, fs_filename, nameR) ]; return (name, entry)
-
-instance ToRDF Entry where
- toRDF (FileEntry repr) = do
- e <- newBNode
- tellTs [ (e, rdf_type, fs_FileEntry), (e, fs_representation, repr) ]
- return e
- toRDF (DirEntry subdir) = do
- e <- newBNode
- tellTs [ (e, rdf_type, fs_DirEntry), (e, fs_subdir, subdir) ]
- return e
- toRDF (ExecutableEntry code) = do
- e <- newBNode
- tellTs [ (e, rdf_type, fs_ExecutableEntry), (e, fs_code, code) ]
- return e
-
-instance FromRDF Entry where
- readRDF g node = case query' (node, rdf_type, X) g of
- x | x == fs_FileEntry -> do
- let repr = query' (node, fs_representation, X) g
- tellTs [ (node, fs_representation, repr) ]
- return $ FileEntry repr
- x | x == fs_DirEntry -> do
- let subdir = query' (node, fs_subdir, X) g
- tellTs [ (node, fs_subdir, subdir) ]
- return $ DirEntry subdir
- x | x == fs_ExecutableEntry -> do
- let code = query' (node, fs_code, X) g
- tellTs [ (node, fs_subdir, code) ]
- return $ ExecutableEntry code
+type Handler = Request -> FenServe Result
+
+data Resource = Resource {
+ readResource :: FromRDF a => FenServe a,
+ modifyResource :: (FromRDF a, ToRDF a) => (a -> FenServe a) -> FenServe (),
+ handleResource :: Handler }
+data Resolver = forall a. (FromRDF a, ToRDF a) =>
+ Resolver (Resolvers -> [String] -> a -> [String] -> FenServe Resource)
+
+type Resolvers = Map Node Resolver
+
+{-
instance StartState Node where
startStateM =
runFenServe writeEmptyState e Nothing >>= \(r,_,_) -> return r where
e = error "FenServe.(StartState Node): this shouldn't be evaluated"
+-}
instance Serialize Node where
typeString _ = "FenServe.State"
@@ -164,86 +117,32 @@
instance ToMessage ByteString where
toMessageBodyM = return
-
-bURI :: BlockId -> String
-bURI (BlockId bid) = "blk:/" ++ bid
-
-bIRI :: BlockId -> Node
-bIRI bid = IRI $ bURI bid
-
-bID :: Node -> BlockId
-bID (IRI ('b':'l':'k':':':'/':s)) = BlockId $ takeWhile (/= '#') s
-bID node = error $ "Not a block IRI: " ++ show node
-
-getGraph :: String -> FenServe Graph
-getGraph uri = do bytes <- wget uri
- let (ts, nss) = unsafePerformIO $
- Raptor.bytesToTriples "turtle" bytes uri
- return $ raptorToGraph ts nss uri
-
-showGraph :: Graph -> ByteString
-showGraph g = let (ts,nss) = graphToRaptor g; uri = iriStr $ defaultGraph g
- in unsafePerformIO $ Raptor.triplesToBytes ts nss uri
-
-putGraph :: Graph -> FenServe ()
-putGraph g = wput (iriStr $ defaultGraph g) (showGraph g)
-postGraph :: String -> Graph -> FenServe String
-postGraph uri g = wpost uri (showGraph g)
-
-getData :: FromRDF a => Node -> FenServe a
-getData node = do graph <- getGraph (takeWhile (/= '#') $ iriStr node)
- return $ fromRDF graph node
-
-putData :: ToRDF a => String -> a -> FenServe Node
-putData uri value = do let (node, ts) = runToRDF uri $ toRDF value
- putGraph $ toGraph (IRI uri) ts
- return node
-
-postData :: ToRDF a => String -> a -> FenServe Node
-postData uri value = do let (node, ts) = runToRDF "new:block" $ toRDF value
- uri' <- postGraph uri $ toGraph (IRI "new:block") ts
- return $ changeBaseURI "new:block" uri' node
+resolve :: Resolvers -> [String] -> FenServe Resource
+resolve rs p = do root <- get; resolve' rs [] root p
-updateStormData :: (FromRDF a, ToRDF a) => EndoM FenServe a -> EndoM FenServe Node
-updateStormData f node = getData node >>= f >>= postData "blk:/"
+resolve' :: Resolvers -> [String] -> Node -> [String] -> FenServe Resource
+resolve' rs p0 n p1 = do g <- getGraph n; ty <- mquery (n, fs_type, X) g
+ Resolver r <- Map.lookup ty rs
+ r rs p0 (fromRDF g n) p1
+
+
+defaultResolvers = Map.fromList [(fs_Directory, Resolver resolveDir)]
handleRequest :: Request -> FenServe Result
-handleRequest req = case scheme $ rqURI req of
- "blk:" -> case rqMethod req of
- GET -> do bytes <- getBlock (bID $ IRI $ render $ rqURI req)
- return $ mkResult 200 "application/octet-stream" bytes
- POST -> do bid <- addBlock (unBody $ rqBody req)
- return $ setHeader "Location" (bURI bid) $
- mkResult 201 "text/html" (toUTF "Created.\n")
- s | s `elem` ["local:",""] -> let p = splitPath $ path $ rqURI req in do
- e <- getEntry p
- case e of Right (ExecutableEntry code) -> execute code req
- _ -> case rqMethod req of GET -> getURI p req
- PUT -> putURI p req
- m -> error ("FenServe.handleRequest: unhandled method: " ++ show m)
- s -> error ("FenServe.handleRequest: cannot handle scheme: " ++ s)
-
-wget :: String -> FenServe ByteString
-wget uri = do r <- handleRequest $ wrequest uri GET
- return $ ByteString.concat $ rsBody r
-
-wput :: String -> ByteString -> FenServe ()
-wput uri body = do handleRequest $ (wrequest uri PUT) { rqBody=Body body }
- return ()
-
-wpost :: String -> ByteString -> FenServe String
-wpost uri body = do r <- handleRequest $ (wrequest uri POST) {rqBody=Body body}
- return $ fromMaybe (error "FenServe.wpost: no Location")
- (getHeader "Location" r)
-
-wrequest :: String -> Method -> Request
-wrequest uri method = case parseURIReference uri of
- Nothing -> error $ "FenServe.wrequest: not a legal URI: " ++ uri
- Just u -> Request { rqURI=SURI u, rqVersion=Version 1 0,
- rqHeaders=Headers Map.empty, rqBody=NoBody,
- rqMethod=method, rqPeer=("localhost",-1234) }
+handleRequest req = do let p = splitPath $ path $ rqURI req
+ r <- resolve defaultResolvers p
+ handleResource r req
+
+data Directory = Dir (Map String Node)
+
+instance FromRDF Directory where fromRDF = error "FenServe: XXX"
+instance ToRDF Directory where toRDF = error "FenServe: XXX"
+
+resolveDir rs p0 (Dir m) (p:p1) = resolve' rs (p0++[p]) (m Map.! p) p1
+
+{-
getURI :: [String] -> Request -> FenServe Result
getURI path req = getEntry path >>= \entry -> case entry of
Left err -> return $ mkResult 404 "text/html" (toUTF err)
@@ -293,6 +192,7 @@
f ((n, e) : es) | n == x = error ("FIXME: not a dir: " ++ n)
f (e : es) = do es' <- f es; return (e:es')
f [] = writeEmptyState >>= recurse
+-}
--------------------------------------------------------------------------
-- Running executable resources
@@ -316,6 +216,7 @@
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)
@@ -383,6 +284,7 @@
--liftIO $ Plugins.makeCleaner fp
liftIO $ modifyIORef codeCache (Map.insert (bID code) h)
return h
+-}
--------------------------------------------------------------------------
diff -rN -u old-fenserve/FenServe.hs.3 new-fenserve/FenServe.hs.3
--- old-fenserve/FenServe.hs.3 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/FenServe.hs.3 2007-04-05 03:26:45.000000000 +0300
@@ -0,0 +1,397 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module FenServe 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 Storm
+import Fenfire.RDF
+import Fenfire.Utils
+import qualified Fenfire.Raptor as Raptor
+
+import HAppS hiding (query, Handler)
+
+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)
+
+import qualified Data.ByteString as ByteString
+import Data.ByteString (ByteString)
+import Data.Generics
+import Data.IORef
+import qualified Data.List as List
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Maybe (fromMaybe, fromJust, isJust)
+import Data.Typeable
+
+import Language.Haskell.Hsx as Hsx
+
+import Network.URI (uriToString, parseURIReference)
+
+import System.Directory (doesFileExist, createDirectoryIfMissing)
+import System.Environment (getEnv, getProgName)
+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"
+fs_DirEntry = IRI "http://fenfire.org/2007/fenserve#DirEntry"
+fs_FileEntry = IRI "http://fenfire.org/2007/fenserve#FileEntry"
+fs_ExecutableEntry = IRI "http://fenfire.org/2007/fenserve#ExecutableEntry"
+fs_FirstVersion = IRI "http://fenfire.org/2007/fenserve#FirstVersion"
+fs_previousVersion = IRI "http://fenfire.org/2007/fenserve#previousVersion"
+fs_entries = IRI "http://fenfire.org/2007/fenserve#entries"
+fs_filename = IRI "http://fenfire.org/2007/fenserve#filename"
+fs_subdir = IRI "http://fenfire.org/2007/fenserve#subdir"
+fs_representation = IRI "http://fenfire.org/2007/fenserve#representation"
+fs_code = IRI "http://fenfire.org/2007/fenserve#code"
+fs_mimeType = IRI "http://fenfire.org/2007/fenserve#mimeType"
+fs_language = IRI "http://fenfire.org/2007/fenserve#language"
+
+storm = "http://fenfire.org/2007/storm"
+storm_depends = IRI "http://fenfire.org/2007/storm#depends"
+
+data Entry = DirEntry { entrySubdir :: Node }
+ | FileEntry { entryRepr :: Node }
+ | ExecutableEntry { entryCode :: Node }
+ deriving (Show, Read)
+
+entryNode (DirEntry n) = n; entryNode (FileEntry n) = n; entryNode (ExecutableEntry n) = n
+
+data Directory = Dir { dirNode :: Node, dirEntries :: [(String,Entry)] }
+ deriving (Show, Read)
+
+type FenServe = StateT Node StormIO
+
+runFenServe :: FenServe a -> Node -> Maybe FilePath -> IO (a, Node, Pool)
+runFenServe m node dir = do ((r,n),p) <- runStormIO (runStateT m node) dir
+ return (r,n,p)
+
+instance StormMonad FenServe where
+ getBlock = lift . getBlock
+ addBlock = lift . addBlock
+
+writeEmptyState :: FenServe Node
+writeEmptyState = postData "blk:/" $ Dir (IRI "new:block") []
+
+type Handler = Request -> FenServe 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
+ l <- toRDFList toRDFEntry entries
+ tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
+ tellTs [ (node, storm_depends, entryNode $ snd e) | e <- entries ]
+ return node
+ where toRDFEntry (name, entry) = do e <- toRDF entry; n <- toRDF name
+ tellTs [(e,fs_filename,n)]; return e
+
+instance FromRDF Directory where
+ readRDF g node = do
+ let l = query' (node, fs_entries, X) g
+ tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
+ entries <- readRDFList readRDFEntry g l
+ return $ Dir node entries
+ where readRDFEntry g n = do
+ let nameR = query' (n, fs_filename, X) g
+ name <- readRDF g nameR; entry <- readRDF g n
+ tellTs [ (n, fs_filename, nameR) ]; return (name, entry)
+
+instance ToRDF Entry where
+ toRDF (FileEntry repr) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_FileEntry), (e, fs_representation, repr) ]
+ return e
+ toRDF (DirEntry subdir) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_DirEntry), (e, fs_subdir, subdir) ]
+ return e
+ toRDF (ExecutableEntry code) = do
+ e <- newBNode
+ tellTs [ (e, rdf_type, fs_ExecutableEntry), (e, fs_code, code) ]
+ return e
+
+instance FromRDF Entry where
+ readRDF g node = case query' (node, rdf_type, X) g of
+ x | x == fs_FileEntry -> do
+ let repr = query' (node, fs_representation, X) g
+ tellTs [ (node, fs_representation, repr) ]
+ return $ FileEntry repr
+ x | x == fs_DirEntry -> do
+ let subdir = query' (node, fs_subdir, X) g
+ tellTs [ (node, fs_subdir, subdir) ]
+ return $ DirEntry subdir
+ x | x == fs_ExecutableEntry -> do
+ let code = query' (node, fs_code, X) g
+ tellTs [ (node, fs_subdir, code) ]
+ return $ ExecutableEntry code
+
+instance StartState Node where
+ startStateM =
+ runFenServe writeEmptyState e Nothing >>= \(r,_,_) -> return r where
+ e = error "FenServe.(StartState Node): this shouldn't be evaluated"
+
+instance Serialize Node where
+ typeString _ = "FenServe.State"
+ decodeStringM = defaultDecodeStringM
+ encodeStringM = defaultEncodeStringM
+
+instance ToMessage ByteString where
+ toMessageBodyM = return
+
+bURI :: BlockId -> String
+bURI (BlockId bid) = "blk:/" ++ bid
+
+bIRI :: BlockId -> Node
+bIRI bid = IRI $ bURI bid
+
+bID :: Node -> BlockId
+bID (IRI ('b':'l':'k':':':'/':s)) = BlockId $ takeWhile (/= '#') s
+bID node = error $ "Not a block IRI: " ++ show node
+
+getGraph :: String -> FenServe Graph
+getGraph uri = do bytes <- wget uri
+ let (ts, nss) = unsafePerformIO $
+ Raptor.bytesToTriples "turtle" bytes uri
+ return $ raptorToGraph ts nss uri
+
+showGraph :: Graph -> ByteString
+showGraph g = let (ts,nss) = graphToRaptor g; uri = iriStr $ defaultGraph g
+ in unsafePerformIO $ Raptor.triplesToBytes ts nss uri
+
+putGraph :: Graph -> FenServe ()
+putGraph g = wput (iriStr $ defaultGraph g) (showGraph g)
+
+postGraph :: String -> Graph -> FenServe String
+postGraph uri g = wpost uri (showGraph g)
+
+getData :: FromRDF a => Node -> FenServe a
+getData node = do graph <- getGraph (takeWhile (/= '#') $ iriStr node)
+ return $ fromRDF graph node
+
+putData :: ToRDF a => String -> a -> FenServe Node
+putData uri value = do let (node, ts) = runToRDF uri $ toRDF value
+ putGraph $ toGraph (IRI uri) ts
+ return node
+
+postData :: ToRDF a => String -> a -> FenServe Node
+postData uri value = do let (node, ts) = runToRDF "new:block" $ toRDF value
+ uri' <- postGraph uri $ toGraph (IRI "new:block") ts
+ return $ changeBaseURI "new:block" uri' node
+
+updateStormData :: (FromRDF a, ToRDF a) => EndoM FenServe a -> EndoM FenServe Node
+updateStormData f node = getData node >>= f >>= postData "blk:/"
+
+handleRequest :: Request -> FenServe Result
+handleRequest req = case scheme $ rqURI req of
+ "blk:" -> case rqMethod req of
+ GET -> do bytes <- getBlock (bID $ IRI $ render $ rqURI req)
+ return $ mkResult 200 "application/octet-stream" bytes
+ POST -> do bid <- addBlock (unBody $ rqBody req)
+ return $ setHeader "Location" (bURI bid) $
+ mkResult 201 "text/html" (toUTF "Created.\n")
+ s | s `elem` ["local:",""] -> let p = splitPath $ path $ rqURI req in do
+ e <- getEntry p
+ case e of Right (ExecutableEntry code) -> execute code req
+ _ -> case rqMethod req of GET -> getURI p req
+ PUT -> putURI p req
+ m -> error ("FenServe.handleRequest: unhandled method: " ++ show m)
+ s -> error ("FenServe.handleRequest: cannot handle scheme: " ++ s)
+
+wget :: String -> FenServe ByteString
+wget uri = do r <- handleRequest $ wrequest uri GET
+ return $ ByteString.concat $ rsBody r
+
+wput :: String -> ByteString -> FenServe ()
+wput uri body = do handleRequest $ (wrequest uri PUT) { rqBody=Body body }
+ return ()
+
+wpost :: String -> ByteString -> FenServe String
+wpost uri body = do r <- handleRequest $ (wrequest uri POST) {rqBody=Body body}
+ return $ fromMaybe (error "FenServe.wpost: no Location")
+ (getHeader "Location" r)
+
+wrequest :: String -> Method -> Request
+wrequest uri method = case parseURIReference uri of
+ Nothing -> error $ "FenServe.wrequest: not a legal URI: " ++ uri
+ Just u -> Request { rqURI=SURI u, rqVersion=Version 1 0,
+ rqHeaders=Headers Map.empty, rqBody=NoBody,
+ rqMethod=method, rqPeer=("localhost",-1234) }
+
+getURI :: [String] -> Request -> FenServe Result
+getURI path req = getEntry path >>= \entry -> case entry of
+ Left err -> return $ mkResult 404 "text/html" (toUTF err)
+ Right (FileEntry r) -> do s <- getBlock (bID r)
+ return $ mkResult 200 "text/html" s
+ Right (ExecutableEntry c) -> execute c req
+
+getEntry :: [String] -> FenServe (Either String Entry)
+getEntry path = do dir <- get; getEntry' path dir where
+ getEntry' [x] dir = getData dir >>= f . dirEntries where
+ f entries = case lookup x entries of
+ Just (DirEntry sub) -> getEntry' [""] sub
+ Just e -> return $ Right e
+ Nothing -> return $ Left $ "not found: " ++ x
+ getEntry' (x:xs) dir = getData dir >>= f . dirEntries where
+ f entries = case lookup x entries of
+ Just (DirEntry sub) -> getEntry' xs sub
+ Just e -> return $ Left $ "is not a dir: " ++ x
+ Nothing -> return $ Left $ "dir not found: " ++ x
+
+unBody NoBody = ByteString.empty
+unBody (Body b) = b
+unBody (LargeBody _ _) = error "FenServe.unBody: large body not handled"
+
+putURI :: [String] -> Request -> FenServe Result
+putURI path rq = do b <- liftM IRI $ wpost "blk:/" (unBody $ rqBody rq)
+ let (e,path') = if List.last path /= ".code"
+ then (FileEntry b, path)
+ else (ExecutableEntry b, List.init path)
+ putEntry path' e
+
+putEntry :: [String] -> Entry -> FenServe Result
+putEntry path e' = do get >>= putEntry' path >>= put
+ return $ mkResult 200 "text/html" (toUTF "Ok.\n") where
+ n' = IRI "new:block"
+ putEntry' [x] dir = updateStormData f' dir where
+ f' (Dir n entries) = do entries' <- f entries; return $ Dir n' entries'
+ f ((n, DirEntry sub) : es) | n == x = do sub' <- putEntry' [""] sub
+ return ((n, DirEntry sub'):es)
+ f ((n, e) : es) | n == x = return $ (n,e'):es
+ | otherwise = do es' <- f es; return $ (n,e):es'
+ f [] = return [(x, e')]
+ putEntry' (x:xs) dir = updateStormData f' dir where
+ recurse sub = do sub' <- putEntry' xs sub; return [(x, DirEntry sub')]
+ f' (Dir n entries) = do es' <- f entries; return (Dir n' es')
+ f ((n, DirEntry sub) : es) | n == x = liftM (++es) (recurse sub)
+ f ((n, e) : es) | n == x = error ("FIXME: not a dir: " ++ n)
+ f (e : es) = do es' <- f es; return (e:es')
+ f [] = writeEmptyState >>= recurse
+
+--------------------------------------------------------------------------
+-- Running executable resources
+--------------------------------------------------------------------------
+
+imports = ["Fenfire.RDF",
+ "Fenfire.Utils ((!?), Endo, maybeDo, BreadthT, scheduleBreadthT, execBreadthT)",
+ "HAppS hiding (Handler, query)",
+ "PagePrelude", "Storm", "FenServe",
+ "Control.Monad", "Control.Monad.State",
+ "Control.Monad.Writer hiding (Endo,Any)",
+ "Control.Monad.Reader", "Data.Maybe",
+ "qualified Data.ByteString as ByteString",
+ "qualified Data.List as List",
+ "qualified Data.Map as Map",
+ "qualified Data.Set as Set"]
+
+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 = let f (Left msg) = return $ mkResult 500 "text/plain" $ toUTF $ msg
+ f (Right h) = h req
+ 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
+
+ homedir <- liftIO $ getEnv "HOME"
+ 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 [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 $ modifyIORef codeCache (Map.insert (bID code) h)
+ return h
+
+
+--------------------------------------------------------------------------
+-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
+--------------------------------------------------------------------------
+
+splitPath :: String -> [String]
+splitPath ('/':x) = a : splitPath b where (a,b) = break (=='/') x
+splitPath [] = []
+splitPath _ = error "splitPath: malformed path"
+
+--------------------------------------------------------------------------
diff -rN -u old-fenserve/StormData.hs new-fenserve/StormData.hs
--- old-fenserve/StormData.hs 2007-04-05 03:26:45.000000000 +0300
+++ new-fenserve/StormData.hs 2007-04-05 03:26:45.000000000 +0300
@@ -60,8 +60,11 @@
Raptor.bytesToTriples "turtle" bytes (iriStr n)
return $ raptorToGraph ts nss (iriStr n)
+getData :: (FromRDF a, StormMonad m) => Node -> m a
+getData n = do g <- getGraph n; return $ fromRDF g n
+
readStormRef :: (FromRDF a, ToRDF a, StormMonad m) => StormRef a -> m a
-readStormRef (StormRef n) = do g <- getGraph n; return $ fromRDF g n
+readStormRef (StormRef n) = getData n
showGraph :: Graph -> ByteString
showGraph g = let (ts,nss) = graphToRaptor g; uri = iriStr $ defaultGraph g
@@ -70,11 +73,13 @@
addGraph :: StormMonad m => Graph -> m Node
addGraph g = liftM bIRI $ addBlock (showGraph g)
+addData :: (ToRDF a, StormMonad m) => a -> m Node
+addData value = do let (node, ts) = runToRDF "new:block" $ toRDF value
+ node' <- addGraph $ toGraph (IRI "new:block") ts
+ return $ changeBaseURI "new:block" (iriStr node') node
+
newStormRef :: (FromRDF a, ToRDF a, StormMonad m) => a -> m (StormRef a)
-newStormRef value = do
- let (node, ts) = runToRDF "new:block" $ toRDF value
- node' <- addGraph $ toGraph (IRI "new:block") ts
- return $ StormRef $ changeBaseURI "new:block" (iriStr node') node
+newStormRef = liftM StormRef . addData
modifyStormRef :: (FromRDF a, ToRDF a, StormMonad m) =>
EndoM m a -> EndoM m (StormRef a)
More information about the Fencommits
mailing list