{-# 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" --------------------------------------------------------------------------