bein 0.2 → 0.3
raw patch · 40 files changed
+5325/−2 lines, 40 files
Files
- Bein/Commands.hs +66/−0
- Bein/Configuration.hs +53/−0
- Bein/Daemon/Commands.hs +85/−0
- Bein/Daemon/Protocol.hs +180/−0
- Bein/Daemon/SignalHandlers.hs +65/−0
- Bein/Daemon/Types.hs +28/−0
- Bein/Minion/Arguments.hs +65/−0
- Bein/Minion/Commands.hs +103/−0
- Bein/Minion/Protocol.hs +219/−0
- Bein/Minion/Types.hs +38/−0
- Bein/ShellScripting.hs +14/−0
- Bein/SocketHandler.hs +79/−0
- Bein/Types.hs +119/−0
- Bein/Web/Authentication.hs +56/−0
- Bein/Web/Commands.hs +7/−0
- Bein/Web/Commands/Local.hs +323/−0
- Bein/Web/Elements.hs +62/−0
- Bein/Web/Elements/Attributes.hs +6/−0
- Bein/Web/Elements/Base.hs +42/−0
- Bein/Web/Elements/Tags.hs +187/−0
- Bein/Web/Pages/Common.hs +201/−0
- Bein/Web/Pages/Index.hs +85/−0
- Bein/Web/Pages/Login.hs +48/−0
- Bein/Web/Pages/New.hs +21/−0
- Bein/Web/Pages/Object.hs +749/−0
- Bein/Web/Pages/Settings.hs +135/−0
- Bein/Web/Pages/SignOut.hs +10/−0
- Bein/Web/Routing.hs +35/−0
- Bein/Web/Types.hs +7/−0
- Bein/Web/Types/Local.hs +115/−0
- INSTALL +36/−0
- README +19/−0
- bein.cabal +22/−2
- sql/core_tables.sql +463/−0
- sql/immutability_test_data.sql +48/−0
- sql/test_data.sql +44/−0
- sql/triggers.sql +1012/−0
- sql/untrusted_functions.sql +64/−0
- sql/utility_functions.sql +21/−0
- static/default.css +393/−0
+ Bein/Commands.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleContexts #-}+module Bein.Commands where+ +import Prelude hiding (catch)+import System.IO+import Data.Convertible+import Control.Monad.Trans ()+import Control.Exception (catch)+import Control.Concurrent ( forkIO, ThreadId )+import Control.Monad.Reader+ ( MonadReader(ask), MonadIO(..), ReaderT(runReaderT) )+import Bein.Types ( BeinState(..), BeinM )+import Database.HDBC.PostgreSQL (Connection)+import Database.HDBC+ ( SqlValue, fromSql, IConnection(commit, run), quickQuery', handleSqlError, withTransaction )+++encodeResponse :: String -> String -> String +encodeResponse header body = header ++ "\n" ++ body'' ++ ".\n"+ where body' = unlines $ map dotEscape $ lines body+ body'' = if body' == "" || last body' == '\n' then body' else body' ++ "\n"+ dotEscape ('.':cs) = ".." ++ cs+ dotEscape cs = cs++forkR :: BeinState s => BeinM s () -> BeinM s ThreadId+forkR f = do st <- ask+ liftIO $ forkIO $ runReaderT f st++catchR :: BeinM s a -> (IOError -> BeinM s a) -> BeinM s a+a `catchR` b = ask >>= \st -> liftIO $ handleSqlError (runReaderT a st) `catch` (\e -> runReaderT (b e) st)++database :: BeinState s => ReaderT s IO Connection+database = ask >>= return.db++query :: BeinState s => String -> [SqlValue] -> BeinM s [[SqlValue]]+query q vs = database >>= \conn -> liftIO $ withTransaction conn (\c -> quickQuery' c q vs)++update :: BeinState s => String -> [SqlValue] -> BeinM s ()+update q vs = database >>= \conn -> liftIO $ withTransaction conn (\c -> run c q vs >> commit c)++updateWithResponse :: BeinState s => String -> [SqlValue] -> BeinM s [[SqlValue]]+updateWithResponse q vs = database >>= \conn -> do res <- liftIO $ quickQuery' conn q vs+ liftIO $ commit conn+ return res++oneValueUpdate :: Convertible SqlValue a => BeinState s => String -> [SqlValue] -> BeinM s (Maybe a)+oneValueUpdate q vs = do+ res <- updateWithResponse q vs+ case res of+ [] -> return Nothing+ [[x]] -> return (Just (fromSql x))+ r -> error $ "Received invalidly shaped response from database: " ++ show r+ +getCommandBlock :: Handle -> IO String+getCommandBlock h = f h ""+ where f h' acc = do l <- hGetLine h+ case l of+ "." -> return acc+ ('.':'.':rest) -> f h' (acc ++ "." ++ rest ++ "\n")+ _ -> f h' (acc ++ l ++ "\n")++maybeRowQuery :: BeinState s => String -> [SqlValue] -> BeinM s (Maybe [SqlValue])+maybeRowQuery qstr vals = query qstr vals >>= \r -> case r of+ [] -> return Nothing+ [x] -> return (Just x)+ _ -> error "Received multiple rows to a maybeRowQuery."
+ Bein/Configuration.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+module Bein.Configuration where++import Database.HDBC+ ( SqlValue,+ fromSql,+ toSql,+ Statement(execute, fetchRow),+ IConnection(prepare) )+import Control.Exception ()+import Data.Convertible ( Convertible )+import System.Posix.Syslog ()+import Bein.Types ( Configuration(..) )++readConfiguration :: IConnection c => c -> IO Configuration+readConfiguration conn = do+ stmt <- prepare conn "select value from configuration where key = ?"+ vfile_repository <- readKey stmt "file_repository"+ vscratch_directory <- readKey stmt "scratch_directory"+ vperl_executable <- readKey stmt "perl_executable"+ vr_executable <- readKey stmt "r_executable"+ vmax_executions <- readKey stmt "max_executions"+ vminion_command <- readKey stmt "minion_command"+ vdaemon_port <- readKey stmt "daemon_port"+ vminion_port <- readKey stmt "minion_port"+ vhttp_port <- readKey stmt "http_port"+ vhttp_base_url <- readKey stmt "http_base_url"+ vauthentication <- readKey stmt "authentication"+ vtemplate_path <- readKey stmt "template_path"+ vstatic_content_directory <- readKey stmt "static_content_directory"+ return $ Configuration {+ file_repository = vfile_repository,+ scratch_directory = vscratch_directory,+ static_content_directory = vstatic_content_directory,+ perl_executable = vperl_executable,+ r_executable = vr_executable,+ max_executions = vmax_executions,+ minion_command = vminion_command,+ daemon_port = vdaemon_port,+ minion_port = vminion_port,+ http_port = vhttp_port,+ http_base_url = vhttp_base_url, + template_path = vtemplate_path,+ authentication = vauthentication }+ +readKey :: Convertible SqlValue a => Statement -> String -> IO a +readKey stmt k = do+ _ <- execute stmt [toSql k]+ fetchRow stmt >>= \v -> case v of+ Nothing -> error $ "No value for parameter " ++ k+ Just [val] -> return $ fromSql val+ Just _ -> error "Received multiple fields from database when reading configuration key. Your database schema is wrong."+
+ Bein/Daemon/Commands.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Bein.Daemon.Commands (+ module Bein.Commands,+ exitDaemon,+ reconfigureDaemon,+ updateJobs,+ database,+ runMinion+) where++import Control.Concurrent.QSem ( signalQSem, waitQSem )+import System.Posix.Process+ ( executeFile, exitImmediately, forkProcess )+import System.Random ( Random(randomR), getStdGen, setStdGen )+import Database.HDBC.PostgreSQL ( Connection )+import Database.HDBC+ ( fromSql, toSql )+import Control.Monad.Trans ()+import Control.Monad.Reader ( MonadReader(ask), MonadIO(..) )+import Control.Concurrent.STM ( atomically, writeTVar )+import Control.Exception ()+import System.Exit ( ExitCode(ExitSuccess) )+import System.Posix.Process ()+import System.Posix.Syslog ( syslog, Priority(Notice, Error) )+import System.Posix.Files ( removeLink, fileExist )+import Bein.Commands ( encodeResponse, forkR, catchR, query, update )+import Bein.Configuration ( readConfiguration )+import Bein.Daemon.Types+ ( Configuration(max_executions, minion_command),+ BeinState(..),+ BeinM,+ ExecutionID(..),+ configField,+ DaemonState(stSem) )++exitDaemon :: BeinM a ()+exitDaemon = liftIO $ do+ removeLink "/var/run/beind.pid"+ syslog Notice "Exiting."+ exitImmediately ExitSuccess++reconfigureDaemon :: BeinM DaemonState ()+reconfigureDaemon = do+ liftIO $ syslog Notice "Reconfiguring."+ st <- ask+ config <- liftIO $ readConfiguration (db st)+ liftIO $ atomically $ writeTVar (configT st) config++updateJobs :: BeinM DaemonState ()+updateJobs = do+ jobSemaphore <- ask >>= return.stSem+ liftIO $ waitQSem jobSemaphore+ maxExecutions <- configField max_executions+ toRun <- query queryString [toSql maxExecutions]+ mapM_ runMinion (map (fromSql.head) toRun)+ liftIO $ signalQSem jobSemaphore+ where queryString = "select id from current_jobs where status = 'pending' " ++ + "limit (select ?-count(id) from current_jobs where status='running')"++database :: BeinM DaemonState Connection+database = ask >>= return.db++randomFileName :: Int -> IO String+randomFileName n = do+ g <- getStdGen+ let (s, g') = randomFileName' g n+ setStdGen g'+ return s+ where randomFileName' g 0 = ([],g)+ randomFileName' g m = let (k,g') = randomR (0,61) g+ (str,g'') = randomFileName' g' (m-1)+ in (toChar k : str, g'')+ toChar :: Int -> Char+ toChar q = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" !! q++runMinion :: ExecutionID -> BeinM DaemonState ()+runMinion (ExecutionID ex) = do+ minionCmd <- configField minion_command+ d <- liftIO $ randomFileName 50+ (liftIO $ fileExist minionCmd) >>= \b -> if b + then do p <- liftIO $ forkProcess $ executeFile minionCmd False ["-x",show ex,"-d",d] Nothing+ update "update current_jobs set (status,running_as_pid,scratch_dir) = ('running',?,?) where id = ?" + [toSql $ toInteger p, toSql d, toSql ex]+ else do update "update executions set status='failed' where id=?" [toSql ex]+ liftIO $ syslog Error "beinminion does not exist. Can't execute jobs."
+ Bein/Daemon/Protocol.hs view
@@ -0,0 +1,180 @@+module Bein.Daemon.Protocol where++import Text.Printf ()+import Data.List ( intercalate )+import Database.HDBC ( fromSql, toSql, SqlValue(..) )+import Control.Monad ()+import qualified System.IO.Error as S ( try )+import Control.Monad.Trans ()+import Text.ParserCombinators.Parsec+ ( parse,+ (<|>),+ try,+ CharParser,+ many1,+ digit,+ newline,+ string,+ eof )+import System.Posix.Syslog ( Priority(Error), syslog )+import System.Posix.Types ()+import System.Posix.Signals ( sigTERM, signalProcess )+import Bein.SocketHandler ()+import Bein.Daemon.Types+ ( BeinM, ExecutionID(..), unExecutionID, DaemonState )+import Bein.Daemon.Commands+ ( encodeResponse,+ catchR,+ exitDaemon,+ reconfigureDaemon,+ updateJobs,+ query,+ update )+import Control.Monad.Reader+ ( MonadPlus(mzero),+ liftM,+ MonadReader(ask),+ MonadIO(..),+ ReaderT(runReaderT) )+import Bein.Configuration ()++daemonProtocol :: String -> BeinM DaemonState String+daemonProtocol received = do+ case parse command "socket" received of+ Left e -> return $ "200 unknown command\n" ++ show e ++ "\n.\n"+ Right c -> executeCommand c++tryR :: (MonadReader r m, MonadIO m) => ReaderT r IO a -> m (Either IOError a) +tryR f = do+ st <- ask+ liftIO $ S.try (runReaderT f st)+ +executeCommand :: BeinDCommand -> BeinM DaemonState String+executeCommand Reconfigure = do+ tryR reconfigureDaemon >>= \x -> case x of+ Left e -> do liftIO $ syslog Error $ "Configuration error: " ++ show e+ return $ "error\n" ++ show e ++ "\n.\n"+ Right () -> return $ encodeResponse "0 ok" ""+executeCommand Jobs = listJobs Nothing+executeCommand (Status exs) = listJobs (Just [exs])+executeCommand (Run ex) = runJob ex `catchR` (\e -> return $ encodeResponse "15 database access error" (show e))+executeCommand (Stop _) = return $ encodeResponse "500 unimplemented command" ""+executeCommand (Continue _) = return $ encodeResponse "500 unimplemented command" ""+executeCommand (Kill ex) = killProcess ex `catchR` (\e -> return $ encodeResponse "15 database access error" (show e))+executeCommand Exit = exitDaemon >> return ""+ +data BeinDCommand = Reconfigure + | Jobs+ | Status ExecutionID+ | Run ExecutionID+ | Stop ExecutionID+ | Continue ExecutionID+ | Kill ExecutionID+ | Exit+ deriving (Eq,Show,Read)++reconfigure :: CharParser st BeinDCommand +jobs :: CharParser st BeinDCommand+status :: CharParser st BeinDCommand+run :: CharParser st BeinDCommand+stop :: CharParser st BeinDCommand+continue :: CharParser st BeinDCommand+kill :: CharParser st BeinDCommand+exit :: CharParser st BeinDCommand++reconfigure = bodylessCommand "reconfigure" Reconfigure+jobs = bodylessCommand "jobs" Jobs+status = oneExecutionIDCommand "status" Status+run = oneExecutionIDCommand "run" Run+stop = oneExecutionIDCommand "stop" Stop+continue = oneExecutionIDCommand "continue" Continue+kill = oneExecutionIDCommand "kill" Kill+exit = bodylessCommand "exit" Exit++command :: CharParser st BeinDCommand+command = foldr (<|>) mzero commands+ where commands = map try [reconfigure, jobs, status, run, stop,+ continue, kill, exit]++integerLine :: (Read a, Integral a) => CharParser st a+integerLine = do x <- many1 digit+ newline+ return $ read x++manyExecutionIDsCommand :: String -> ([ExecutionID] -> a) -> CharParser st a+manyExecutionIDsCommand cmd constr = do + string cmd+ newline+ ids <- many1 integerLine+ eof+ return $ constr $ map ExecutionID ids++oneExecutionIDCommand :: String -> (ExecutionID -> a) -> CharParser st a+oneExecutionIDCommand cmd constr = do+ string cmd+ newline+ ids <- integerLine+ eof+ return $ constr $ ExecutionID ids++bodylessCommand :: String -> a -> CharParser st a+bodylessCommand cmd val = do string cmd+ newline+ eof+ return val++listJobs :: Maybe [ExecutionID] -> BeinM DaemonState String+listJobs v = listJobs' v `catchR` (\e -> return $ encodeResponse "15 database access error" (show e))++listJobs' :: Maybe [ExecutionID] -> BeinM DaemonState String+listJobs' v = do+ jobList <- case v of + Nothing -> query "select id,status,running_as_pid,scratch_dir from current_jobs" []+ Just exs -> query "select id,status,running_as_pid,scratch_dir from current_jobs where array[id] <@ ?" [toSql exs]+ body <- liftM unlines $ mapM listJob jobList+ return $ encodeResponse "0 ok" body++listJob :: [SqlValue] -> BeinM DaemonState String+listJob [sId, sStatus, sPid, sScratchDir] = + case fromSql sStatus of+ "waiting" -> do+ jobList <- query "select id from jobs_awaiting where awaited_by=?" [sId]+ let jobids = map (fromSql.head) jobList :: [Int]+ jid = fromSql sId :: Int+ return $ show jid ++ "\t--\twaiting\t--\t" ++ (intercalate ", " $ map show jobids)+ "pending" -> do+ let jid = fromSql sId :: Int+ return $ show jid ++ "\t--\tpending\t--"+ "running" -> do+ let jid = fromSql sId :: Int+ pid = fromSql sPid :: Integer+ scratchDir = fromSql sScratchDir :: FilePath+ return $ show jid ++ "\t" ++ show pid ++ "\tpending\t" ++ scratchDir+ other -> error $ "Invalid status: " ++ other+listJob _ = error "Invalid arguments to listJob."+ + +runJob :: ExecutionID -> BeinM DaemonState String+runJob ex = do+ query "select id from executions where id = ?" [toSql ex] >>= \r -> case r of+ [] -> return $ encodeResponse "110 unknown execution" (show $ unExecutionID ex)+ [_] -> (do update "select run(?)" [toSql ex]+ updateJobs+ return $ encodeResponse "0 ok" (show $ unExecutionID ex))+ `catchR` (\e -> return $ encodeResponse "15 database access error" (show e))+ _ -> error "Got multiple results back from the database. Coherence lost. Dying."++killProcess :: ExecutionID -> BeinM DaemonState String+killProcess ex = do+ query "select running_as_pid from current_jobs where id=?" [toSql ex] >>= \r -> case r of + [] -> return $ encodeResponse "120 no such job" (show $ unExecutionID ex)+ [[sPid]] -> do + update "delete from current_jobs where id=?" [toSql ex]+ if sPid /= SqlNull then + let pid = fromSql sPid :: Integer+ in (do update "update executions set status='failed' where id=? and status='running'" [toSql ex]+ liftIO $ signalProcess sigTERM (fromIntegral pid)+ return $ encodeResponse "0 ok" (show $ unExecutionID ex))+ `catchR` (\e -> return $ encodeResponse "150 failed to kill" (show e))+ else return $ encodeResponse "0 ok" (show $ unExecutionID ex)+ _ -> error "Got multiple results back from the database. Coherence lost. Dying."
+ Bein/Daemon/SignalHandlers.hs view
@@ -0,0 +1,65 @@+module Bein.Daemon.SignalHandlers (installSignalHandlers) where++import Database.HDBC ( fromSql, toSql )+import System.Exit ()+import System.Posix.Process ( ProcessStatus, getAnyProcessStatus )+import System.Posix.Process ()+import System.Posix.Signals+ ( installHandler,+ sigALRM,+ sigCHLD,+ sigHUP,+ sigPIPE,+ sigPROF,+ sigTERM,+ sigUSR1,+ sigUSR2,+ sigVTALRM,+ Handler(Ignore, Catch),+ fullSignalSet,+ deleteSignal )+import System.Posix.Syslog ( syslog, Priority(Notice) )+import System.Posix.Types ( ProcessID )+import System.Posix.Files ( fileExist )+import System.Directory ( removeDirectoryRecursive )+import Control.Monad.Trans ()+import Control.Monad.Reader+ ( when, MonadReader(ask), MonadIO(..), ReaderT(runReaderT) )+import Bein.Daemon.Commands+ ( exitDaemon, reconfigureDaemon, updateJobs, query, update )+import Bein.Daemon.Types ( BeinM, DaemonState )+ +installSignalHandlers :: BeinM DaemonState ()+installSignalHandlers = do+ st <- ask+ liftIO $ do+ installHandler sigALRM Ignore Nothing+ installHandler sigCHLD (Catch $ runReaderT (onDeadChildren cleanUpChild) st) (Just fullSignalSet)+ installHandler sigHUP (Catch $ runReaderT reconfigureDaemon st) Nothing+ installHandler sigPIPE Ignore Nothing+ installHandler sigPROF Ignore Nothing+ installHandler sigTERM (Catch $ runReaderT exitDaemon st) (Just $ deleteSignal sigCHLD fullSignalSet)+ installHandler sigUSR1 (Catch $ runReaderT updateJobs st) Nothing+ installHandler sigUSR2 Ignore Nothing+ installHandler sigVTALRM Ignore Nothing+ return ()+ +cleanUpChild :: ProcessID -> ProcessStatus -> BeinM DaemonState ()+cleanUpChild pid _ = do+ query "select id,status,scratch_dir from current_jobs where running_as_pid = ?" [toSql $ toInteger pid] >>= \r -> case r of+ [] -> liftIO $ syslog Notice ("Received SIGCHLD from unknown child with pid " ++ show pid)+ [[sId,_sStatus,sSD]] -> do liftIO $ ensureDeleted (fromSql sSD) + update "delete from current_jobs where id = ?" [sId]+ update "update executions set status='failed' where id = ? and status = 'running'" [sId]+ _ -> error "Invalid response from database. Should have been unique."++ensureDeleted :: FilePath -> IO ()+ensureDeleted path = fileExist path >>= \b -> when b $ removeDirectoryRecursive path `catch` (const $ return ()) + +onDeadChildren :: (ProcessID -> ProcessStatus -> BeinM DaemonState ()) -> BeinM DaemonState ()+onDeadChildren act = do+ v <- liftIO $ getAnyProcessStatus False False+ case v of+ Just (pid,status) -> act pid status >> onDeadChildren act+ Nothing -> return ()+
+ Bein/Daemon/Types.hs view
@@ -0,0 +1,28 @@+module Bein.Daemon.Types (+ module Bein.Types,+ DaemonState(..)+) where++import Bein.Types+ ( BeinError(..),+ AuthenticationFailed(..),+ Authentication(..),+ ConfigurationError(..),+ Configuration(..),+ BeinState(..),+ BeinM,+ ExecutionID(..),+ configField,+ unExecutionID,+ errorNumber,+ errorName )+import Database.HDBC.PostgreSQL ( Connection )+import Control.Concurrent.STM ( TVar )+import Control.Concurrent.QSem ( QSem )++data DaemonState = State { stDb :: Connection, stConfigT :: TVar Configuration, stSem :: QSem }++instance BeinState DaemonState where+ configT = stConfigT+ db = stDb+
+ Bein/Minion/Arguments.hs view
@@ -0,0 +1,65 @@+module Bein.Minion.Arguments where++import System.Console.GetOpt+ ( OptDescr(..),+ ArgOrder(RequireOrder),+ ArgDescr(NoArg, ReqArg),+ getOpt,+ usageInfo )+import System.Environment ( getArgs, getProgName )+import System.Exit ( exitSuccess, exitFailure )+import System.IO ( hPutStrLn, stderr )+import Bein.Minion.Types ( ExecutionID(..), Settings(..) )++getSettings :: IO Settings+getSettings = do+ args <- getArgs+ case getOpt RequireOrder options args of+ (actions, _, []) -> do opts <- foldl (>>=) (return defaultSettings) actions+ case valid opts of+ Left err -> printHelpAndDie (Just err)+ Right o -> return o+ (_, _, errs) -> printHelpAndDie (Just $ concat errs)+ +valid :: Settings -> Either String Settings +valid opts = + if setScratchDir opts == "" && setExecution opts == ExecutionID (-1)+ then Left "Must specify scratch directory and execution."+ else Right opts ++printHelpAndDie :: Maybe String -> IO a+printHelpAndDie msg = do+ case msg of+ Nothing -> help >> exitSuccess+ Just m -> hPutStrLn stderr m >> help >> exitFailure+ where help = do + programName <- getProgName+ hPutStrLn stderr (usageInfo programName options)++options :: [OptDescr (Settings -> IO Settings)]+options = [+ + Option "h" ["help"] + (NoArg (\_ -> printHelpAndDie Nothing))+ "Show help",+ + Option "v" ["verbose"] + (NoArg (\opt -> return opt { setVerbose = True })) + "Be verbose.",+ + Option "x" ["execution"] + (ReqArg (\arg opt -> + let ex = ExecutionID (read arg)+ in return opt { setExecution = ex }) "EXECUTIONID") + "Execution to process",+ + Option "d" ["scratchdir"] + (ReqArg (\arg opt -> return opt { setScratchDir = arg }) "DIRECTORY") + "Scratch directory"+ + ]+ +defaultSettings :: Settings+defaultSettings = Settings { setVerbose = False,+ setScratchDir = "",+ setExecution = ExecutionID (-1) }
+ Bein/Minion/Commands.hs view
@@ -0,0 +1,103 @@+module Bein.Minion.Commands (+ module Bein.Commands,+ ifVerbose, verboseMsg, verboseMsgLn,+ scratchDir, execution, minionSocket,+ minionPid, writeMinionPid,+ dieWith,+ query, update,+ cleanUp,+ receiveOneRow,+ ignoreSignal+) where++import Database.HDBC+ ( SqlValue, toSql, IConnection(commit, run), quickQuery' )+import Control.Monad.Trans ()+import System.IO ()+import Control.Monad.Reader+ ( MonadReader(ask), MonadIO(..), ReaderT )+import System.Posix.Types ( ProcessID )+import Control.Concurrent.STM ( atomically, readTVar, writeTVar )+import System.Exit ( ExitCode(ExitFailure) )+import System.IO ()+import System.Environment ()+import System.Console.GetOpt ()+import System.FilePath.Posix ( joinPath )+import System.Directory+ ( removeDirectoryRecursive, setCurrentDirectory )+import System.Posix.Signals+ ( Signal, Handler(Ignore), installHandler, sigKILL, signalProcess )+import System.Posix.Process ( exitImmediately )+import System.IO ( stdout, hPutStrLn, hFlush )+import Bein.Commands ( encodeResponse, forkR, catchR, database, maybeRowQuery )+import Bein.Minion.Types+ ( Configuration(minion_port, scratch_directory),+ BeinM,+ ExecutionID,+ configField,+ State(stMinionPid, stSettings),+ Settings(setExecution, setScratchDir, setVerbose) )+import Bein.Minion.Arguments ()++ifVerbose :: ReaderT State IO () -> ReaderT State IO ()+ifVerbose act = ask >>= \st -> if setVerbose (stSettings st) then act else return ()++verboseMsg :: String -> ReaderT State IO ()+verboseMsg m = ifVerbose $ liftIO $ putStr m >> hFlush stdout++verboseMsgLn :: String -> BeinM State ()+verboseMsgLn m = ifVerbose $ liftIO $ putStrLn m >> hFlush stdout++scratchDir :: ReaderT State IO FilePath+scratchDir = do + st <- ask + baseDir <- configField scratch_directory+ let scrDir = setScratchDir $ stSettings st+ return $ joinPath [baseDir, scrDir]++execution :: ReaderT State IO ExecutionID+execution = ask >>= return.stSettings >>= return.setExecution++minionSocket :: ReaderT State IO FilePath+minionSocket = do+ dir <- scratchDir+ minionSocketName <- configField minion_port+ return $ joinPath [dir,minionSocketName]++minionPid :: ReaderT State IO (Maybe ProcessID)+minionPid = ask >>= return.stMinionPid >>= liftIO.atomically.readTVar++writeMinionPid :: ProcessID -> ReaderT State IO ()+writeMinionPid pid = ask >>= return.stMinionPid >>= \v -> + liftIO $ atomically $ writeTVar v (Just pid)+ +dieWith :: String -> BeinM State a+dieWith m = (liftIO $ hPutStrLn stdout m) >> cleanUp (ExitFailure 1)++query :: String -> [SqlValue] -> BeinM State [[SqlValue]]+query q vs = database >>= \conn -> liftIO $ quickQuery' conn q vs++update :: String -> [SqlValue] -> BeinM State ()+update q vs = database >>= (\conn -> liftIO $ run conn q vs >> commit conn)++cleanUp :: ExitCode -> BeinM State a+cleanUp term = do+ minionPid >>= \p -> liftIO $ (case p of + Nothing -> return ()+ Just pid -> signalProcess sigKILL pid) `catch` (const $ return ())+ configField scratch_directory >>= liftIO.setCurrentDirectory + scratchDir >>= \d -> liftIO $ (removeDirectoryRecursive d `catch` (const $ return ()))+ execution >>= \ex -> update updateString [toSql ex]+ liftIO $ exitImmediately term+ return undefined+ where updateString = "update executions set status = 'failed' " +++ "where id=? and status='running'"++receiveOneRow :: BeinM State [[a]] -> BeinM State [a]+receiveOneRow act = act >>= \r -> case r of+ [] -> dieWith "Received no rows from database."+ [a] -> return a+ _ -> dieWith "Received multiple rows from database."+ +ignoreSignal :: Signal -> BeinM s Handler+ignoreSignal sig = liftIO $ installHandler sig Ignore Nothing
+ Bein/Minion/Protocol.hs view
@@ -0,0 +1,219 @@+module Bein.Minion.Protocol where++import System.Directory (doesFileExist)+import Prelude hiding (log)+import Text.ParserCombinators.Parsec+ ( CharParser,+ anyChar,+ char,+ newline,+ noneOf,+ oneOf,+ spaces,+ string,+ eof,+ (<|>),+ many,+ parse,+ try )+import Control.Monad ( MonadPlus(mzero) )+import Control.Monad.Trans ( liftIO )+import Database.HDBC ( fromSql, toSql, IConnection(commit, run) )+import System.Directory ( copyFile )+import System.FilePath.Posix ( joinPath )+import System.Posix.Files ( createSymbolicLink, rename )+import Bein.Minion.Types+ ( Configuration(file_repository), BeinM, configField, State )+import Bein.Minion.Commands+ ( encodeResponse,+ catchR,+ scratchDir,+ execution,+ database,+ query,+ update,+ receiveOneRow, + maybeRowQuery )++minionProtocol :: String -> BeinM State String +minionProtocol received = do+ case parse command "socket" received of+ Left e -> return $ "200 unknown command\n" ++ show e ++ "\n.\n"+ Right c -> executeCommand c++command :: CharParser st MinionCommand+command = foldr (<|>) mzero commands+ where commands = map try [log,get,put,completed,failed]++executeCommand :: MinionCommand -> BeinM State String+executeCommand c = executeCommand' c `catchR` + (\e -> return $ "15 database access error\n" ++ show e ++ "\n.\n")++executeCommand' :: MinionCommand -> BeinM State String+executeCommand' (Log body) = do + mapM_ writeLog $ lines body+ database >>= liftIO . commit+ return "0 ok\n.\n"+executeCommand' (Get lbl format) = do+ getInput lbl format+executeCommand' (Put lbl format body) = do+ putOutput lbl format body+executeCommand' Completed = do+ ex <- execution+ update "update executions set status='complete' where id=?" [toSql ex]+ return "0 ok\n.\n"+executeCommand' Failed = do+ ex <- execution+ update "update executions set status='failed' where id=?" [toSql ex]+ return "0 ok\n.\n"++writeLog :: String -> BeinM State Integer+writeLog line = do+ ex <- execution+ database >>= \conn -> liftIO $ run conn queryString [toSql ex, toSql line]+ where queryString = "insert into execution_logs (id,log_time,log_message) " ++ + "values (?,now(),?)"++data MinionCommand = Log String+ | Get Label GetFormat+ | Put Label PutFormat String+ | Completed+ | Failed+ deriving (Eq,Show,Read)+ +type Label = String ++data GetFormat = GetCopy | GetReadOnlyLink | GetNoFormat deriving (Eq,Show,Read)++data PutFormat = PutMove | PutCopy | PutNoFormat deriving (Eq,Show,Read)++log :: CharParser st MinionCommand+log = do+ string "10 log"+ newline+ ls <- many anyChar+ eof+ return $ Log ls+ +quotedString :: CharParser st String+quotedString = do+ char '"'+ str <- many escapedChar+ char '"'+ return str+ where escapedChar = (try (string "\\\"") >> return '"') <|> noneOf "\""++getFormat :: CharParser st GetFormat+getFormat = (try (string "copy") >> return GetCopy) <|>+ (string "read-only-link" >> return GetReadOnlyLink)++get :: CharParser st MinionCommand+get = do+ string "20 get"+ spaces+ lbl <- quotedString+ many $ oneOf " \t"+ format <- try getFormat <|> return GetNoFormat+ many $ oneOf " \t"+ newline+ eof+ return $ Get lbl format++putFormat :: CharParser st PutFormat+putFormat = (try (string "copy") >> return PutCopy) <|>+ (try (string "move") >> return PutMove) <|>+ return PutNoFormat++put :: CharParser st MinionCommand+put = do+ string "30 put"+ spaces+ lbl <- quotedString+ many $ oneOf " \t"+ format <- try putFormat <|> return PutNoFormat+ many $ oneOf " \t"+ newline+ ls <- many anyChar+ eof+ return $ Put lbl format ls++completed :: CharParser st MinionCommand+completed = bodylessCommand "100 completed" Completed++failed :: CharParser st MinionCommand+failed = bodylessCommand "200 failed" Failed++bodylessCommand :: String -> a -> CharParser st a+bodylessCommand cmd val = do string cmd+ newline+ eof+ return val+++getInput :: String -> GetFormat -> BeinM State String+getInput lbl format = do+ ex <- execution+ t <- maybeRowQuery "select type from execution_inputs where id=? and label=?" [toSql ex, toSql lbl]+ case fmap (fromSql . head) t of+ Just "sequence" -> return "500 unimplemented command\n.\n"+ Just "number" -> getNumberInput lbl+ Just "string" -> getStringInput lbl+ Just "file" -> getFileInput lbl format+ Nothing -> return $ encodeResponse "32 no such label" ""+ _ -> error "Invalid type in getInput."+ +getStringInput :: String -> BeinM State String+getStringInput lbl = do+ ex <- execution+ [v] <- receiveOneRow $ query "select value from execution_string_inputs where id=? and label=?" [toSql ex, toSql lbl]+ let v' = fromSql v+ return $ encodeResponse "0 ok" v' + +getNumberInput :: String -> BeinM State String+getNumberInput lbl = do+ ex <- execution+ [v] <- receiveOneRow $ query "select value from execution_number_inputs where id=? and label=?" [toSql ex, toSql lbl]+ let v' = fromSql v+ return $ encodeResponse "0 ok" v'+ +getFileInput :: String -> GetFormat -> BeinM State String+getFileInput lbl GetNoFormat = getFileInput lbl GetCopy+getFileInput lbl format = do+ ex <- execution+ sd <- scratchDir+ [fname] <- receiveOneRow $ query ("select f.stored_as from files as f right join " ++ + "execution_object_inputs as e on e.value=f.id where e.label=? and e.id=?")+ [toSql lbl, toSql ex]+ let fname' = fromSql fname+ filePath <- configField file_repository+ liftIO $ (if format == GetCopy then copyFile else createSymbolicLink) (joinPath [filePath, fname']) (joinPath [sd, fname'])+ return $ encodeResponse "0 ok" fname'+ + +putOutput :: String -> PutFormat -> String -> BeinM State String +putOutput lbl format body = do+ ex <- execution+ r <- maybeRowQuery "select target,type from execution_outputs where id=? and label=?" [toSql ex, toSql lbl]+ case fmap (\[a,b] -> (fromSql a, fromSql b)) r of+ Just (_,"sequence") -> return "500 unimplemented command\n.\n"+ Just (target,"file") -> putFileOutput lbl format body target+ Nothing -> return $ encodeResponse "32 no such label" ""+ _ -> return $ encodeResponse "1000 unknown error" ""++putFileOutput :: String -> PutFormat -> String -> Integer -> BeinM State String+putFileOutput _lbl format body target = do+ if length (lines body) > 1 || ' ' `elem` body + then return $ encodeResponse "36 invalid file name" "File name cannot contain newlines or spaces"+ else do let [fname] = lines body+ sd <- scratchDir+ filePath <- configField file_repository+ [targetName] <- receiveOneRow $ query "select unique_name(in_repository(''),50)" []+ let targetName' = fromSql targetName+ q <- liftIO $ doesFileExist (joinPath [sd,fname])+ if q + then do liftIO $ (if format == PutNoFormat || format == PutCopy then copyFile else rename) + (joinPath [sd,fname]) (joinPath [filePath,targetName'])+ update "insert into files (id,user_filename,stored_as) values (?,?,?)" [toSql target, toSql fname, toSql targetName']+ return $ encodeResponse "0 ok" ""+ else return $ encodeResponse "35 file does not exist" ""+
+ Bein/Minion/Types.hs view
@@ -0,0 +1,38 @@+module Bein.Minion.Types (+ module Bein.Types,+ State(..), + Settings(..)+) where++import Database.HDBC.PostgreSQL ( Connection )+import Control.Concurrent.STM ( TVar )+import System.Posix.Types ( ProcessID )+import Bein.Types+ ( BeinError(..),+ AuthenticationFailed(..),+ Authentication(..),+ ConfigurationError(..),+ Configuration(..),+ BeinState(..),+ BeinM,+ ExecutionID(..),+ configField,+ unExecutionID,+ errorNumber,+ errorName )++data Settings = Settings { setVerbose :: Bool,+ setScratchDir :: FilePath,+ setExecution :: ExecutionID+ } deriving Show+++data State = State { stDb :: Connection, + stConfigT :: TVar Configuration, + stSettings :: Settings,+ stMinionPid :: TVar (Maybe ProcessID)+ } ++instance BeinState State where+ configT = stConfigT+ db = stDb
+ Bein/ShellScripting.hs view
@@ -0,0 +1,14 @@+module Bein.ShellScripting where++import System.Exit (ExitCode(..))+import System.Process (system)++systemM :: String -> IO ()+systemM cmd = do e <- system cmd+ case e of+ ExitSuccess -> return ()+ ExitFailure v -> fail $ "Command '" ++ cmd ++ + "' exited with code " ++ show v+ +systemM_ :: String -> IO ()+systemM_ cmd = system cmd >> return ()
+ Bein/SocketHandler.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Bein.SocketHandler (listenWith, Authentication(..),getCommandBlock) where++import Data.Typeable ()+import System.Posix.Types ()+import Control.Monad ( forever )+import Foreign.C.Types ()+import System.Posix.Syslog ()+import Control.Monad ()+import Network.Socket+ ( Socket, accept, getPeerCred, socketToHandle )+import Network ( PortID(UnixSocket), listenOn )+import System.Posix.Files ( fileExist, removeLink )+import Text.Printf ()+import System.Posix.User ( getRealUserID )+import Control.Concurrent ( ThreadId )+import Control.Monad.Reader+ ( MonadReader(ask), MonadIO(..), ReaderT(runReaderT) )+import Control.Monad.Trans ()+import Control.Exception ( finally, throwIO )+import System.IO+ ( BufferMode(LineBuffering),+ IOMode(ReadWriteMode),+ hClose,+ hFlush,+ hSetBuffering,+ hPutStr )+import Bein.Types+ ( AuthenticationFailed(..),+ Authentication(..),+ Configuration(authentication),+ BeinState,+ BeinM,+ configField )+import Bein.Commands ( forkR, getCommandBlock )++listenWith :: BeinState s => (String -> BeinM s String) -> FilePath -> BeinM s ()+listenWith f socketFile = do+ s <- liftIO $ ensureFreeSocket socketFile+ forever $ s `accepts` f++accepts :: BeinState s => Socket -> (String -> BeinM s String) -> BeinM s ThreadId+s `accepts` action = (liftIO.accept) s >>= (forkR . withAuthentication (run action) . fst)+ +ensureFreeSocket :: FilePath -> IO Socket+ensureFreeSocket s = do+ fileExist s >>= \exists -> + if exists then removeLink s else return ()+ listenOn (UnixSocket s)++withAuthentication :: BeinState s => (Socket -> BeinM s a) -> Socket -> BeinM s a+withAuthentication f s = do+ authType <- configField authentication+ b <- liftIO $ authenticate authType s+ if b then f s else liftIO $ throwIO AuthenticationFailed++-- authenticateAndRun :: Authentication -> (String -> IO String) -> Socket -> IO ()+-- authenticateAndRun authType f s = do +-- b <- authenticate authType s+-- if b then communicate f s else closeAndFail s+ +authenticate :: Authentication -> Socket -> IO Bool+authenticate None _ = return True+authenticate SameUser s = liftIO $ do uid <- getRealUserID+ (_,otherUid,_) <- getPeerCred s+ return $ toInteger uid == toInteger otherUid+authenticate (OnlyUser uid) s = liftIO $ do (_,otherUid,_) <- getPeerCred s+ return $ toInteger uid == toInteger otherUid+ +run :: BeinState s => (String -> BeinM s String) -> Socket -> BeinM s ()+run f s = do+ st <- ask+ liftIO $ setup (\str -> runReaderT (f str) st)+ where setup g = do h <- socketToHandle s ReadWriteMode+ hSetBuffering h LineBuffering+ (forever $ run' g h) `finally` hClose h+ run' q h = do str <- getCommandBlock h + q str >>= hPutStr h >> hFlush h+
+ Bein/Types.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances #-}+module Bein.Types where++import Data.List ( intercalate )+import System.Posix.Types ( UserID )+import Control.Concurrent.STM ( TVar, atomically, readTVar )+import Control.Monad ()+import Control.Monad.Reader ( ReaderT(..), ask )+import Control.Monad.Trans ( liftIO )+import Control.Exception ( Exception )+import Data.Typeable ( Typeable )+import Database.HDBC ( fromSql, toSql, SqlValue(SqlString) )+import Database.HDBC.PostgreSQL+import Data.Convertible ( Convertible(..), convError )++newtype ExecutionID = ExecutionID Int deriving (Eq,Show,Read)++type BeinM a b = ReaderT a IO b++class BeinState a where+ configT :: a -> TVar Configuration+ db :: a -> Connection++configField :: BeinState s => (Configuration -> a) -> ReaderT s IO a+configField f = ask >>= liftIO.atomically.readTVar.configT >>= return.f++data Configuration = Configuration {+ file_repository :: String,+ scratch_directory :: String,+ static_content_directory :: FilePath,+ perl_executable :: String,+ r_executable :: String,+ max_executions :: Int,+ minion_command :: String, -- "/path/to/minion -d %s -e %d" where %s will be the directory+ -- to work in, and %d the id of the execution to run.+ daemon_port :: String, -- By default /tmp/.s.BEIND+ minion_port :: String, -- By default .s.minion in the execution directory+ http_port :: Int, -- default 8082+ http_base_url :: String,+ template_path :: String,+ authentication :: Authentication+} deriving (Eq,Show,Read)+++instance Convertible SqlValue Authentication where+ safeConvert x = case readsPrec 1 (fromSql x) of+ [] -> convError "Invalid authentication type" x+ [(v,"")] -> return v+ _ -> convError "Read multiple authentication types in string. Make up your mind!" x+ +instance Convertible Authentication SqlValue where+ safeConvert = return . toSql . show++instance Convertible SqlValue ExecutionID where+ safeConvert = return . ExecutionID . fromSql+ +instance Convertible ExecutionID SqlValue where+ safeConvert (ExecutionID x) = return $ toSql x++unExecutionID :: ExecutionID -> Int+unExecutionID (ExecutionID x) = x++instance Convertible [ExecutionID] SqlValue where+ safeConvert xs = let xs' = map (show.unExecutionID) xs+ in return $ SqlString $ "{" ++ intercalate "," xs' ++ "}"++data ConfigurationError = InvalidAuthentication String deriving (Eq,Show,Read,Typeable)++instance Exception ConfigurationError ++data Authentication = None | SameUser | OnlyUser UserID deriving (Eq,Show,Read,Typeable)++data AuthenticationFailed = AuthenticationFailed deriving (Show,Typeable)+instance Exception AuthenticationFailed++data BeinError = NoDatabaseServer String+ | DatabaseAccessError String+ | MissingConfigurationField String+ | NoScratchDirectory String+ | CannotWriteToScratchDirectory String+ | NoFileDirectory String+ | CannotWriteToFileDirectory String+ | MissingFile Int String String -- ID, user_filename, stored_as+ | MinionExecutionFailed String+ | UnknownExecution ExecutionID+ | NoSuchJob ExecutionID+ | FailedToKillJob ExecutionID+ | UnknownCommand String+ deriving (Eq,Show,Read)+ +errorNumber :: BeinError -> Int+errorNumber (NoDatabaseServer _) = 10+errorNumber (DatabaseAccessError _) = 15+errorNumber (MissingConfigurationField _) = 17+errorNumber (NoScratchDirectory _) = 20+errorNumber (CannotWriteToScratchDirectory _) = 25+errorNumber (NoFileDirectory _) = 30+errorNumber (CannotWriteToFileDirectory _) = 35+errorNumber (MissingFile _ _ _) = 36+errorNumber (MinionExecutionFailed _) = 100+errorNumber (UnknownExecution _) = 110+errorNumber (NoSuchJob _) = 120+errorNumber (FailedToKillJob _) = 150+errorNumber (UnknownCommand _) = 200++errorName :: BeinError -> String+errorName (NoDatabaseServer _) = "no database server"+errorName (DatabaseAccessError _) = "database access error"+errorName (MissingConfigurationField _) = "missing configuration field"+errorName (NoScratchDirectory _) = "no scratch directory"+errorName (CannotWriteToScratchDirectory _) = "cannot write to scratch directory"+errorName (NoFileDirectory _) = "no file directory"+errorName (CannotWriteToFileDirectory _) = "cannot write to file directory"+errorName (MissingFile _ _ _) = "missing file"+errorName (MinionExecutionFailed _) = "minion execution failed"+errorName (UnknownExecution _) = "unknown execution"+errorName (NoSuchJob _) = "no such job"+errorName (FailedToKillJob _) = "failed to kill job"+errorName (UnknownCommand _) = "unknown command"
+ Bein/Web/Authentication.hs view
@@ -0,0 +1,56 @@+module Bein.Web.Authentication where++import Bein.Web.Types+import Bein.Web.Commands+import Database.HDBC+import Control.Monad.Reader+import Happstack.Server+import Happstack.Crypto.SHA1++sessionCookie :: String+sessionCookie = "beinsid"++sessionTimeout :: Int+sessionTimeout = 30*60 -- 30 minutes++getSession :: RqData (Maybe String)+getSession = liftM Just (lookCookieValue sessionCookie) `mplus` return Nothing++getRequestUser :: BeinServerPart (Maybe User)+getRequestUser = hostAuthentication `mmplus` cookieAuthentication++hostAuthentication :: BeinServerPart (Maybe User)+hostAuthentication = askRq >>= return . fst . rqPeer >>= \h -> lift $ getUser (WithHost h)++cookieAuthentication :: BeinServerPart (Maybe User)+cookieAuthentication = withDataFn getSession f+ where f Nothing = return Nothing+ f (Just sid) = userOfSession sid++userOfSession :: String -> BeinServerPart (Maybe User)+userOfSession sid = do+ r <- lift $ query "select uid from sessions where key = ?" [toSql sid]+ case (fmap (fromSql.head) . safeHead) r of+ Nothing -> do addCookie 0 (mkCookie sessionCookie "0")+ return Nothing+ Just thisUid -> do lift $ update "select touch_session(?)" [toSql sid]+ addCookie sessionTimeout (mkCookie sessionCookie sid)+ lift $ getUser (WithUid thisUid)++ensureSession :: BeinServerPart a -> BeinServerPart a -> (String,String) -> BeinServerPart a+ensureSession onFail onSucceed (givenUsername,givenPassword) = lift (getUser (WithUserName givenUsername)) >>= \u -> case u of + Nothing -> onFail+ Just user -> if authType user == Password (sha1 givenPassword)+ then do sid <- liftM (fromSql.head.head) $ lift $ updateWithResponse "select new_session(?)" [toSql (uid user)]+ addCookie sessionTimeout (mkCookie sessionCookie sid)+ onSucceed `withUser` user+ else do onFail++++clearSession :: BeinServerPart ()+clearSession = withDataFn getSession logOut'+ where logOut' c = do addCookie 0 (mkCookie sessionCookie "0")+ lift $ update "delete from sessions where key = ?" [toSql c]+ setHeaderM "Content-Type" "text/html; charset=utf-8"+
+ Bein/Web/Commands.hs view
@@ -0,0 +1,7 @@+module Bein.Web.Commands (+ module Bein.Commands,+ module Bein.Web.Commands.Local+) where ++import Bein.Commands+import Bein.Web.Commands.Local
+ Bein/Web/Commands/Local.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards, FlexibleContexts #-}+module Bein.Web.Commands.Local where++import Data.List (find)+import Data.Convertible+import Happstack.Server+import System.FilePath (joinPath)+import Bein.Web.Types+import Bein.Commands+import Database.HDBC+import Control.Monad.Reader+import Data.Maybe+import Data.Monoid+import qualified Data.Map as M+import Text.XHtml hiding (label,script,dir)++mmplus :: (Monad m, MonadPlus q) => m (q a) -> m (q a) -> m (q a)+mmplus = liftM2 mplus++mmappend :: (Monad m, Monoid a) => m a -> m a -> m a+mmappend = liftM2 mappend+ +safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x++getPostPair :: BeinServerPart Response -> BeinServerPart Response -> BeinServerPart Response+getPostPair getr postr = mconcat [ methodOnly GET >> getr,+ methodOnly POST >> postr ]++exactDir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a+exactDir partPath act = dir partPath $ baseDir $ act++baseDir :: (ServerMonad m, MonadPlus m) => m a -> m a+baseDir act = nullDir >> act++maybeM :: MonadPlus m => (a -> m b) -> Maybe a -> m b+maybeM _ Nothing = mzero+maybeM f (Just x) = f x++liftT :: (MonadTrans t, Monad m) => (a -> m b) -> (a -> t m b)+liftT f = \o -> lift (f o)++guardObject :: BeinServerPart a -> BeinServerPart a+guardObject r = path (\oid -> return oid >>= liftT getObject >>= maybeM (r `withObject`))++withObject :: BeinServerPart a -> BeinObject -> BeinServerPart a+withObject r o = local (\st -> st { stObject = o }) r++joinURL :: String -> String -> String+joinURL "" b = b+joinURL a "" = a+joinURL a ('/':b) = joinPath [a,appendSlash b]+joinURL a b = joinPath [a,appendSlash b]+ +appendSlash :: String -> String+appendSlash "" = ""+appendSlash x = if last x /= '/' then x ++ "/" else x++(<>) :: (Monad m, Monoid a) => m a -> m a -> m a+(<>) = liftM2 mappend++infixl 4 <>+++ +(|>>=|) :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)+x |>>=| f = x >>= \r -> case r of+ Nothing -> return Nothing+ Just v -> f v+ +infixl 1 |>>=|++(|>>|) :: Monad m => m (Maybe a) -> m (Maybe b) -> m (Maybe b)+x |>>| y = x >>= \r -> case r of+ Nothing -> return Nothing+ Just _ -> y+ +infixl 1 |>>|++getGroup :: BeinState s => GroupQuery -> BeinM s (Maybe Group)+getGroup (WithGid g) = maybeRowQuery "select name from groups where gid=?" [toSql g] |>>=| + \[grname] -> return $ Just $ Group { gid = g, groupName = fromSql grname }+getGroup (WithGroupName g) = maybeRowQuery "select gid from groups where name=?" [toSql g] |>>=| + \[r] -> return $ Just $ Group { gid = fromSql r, groupName = g }+ +getUser :: BeinState s => UserQuery -> BeinM s (Maybe User)+getUser cond = do q cond >>= \r -> case r of + [] -> return Nothing+ [rUser@(rUid:_)] -> do g <- getGroupMembership (fromSql rUid)+ return $ Just $ readUser rUser g+ _ -> error "Database returned more than one user to getUser query."+ where q (WithUid u) = query (queryString ++ "uid = ?") [toSql u]+ q (WithUserName s) = query (queryString ++ "name = ?") [toSql s]+ q (WithHost h) = query (queryString ++ "auth_type='host' and auth_secret=?") [toSql h]+ queryString = "select uid,name,default_gr,default_gw,default_wr,default_ww,default_group," ++ + "administrator,auth_type,auth_secret from users where "+ readUser [rUid,rName,rGR,rGW,rWR,rWW,rGroup,rAdmin,rAuthType,rAuthSecret] g =+ case find (\thisg -> gid thisg == fromSql rGroup) g of+ Nothing -> error "Failed to get default group; not among groups user is a member of."+ Just dg ->+ User { uid = fromSql rUid,+ groups = g,+ userName = fromSql rName,+ defaultGR = fromSql rGR,+ defaultGW = fromSql rGW,+ defaultWR = fromSql rWR,+ defaultWW = fromSql rWW,+ defaultGroup = dg,+ isAdministrator = fromSql rAdmin,+ authType = case fromSql rAuthType of+ "password" -> Password (fromSql rAuthSecret)+ "host" -> Host (fromSql rAuthSecret) + "nologin" -> NoLogin+ _ -> error "Invalid authentication type."+ }+ readUser _ _ = error "Invalid arguments to readUser."+++getGroupMembership :: BeinState s => Int -> BeinM s [Group] +getGroupMembership thisUid = query q [toSql thisUid] >>= return.(map readGroup)+ where q = "select g.gid,g.name from groups as g inner join group_members as m on g.gid=m.gid where m.uid=?"+ readGroup [rGid,rName] = Group { gid = fromSql rGid, groupName = fromSql rName }+ readGroup _ = error "Invalid arguments to readGroup."+++getObject :: BeinState s => Int -> BeinM s (Maybe BeinObject)+getObject idToFind = do+ maybeRowQuery "select label,notes,uid,gid,gr,gw,wr,ww,created,last_modified,type,immutable(id) from headers where id=?" [toSql idToFind] |>>=|+ \[rLabel,rNotes,rUid,rGid,rGr,rGw,rWr,rWw,rCreated,rLastModified,rType,rImm] -> do+ Just o <- getUser (WithUid (fromSql rUid))+ Just r <- getGroup (WithGid (fromSql rGid))+ let h = ObjectHeader { label = fromSql rLabel,+ notes = fromSql rNotes,+ owner = o,+ group = r,+ gr = fromSql rGr,+ gw = fromSql rGw,+ wr = fromSql rWr,+ ww = fromSql rWw,+ created = fromSql rCreated,+ lastModified = fromSql rLastModified, + objType = case fromSql rType of+ "file" -> File+ "execution" -> Execution+ "program" -> Program+ v -> error ("Invalid type for object: " ++ v),+ immutable = fromSql rImm+ }+ b <- case fromSql rType of+ "file" -> getFileBody idToFind+ "execution" -> getExecutionBody idToFind+ "program" -> getProgramBody idToFind+ "sequence" -> error "Sequence type not implemented yet."+ _ -> error "Found invalid type in database."+ return $ Just $ BeinObject { objId = idToFind, objHeader = h, objBody = b }+ + +getFileBody :: BeinState s => Int -> BeinM s (Maybe ObjectBody)+getFileBody idToFind = + maybeRowQuery "select user_filename,in_repository(stored_as),content_type from files where id=?" [toSql idToFind] |>>=|+ \[rUserFilename,rStoredAs,rContType] -> return $ Just $ FileBody { userFilename = fromSql rUserFilename, storedAs = fromSql rStoredAs, + contentType = fromSql rContType }+ + +getExecutionBody :: BeinState s => Int -> BeinM s (Maybe ObjectBody)+getExecutionBody idToFind = + maybeRowQuery "select program,status,failed_dependency from executions where id=?" [toSql idToFind] |>>=|+ \[rProgram,rStatus,rFailedDep] -> do + rInputs <- query "select label,type from execution_inputs where id=?" [toSql idToFind]+ inputs <- liftM M.fromList $ mapM mkInput rInputs+ rOutputs <- query "select label,target,type from execution_outputs where id=?" [toSql idToFind]+ outputs <- liftM M.fromList $ mapM mkOutput rOutputs+ logs <- liftM (map mkLog) $ + query "select log_time,log_message from execution_logs where id=?" [toSql idToFind]+ Just resSpec <- getResourceSpec idToFind+ pr <- return (maybeFromSql rProgram) |>>=| getObject+ return $ Just $ ExecutionBody { resourceSpec = resSpec,+ program = pr,+ status = mkStatus (fromSql rStatus) rFailedDep,+ executionInputs = inputs,+ executionOutputs = outputs,+ executionLog = logs }+ where mkLog [d,v] = (fromSql d, fromSql v)+ mkLog _ = error "Invalid arguments to mkLog."+ mkInput :: BeinState s => [SqlValue] -> BeinM s (String,ExecutionInput)+ mkInput [rLabel,rType] = case fromSql rType of+ "string" -> do + s <- liftM (head.head) $ + query "select value from execution_string_inputs where id=? and label=?" [toSql idToFind, rLabel]+ return $ (fromSql rLabel, ExecutionStringInput $ maybeFromSql s)+ "number" -> do + s <- liftM (head.head) $ + query "select value from execution_number_inputs where id=? and label=?" [toSql idToFind, rLabel]+ return $ (fromSql rLabel, ExecutionNumberInput $ maybeFromSql s)+ "file" -> + do [s] <- liftM head $+ query "select value from execution_object_inputs where id=? and label=?" [toSql idToFind, rLabel]+ if s == SqlNull then return (fromSql rLabel, ExecutionObjectInput Nothing)+ else getObject (fromSql s) >>= \obj -> return (fromSql rLabel, + ExecutionObjectInput obj)+ v -> error $ "Received invalid execution input type from database: " ++ v + mkInput _ = error "Invalid arguments to mkInput."+ mkOutput [rLabel,rTarget,_rType] = getObject (fromSql rTarget) >>= \(Just o) -> return (fromSql rLabel, ExecutionFileOutput o)+ mkOutput _ = error "Received invalid execution output from database."+ mkStatus "waiting" _ = Waiting+ mkStatus "running" _ = Running+ mkStatus "complete" _ = Complete+ mkStatus "failed" _ = Failed+ mkStatus "dependency_failed" v = DependencyFailed (fromSql v)+ mkStatus _ _ = error "Invalid status value."+ ++getProgramBody :: BeinState s => Int -> BeinM s (Maybe ObjectBody)+getProgramBody idToFind = do+ maybeRowQuery "select language,script from programs where id=?" [toSql idToFind] |>>=|+ \[rLang,rScript] -> do+ let prlang = if fromSql rLang == "perl" then Perl else R+ scr = fromSql rScript+ inputs <- liftM (M.fromList . (map mkInput)) $ query "select label,type from program_inputs where id=?" [toSql idToFind]+ outputs <- liftM (M.fromList . (map mkOutput)) $ query "select label,type from program_outputs where id=?" [toSql idToFind]+ Just resSpec <- getResourceSpec idToFind+ return $ Just $ ProgramBody { language = prlang, script = scr,+ programInputs = inputs, programOutputs = outputs,+ resourceSpec = resSpec }+ where mkInput [rlbl,rtype] = (fromSql rlbl, + case fromSql rtype of+ "sequence" -> InputSequence+ "file" -> InputFile+ "number" -> InputNumber+ "string" -> InputString+ _ -> error "mkInput called on invalid type.")+ mkInput _ = error "mkInput called with invalid arguments."+ mkOutput [rlbl,_rtype] = (fromSql rlbl, OutputFile)+ mkOutput _ = error "mkOutput called with invalid arguments."++getResourceSpec :: BeinState s => Int -> BeinM s (Maybe ResourceSpec)+getResourceSpec o = do+ maybeRowQuery "select resreq,maxcpu,maxfilesize,maxram,maxswap,maxprocs from resource_specification where id=?" [toSql o] |>>=|+ \[rResreq,rMaxcpu,rMaxfilesize,rMaxram,rMaxswap,rMaxprocs] ->+ return $ Just $ ResourceSpec { resReq = fromSql rResreq,+ maxCpu = maybeFromSql rMaxcpu,+ maxFileSize = maybeFromSql rMaxfilesize,+ maxRam = maybeFromSql rMaxram,+ maxSwap = maybeFromSql rMaxswap,+ maxProcs = maybeFromSql rMaxprocs }+ +maybeFromSql :: Convertible SqlValue a => SqlValue -> Maybe a+maybeFromSql SqlNull = Nothing+maybeFromSql v = Just $ fromSql v++getObjects :: BeinState s => User -> Maybe Int -> Maybe Int -> BeinM s [BeinObject]+getObjects user offset limit = do+ ids <- liftM (map (fromSql.head)) $ query q [toSql (uid user), toSql (fromMaybe 25 limit), toSql (fromMaybe 0 offset)]+ mapM (liftM fromJust . getObject) ids+ where q = "select id from headers where uid=? or array[gid] <@ array" ++ + (show $ map gid $ groups user) ++ " order by last_modified desc limit ? offset ?"+ +objectTag :: BeinObject -> String+objectTag obj = show (objId obj) ++ " " ++ (if label (objHeader obj) == "" then "(no label)" else "'" ++ label (objHeader obj) ++ "'")+ +-- getField :: ServerMonad m => String -> m (Maybe String)+-- getField f = getDataFn (look f)++-- maybeGetField :: ServerMonad m => String -> String -> m String+-- maybeGetField f def = liftM (maybe def id) $ getDataFn (look f)++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+ [(v,"")] -> Just v+ _ -> Nothing+ +redir :: String -> BeinServerPart Response+redir targetUrl = lift (configField http_base_url) >>= \baseUrl -> seeOther (joinURL baseUrl targetUrl) (toResponse "Redirecting...")++lookCheckbox :: String -> RqData Bool+lookCheckbox boxName = do inputs <- asks fst+ case lookup boxName inputs of+ Nothing -> return False+ Just _ -> return True+ +lookSubmit :: String -> RqData Bool+lookSubmit submitName = do inputs <- asks fst+ case lookup submitName inputs of+ Nothing -> return False+ Just _ -> return True + +maskEmpty :: String -> String -> String+maskEmpty def "" = def+maskEmpty _ s = s+++asksUser :: BeinServerPart User+asksUser = asks stUser >>= \u -> case u of+ Just user -> return user+ Nothing -> error "asksUser: Error: no user currently defined."++withUser :: BeinServerPart a -> User -> BeinServerPart a+withUser act user = local (\st -> st { stUser = Just user }) act++asksBaseUrl :: BeinServerPart URL+asksBaseUrl = lift $ configField http_base_url >>= \b -> return $ if b == "" then "/" else b++fullUrl :: URL -> BeinServerPart URL+fullUrl b' = do+ b <- asksBaseUrl+ return $ joinURL b b'++asksObject :: BeinServerPart BeinObject+asksObject = asks stObject++setUTF8 :: Monad m => ServerPartT m ()+setUTF8 = setHeaderM "Content-Type" "text/html; charset=utf-8"++userAtBein :: User -> String+userAtBein user = (userName user) ++ "@Bein"+++guard2 :: c -> c -> (a -> b -> c) -> Maybe a -> Maybe b -> c+guard2 x0 _ _ Nothing _ = x0+guard2 _ y0 _ _ Nothing = y0+guard2 _ _ f (Just x) (Just y) = f x y+
+ Bein/Web/Elements.hs view
@@ -0,0 +1,62 @@+module Bein.Web.Elements (+ module Bein.Web.Elements.Tags,+ module Bein.Web.Elements.Base,+ module Bein.Web.Elements.Attributes,+ module Text.XHtml +) where++import Text.XHtml (+ Html,+ HTML(..),+ renderHtml,+ action,+ align,+ alt,+ altcode,+ archive,+ base,+ border,+ bordercolor,+ cellpadding,+ cellspacing,+ checked,+ codebase,+ cols,+ colspan,+ content,+ coords,+ disabled,+ enctype,+ height,+ href,+ hreflang,+ httpequiv,+ identifier,+ ismap,+ lang,+ maxlength,+ method,+ multiple,+ name,+ nohref,+ rel,+ rev,+ rows,+ rowspan,+ rules,+ selected,+ shape,+ size,+ src,+ theclass,+ thefor,+ thestyle,+ thetype,+ title,+ usemap,+ valign,+ value,+ width)+import Bein.Web.Elements.Base+import Bein.Web.Elements.Tags+import Bein.Web.Elements.Attributes
+ Bein/Web/Elements/Attributes.hs view
@@ -0,0 +1,6 @@+module Bein.Web.Elements.Attributes where++import Text.XHtml++for :: String -> HtmlAttr+for = strAttr "for"
+ Bein/Web/Elements/Base.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}+module Bein.Web.Elements.Base where++import Data.Monoid+import qualified Text.XHtml as X+import Text.XHtml ((!),HTML,Html,HtmlAttr,ADDATTRS)+import Control.Monad++(<!>) :: (ADDATTRS a, Monad m) => m a -> [HtmlAttr] -> m a+t <!> a = liftM (!a) t++(<!) :: (ADDATTRS a, Monad m) => (b -> m a) -> [HtmlAttr] -> (b -> m a)+t <! a = \x -> t x <!> a++(=<<:) :: Monad m => TagM -> [m Html] -> m Html+f =<<: gs = f =<< mconcatM gs++infixr 1 =<<:++(<<) :: (Monad m, HTML a) => TagM -> a -> m Html+t << v = t =<< html v++infixr 7 <<++type TagM = Monad m => Html -> m Html+type ITagM = Monad m => m Html ++html :: (Monad m, HTML a) => a -> m Html+html = return . X.toHtml++noHtmlM :: Monad m => m Html+noHtmlM = return X.noHtml++noHtml :: Html+noHtml = X.noHtml++mconcatM :: (Monad m, Monoid a) => [m a] -> m a+mconcatM [] = return mempty+mconcatM (x:xs) = do+ v <- x+ vs <- mconcatM xs+ return (v `mappend` vs)
+ Bein/Web/Elements/Tags.hs view
@@ -0,0 +1,187 @@+module Bein.Web.Elements.Tags where++import Bein.Web.Elements.Base+import Text.XHtml++abbrM :: TagM+acronymM :: TagM+addressM :: TagM+anchorM :: TagM+areaM :: ITagM+bdoM :: TagM+bigM :: TagM+blockquoteM :: TagM+bodyM :: TagM+boldM :: TagM+brM :: ITagM+buttonM :: TagM+captionM :: TagM+citeM :: TagM+colM :: TagM+colgroupM :: TagM+delM :: TagM+ddefM :: TagM+defineM :: TagM+dlistM :: TagM+dtermM :: TagM+emphasizeM :: TagM+fieldsetM :: TagM+formM :: TagM+h1M :: TagM+h2M :: TagM+h3M :: TagM+h4M :: TagM+h5M :: TagM+h6M :: TagM+headerM :: TagM+hrM :: ITagM+imageM :: ITagM+inputM :: ITagM+insM :: TagM+italicsM :: TagM+keyboardM :: TagM+labelM :: TagM+legendM :: TagM+liM :: TagM+linkM :: ITagM+metaM :: ITagM+noscriptM :: TagM+objectM :: TagM+olistM :: TagM+optgroupM :: TagM+optionM :: TagM+paragraphM :: TagM+paramM :: ITagM+preM :: TagM+quoteM :: TagM+sampleM :: TagM+scriptM :: TagM+selectM :: TagM+smallM :: TagM+strongM :: TagM+styleM :: TagM+subM :: TagM+supM :: TagM+tableM :: TagM+tbodyM :: TagM+tdM :: TagM+textareaM :: TagM+tfootM :: TagM+thM :: TagM+theadM :: TagM+thebaseM :: ITagM+thecodeM :: TagM+thedivM :: TagM+thehtmlM :: TagM+thelinkM :: TagM+themapM :: TagM+thespanM :: TagM+thetitleM :: TagM+trM :: TagM+ttM :: TagM+ulistM :: TagM+variableM :: TagM++abbrM = return . abbr+acronymM = return . acronym+addressM = return . address+anchorM = return . anchor+areaM = return area+bdoM = return . bdo+bigM = return . big+blockquoteM = return . blockquote+bodyM = return . body+boldM = return . bold+buttonM = return . button+brM = return br+captionM = return . caption+citeM = return . cite+colM = return . col+colgroupM = return . colgroup+ddefM = return . ddef+defineM = return . define+delM = return . del+dlistM = return . dlist+dtermM = return . dterm+emphasizeM = return . emphasize+fieldsetM = return . fieldset+formM = return . form+h1M = return . h1+h2M = return . h2+h3M = return . h3+h4M = return . h4+h5M = return . h5+h6M = return . h6+headerM = return . header+hrM = return hr+imageM = return image+inputM = return input+insM = return . ins+italicsM = return . italics+keyboardM = return . keyboard+labelM = return . label+legendM = return . legend+liM = return . li+linkM = return (itag "link")+metaM = return meta+noscriptM = return . noscript+objectM = return . object+olistM = return . olist+optgroupM = return . optgroup+optionM = return . option+paragraphM = return . paragraph+paramM = return param+preM = return . pre+quoteM = return . quote+sampleM = return . sample+scriptM = return . script+selectM = return . select+smallM = return . small+strongM = return . strong+styleM = return . style+subM = return . sub+supM = return . sup+tableM = return . table+tbodyM = return . tbody+tdM = return . td+textareaM = return . textarea+tfootM = return . tfoot+thM = return . th+theadM = return . thead+thebaseM = return thebase+thecodeM = return . thecode+thedivM = return . thediv+thehtmlM = return . thehtml+thelinkM = return . thelink+themapM = return . themap+thespanM = return . thespan+thetitleM = return . thetitle+trM = return . tr+ttM = return . tt+ulistM = return . ulist+variableM = return . variable++widgetM :: String -> String -> [HtmlAttr] -> ITagM+widgetM w n markupAttrs = inputM <!> ([thetype w] ++ ns ++ markupAttrs)+ where ns = if null n then [] else [name n,identifier n]++checkboxM :: String -> String -> Bool -> ITagM+hiddenM :: String -> String -> ITagM+radioM :: String -> String -> ITagM+resetM :: String -> String -> ITagM+submitM :: String -> String -> ITagM+passwordM :: String -> ITagM+textfieldM :: String -> ITagM+afileM :: String -> ITagM+clickmapM :: String -> ITagM+++checkboxM n v ch = widgetM "checkbox" n ([value v] ++ if ch then [checked] else [])+hiddenM n v = widgetM "hidden" n [value v]+radioM n v = widgetM "radio" n [value v]+resetM n v = widgetM "reset" n [value v]+submitM n v = widgetM "submit" n [value v]+passwordM n = widgetM "password" n []+textfieldM n = widgetM "text" n []+afileM n = widgetM "file" n []+clickmapM n = widgetM "image" n []
+ Bein/Web/Pages/Common.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Bein.Web.Pages.Common where++import Database.HDBC+import Bein.Web.Elements +import Bein.Web.Commands+import Bein.Web.Types+import Data.Monoid+import Control.Monad.Reader+import Control.Monad.Writer+import Happstack.Server as S hiding (method)+import qualified Text.XHtml as X+import Text.XHtml ((!))++data HideHeaderLink = HideHome | HideSettings | HideNone deriving (Eq,Show,Read)++-- | @page@ is the skeleton for all pages in Bein. +page :: Maybe String -- ^ 'Nothing' for no title beyond "user@Bein"; 'Just "subtitle"' to add a subtitle.+ -> HideHeaderLink -- ^ which, if any, of the header links at the top right of the page to hide.+ -> (a -> BeinFormPart a Html) -- ^ The body of the page. Should take a value to plug into + -- the page, such as for messages after operations.+ -> a -- ^ The value to plug into the body+ -> BeinServerPart Response+page ptitle hideLink pageBody plug = do+ setUTF8+ (b,posts) <- runWriterT (pageBody plug)+ h <- mconcatM [ pageHeader ptitle,+ bodyM =<<: [ headerLinks hideLink, bodyTitle ptitle, thedivM <! [theclass "main-panel"] $ b ],+ pageFooter ]+ mconcat ((nullDir >> (ok $ toResponse $ renderHtml h)) :+ map (\(postDir,postMonad) -> methodOnly POST >> dir postDir (postMonad >>= handlePost)) posts)+ where handlePost (ContinuePage v) = page ptitle hideLink pageBody v+ handlePost (ContinuePageWithWrapper v wrp) = wrp $ page ptitle hideLink pageBody v+ handlePost (NewResponse r) = return r+ handlePost (RedirectTo s) = seeOther s (toResponse "Redirecting...")++bodyTitle :: Maybe String -> BeinServerPart Html+bodyTitle Nothing = asks stUser >>= \user -> h1M << maybe "" userAtBein user+bodyTitle (Just s) = asks stUser >>= \user -> h1M <! [theclass "title-with-subtitle"] << maybe "" userAtBein user <>+ h1M <! [theclass "subtitle"] << s+ +pageHeader :: Maybe String -> BeinServerPart Html+pageHeader ptitle = do+ stylesheetUrl <- fullUrl "/default.css"+-- scriptUrl <- fullUrl "/script.js"+-- jqueryUrl <- fullUrl "/jquery.js"+ fullTitle <- asks stUser >>= \user -> return $ maybe "" userAtBein user ++ maybe "" (\t -> " - " ++ t) ptitle+ headerM =<<: [+ thetitleM << fullTitle,+ linkM <!> [rel "stylesheet", href stylesheetUrl, thetype "text/css"],+-- scriptM <! [thetype "text/javascript", src jqueryUrl] $ noHtml,+-- scriptM <! [thetype "text/javascript", src scriptUrl] $ noHtml,+ metaM <!> [httpequiv "Content-Type", content "text/html; charset=utf-8"]+ ]++headerLinks :: HideHeaderLink -> BeinServerPart Html+headerLinks toHide = paragraphM <! [identifier "header-links"] =<<: [ + (if toHide /= HideHome then home <> html " | " else noHtmlM),+ (if toHide /= HideSettings then settings <> html " | " else noHtmlM),+ signOut ]+ where linkTemplate target txt = fullUrl target >>= \t -> anchorM <! [href t] << txt+ home = linkTemplate "/" "Home"+ settings = linkTemplate "/settings" "Settings"+ signOut = linkTemplate "/signout" "Sign Out"+++pageFooter :: BeinServerPart Html+pageFooter = thedivM <! [identifier "footer"] =<< paragraphM =<<: [+ html "Bein may eat your data.", brM, + html "Bein may launch nuclear missiles at Guam.", brM,+ html "We like to think this is unlikely.", brM,+ html "Contact its creator at ", ttM << "fred dot ross at epfl dot ch" ]++-- Body elements++objUrl :: String -> BeinServerPart String+objUrl p = do + obj <- asksObject+ fullUrl $ show (objId obj) ++ "/" ++ p++objectFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html+objectFormTo url handler frm = do+ obj <- lift $ asksObject+ u <- lift $ fullUrl $ (show (objId obj) ++ "/" ++ case url of "" -> ""; '/':r -> r; r -> r)+ tell [(url,handler)]+ formM <! [method "post", action u] $ frm++formTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html+formTo url handler frm = do+ tell [(url, handler)]+ formM <! [method "post", action url] $ frm++multipartFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html+multipartFormTo url handler frm = do+ tell [(url, handler)]+ formM <! [method "post", action url, enctype "multipart/form-data"] $ frm+++alignedLabelM :: (HTML a, Monad m) => a -> m Html+alignedLabelM txt = thespanM <! [theclass "inline-label"] << txt++redParagraph :: HTML a => a -> Html+redParagraph txt = X.paragraph ! [thestyle "text-align: center; color: red; font-weight: bold;"] X.<< txt++greenParagraph :: HTML a => a -> Html+greenParagraph txt = X.paragraph ! [thestyle "text-align: center; color: green; font-weight: bold;"] X.<< txt++formatPermissions :: Bool -> Bool -> Bool -> Bool -> String+formatPermissions pgr pgw pwr pww = formatHalf pgr pgw ++ "/" + ++ formatHalf pwr pww+ where formatHalf False False = "--"+ formatHalf False True = "w"+ formatHalf True False = "r"+ formatHalf True True = "rw"++groupBox :: Monad m => String -> [Group] -> Group -> m Html+groupBox ident gs currentGroup = selectM <! [identifier ident, name ident] =<<: map groupToOption gs+ where groupToOption g = optionM <! attrs g << groupName g+ attrs g = [value (show $ gid g)] ++ if currentGroup == g then [selected] else []+++-- checkField :: HTML a => String -> a -> Bool -> Html+-- checkField identifier displayName isChecked = X.label $ checkbox identifier "True" ! (if isChecked then [checked] else []) <> toHtml displayName++-- groupBox :: String -> [Group] -> Group -> Html+-- groupBox ident groups currentGroup = select ! [identifier ident, name ident] $ mconcat $ map groupToOption groups+-- where groupToOption g = option ! attrs g << groupName g+-- attrs g = if currentGroup == g then [value (show $ gid g), selected] else [value (show $ gid g)]++-- formTo :: URL -> URL -> Html -> Html+-- formTo baseUrl to = form ! [X.method "post", action (joinURL baseUrl to)]+ +-- permissionBoxes :: Bool -> Bool -> Bool -> Bool -> Html+-- permissionBoxes gr gw wr ww = mconcat [+-- toHtml "Group can ", checkField "defaultgr" "Read" gr, toHtml " ", +-- checkField "defaultgw" "Write" gw, toHtml " / ",+-- toHtml "World can ", checkField "defaultwr" "Read" wr, toHtml " ",+-- checkField "defaultww" "Write" ww ]+ +-- buttonTo :: URL -> URL -> String -> Html+-- buttonTo baseUrl url txt = form ! [X.method "post", action (joinURL baseUrl url)] $ submit txt txt++ +-- formHtml :: X.HTML a => a -> BeinForm ()+-- formHtml = xml . toHtml++-- lookInputs :: RqData Env+-- lookInputs = do+-- inps <- asks fst+-- return $ map toFileOrField inps+-- where toFileOrField (n,i) | inputFilename i == Nothing = (n, Left $ toString (inputValue i))+-- | otherwise = (n, Right (Text.Formlets.File { content = inputValue i, fileName = (fromJust (inputFilename i)), +-- contentType = convertContentType (inputContentType i) }))+-- convertContentType ct = F.ContentType { F.ctType = S.ctType ct, F.ctSubtype = S.ctSubtype ct, F.ctParameters = S.ctParameters ct }+++-- formlet :: String -> BeinForm b -> (b -> BeinM WebState (Either [String] ())) -> RereadOnUpdate -> BeinFormPart Html+-- formlet postDir frm successAction updatePolicy = do+-- let (extractor, xml, endState) = runFormState [] frm+-- tell [(postDir, response)]+-- return $ form ! [X.method "POST", action postDir] << (xml +++ X.submit "save" "Save")+-- where response :: BeinServerPart Response+-- response = methodOnly POST >> (authenticated $ withDataFn lookInputs $ \x -> do+-- let (extractor,_,_) = runFormState x frm+-- lift extractor >>= \v -> case v of+-- Failure errs -> asks stPage >>= \f -> f (mconcat $ map redParagraph errs)+-- Success s -> lift (successAction s) >>= \r -> case r of+-- Left errs -> asks stPage >>= \f -> updateState updatePolicy $ f (mconcat $ map redParagraph errs)+-- Right () -> asks stPage >>= \f -> updateState updatePolicy $ f (greenParagraph "Succeeded."))++-- updateState :: RereadOnUpdate -> BeinServerPart m -> BeinServerPart m+-- updateState NoReread r = r+-- updateState RereadUser r = asks stUser >>= \u -> case u of+-- Nothing -> r+-- Just user -> lift (getUser (WithUid (uid user))) >>= \newUser -> local (\st -> st { stUser = newUser }) r+-- updateState RereadObject r = asksObject >>= \o -> lift (getObject (objId o)) >>= \(Just newObj) -> local (\st -> st { stObject = newObj }) r+-- updateState RereadUserAndObject r = updateState RereadUser (updateState RereadObject r)++rereadUser :: BeinServerPart Response -> BeinServerPart Response+rereadUser r = asks stUser >>= \u -> case u of+ Nothing -> r+ Just user -> lift (getUser (WithUid (uid user))) >>= \newUser -> local (\st -> st { stUser = newUser }) r+ +rereadObject :: BeinServerPart Response -> BeinServerPart Response+rereadObject r = asksObject >>= \o -> lift (getObject (objId o)) >>= \(Just newObj) -> local (\st -> st { stObject = newObj }) r++hasPermissions :: String -> String -> BeinServerPart ()+hasPermissions groupTerm worldTerm = do+ user <- asksUser+ obj <- asksObject+ let q = "select id from headers where id = ? and (uid=? or (" ++ groupTerm ++ " = true and array[gid] <@ array" ++ + (show $ map gid $ groups user) ++ ") or " ++ worldTerm ++ " = true)"+ lift $ maybeRowQuery q [toSql (objId obj), toSql (uid user)] >>= \r -> case r of+ Nothing -> mzero+ Just _ -> return ()++hasReadPermissions :: BeinServerPart ()+hasReadPermissions = hasPermissions "gr" "wr"++hasWritePermissions :: BeinServerPart ()+hasWritePermissions = hasPermissions "gw" "ww"
+ Bein/Web/Pages/Index.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Bein.Web.Pages.Index where++import Bein.Web.Elements+import Bein.Web.Types+import Bein.Web.Pages.Common+import Data.Time+import System.Locale+import Bein.Web.Commands+import Happstack.Server+import Control.Monad.Trans+import qualified Data.Map as M+import Data.List (intersperse)+import Bein.Web.Pages.Login++index :: BeinServerPart Response+index = authenticated $ page Nothing HideHome (const $ lift $ indexHeader <> objectList) ()++indexHeader :: BeinServerPart Html+indexHeader = thedivM <! [identifier "object-list-header"] =<<: [+ paragraphM <! [identifier "object-list-new-line"] =<<: [+ headerAnchor "new/execution" "New Execution",+ headerAnchor "new/program" "New Program",+ headerAnchor "new/file" "New File" ]]+ where headerAnchor :: HTML a => String -> a -> BeinServerPart Html+ headerAnchor hr txt = fullUrl hr >>= \u -> anchorM <! [href u] =<< html txt+ +objectList :: BeinServerPart Html+objectList = do+ st :: Maybe Int <- getDataFn $ lookRead "start"+ cn :: Maybe Int <- getDataFn $ lookRead "display"+ user <- asksUser+ objs <- lift $ getObjects user st cn+ thedivM <! [identifier "object-list"] =<<: map compactDisplay objs++compactDisplay :: BeinObject -> BeinServerPart Html+compactDisplay obj = thedivM <! [theclass "compact"] =<< leftPane obj <> rightPane obj+ +leftPane :: BeinObject -> BeinServerPart Html+leftPane obj = do+ displayUrl <- fullUrl ("/" ++ show (objId obj))+ editUrl <- fullUrl ("/" ++ show (objId obj) ++ "/edit")+ let h = objHeader obj+ thedivM <! [theclass "left"] =<<: [ + paragraphM <! [theclass "title"] =<< anchorM <! [href displayUrl] << objectTag obj,+ paragraphM << (userName (owner h) ++ "/" ++ groupName (group h) ++ " " ++ formatPermissions (gr h) (gw h) (wr h) (ww h)),+ paragraphM << ("Last modified " ++ formatTime defaultTimeLocale "%F %R" (lastModified h)),+ paragraphM << ("Created " ++ formatTime defaultTimeLocale "%F %R" (created h)), + paragraphM =<< anchorM <! [href editUrl] << "Edit" ]+ +rightPane :: BeinObject -> BeinServerPart Html+rightPane obj = thedivM <! [theclass "right"] =<<: [+ paragraphM <! [theclass "notes"] << (notes $ objHeader obj),+ compactBody obj ]++compactBody :: BeinObject -> BeinServerPart Html+compactBody obj = case objBody obj of+ Nothing -> paragraphM << ("Future of type " ++ show (objType (objHeader obj)))+ Just f@FileBody{} -> paragraphM << ("File " ++ userFilename f)+ Just p@ProgramBody{} -> mconcatM [+ paragraphM << (show (language p) ++ " script beginning:"),+ preM << (take 300 (script p) ++ "..."),+ paragraphM =<< strongM << "Inputs: " <> brM <> mconcatM (intersperse brM (map (html . showInput) $ M.toList (programInputs p))),+ paragraphM =<< strongM << "Outputs: " <> brM <> mconcatM (intersperse brM (map (html . ("file "++)) $ M.keys (programOutputs p))) ]+ where showInput (k,v) = case v of+ InputSequence -> "sequence " ++ k+ InputFile -> "file " ++ k+ InputString -> "string " ++ k+ InputNumber -> "number " ++ k+ Just x@ExecutionBody{} -> mconcatM [ + paragraphM << showStatus (status x) (program x),+ paragraphM =<< strongM << "Inputs: " <> brM <> mconcatM (intersperse brM (map (html . showInput) $ M.toList (executionInputs x))),+ paragraphM =<< strongM << "Outputs: " <> brM <> mconcatM (intersperse brM (map (html . showOutput) $ M.toList (executionOutputs x))) ]+ where showStatus _ Nothing = "Execution with no program set."+ showStatus Waiting (Just p) = "Waiting execution of program " ++ objectTag p+ showStatus Running (Just p) = "Running execution of program " ++ objectTag p+ showStatus Complete (Just p) = "Completed execution of program " ++ objectTag p+ showStatus Failed (Just p) = "Failed execution of program " ++ objectTag p+ showStatus (DependencyFailed v) (Just p) = "Execution of program " ++ objectTag p ++ " with failed dependency " ++ show v ++ "."+ showInput :: (String,ExecutionInput) -> String+ showInput (lbl,ExecutionStringInput str) = lbl ++ " (string) ← " ++ (maybe "(undefined)" show str)+ showInput (lbl,ExecutionNumberInput n) = lbl ++ " (number) ← " ++ (maybe "(undefined)" show n)+ showInput (lbl,ExecutionObjectInput tobj) = lbl ++ " (file) ← " ++ (maybe "(undefined)" objectTag tobj)+ showOutput (lbl,ExecutionFileOutput tobj) = lbl ++ " (file) → " ++ objectTag tobj+
+ Bein/Web/Pages/Login.hs view
@@ -0,0 +1,48 @@+module Bein.Web.Pages.Login where++import Bein.Web.Commands+import Bein.Web.Pages.Common+import Bein.Web.Types+import Bein.Web.Elements+import Bein.Web.Authentication+import Happstack.Server hiding (method)++loginTitle :: String+loginTitle = "Bein - Login"++login :: BeinServerPart Response+login = page (Just loginTitle) HideNone loginBody (noHtml,noHtml)++loginBody :: (Html,Html) -> BeinFormPart (Html,Html) Html+loginBody (headerMsg,loginMsg) = do+ mconcatM [+ paragraphM << headerMsg,+ paragraphM =<<: [ html "Bein is a web-based shell for exploratory data analysis. ",+ html "Its source and documentation is available at ",+ anchorM <! [href "http://github.com/madhadron/bein"] << "github"],+ formTo "go" tryLogin =<< mconcatM [+ paragraphM =<<: [ alignedLabelM "Username:", textfieldM "username" <!> [value "", size "25"], brM,+ alignedLabelM "Password:", passwordM "password" <!> [value "", size "25"], brM,+ submitM "signin" "Sign in" <!> [thestyle "text-align: right"], html loginMsg ]]]++tryLogin :: BeinServerPart (FormResponse (Html,Html))+tryLogin = withDataFn loginFields tryLogin'+ where tryLogin' :: (String,String) -> BeinServerPart (FormResponse (Html,Html))+ tryLogin' = ensureSession loginFailed loginSucceeded+ +loginFailed :: BeinServerPart (FormResponse (Html,Html))+loginFailed = return $ ContinuePage (noHtml,redParagraph "Invalid username or password.")++loginSucceeded :: BeinServerPart (FormResponse (Html,Html))+loginSucceeded = fullUrl "/" >>= \u -> return $ RedirectTo u+ +loginFields :: RqData (String,String)+loginFields = do+ u <- look "username"+ p <- look "password"+ return (u,p)++authenticated :: BeinServerPart Response -> BeinServerPart Response+authenticated act = getRequestUser >>= \u -> case u of+ Just user -> act `withUser` user+ Nothing -> fullUrl "/login" >>= \url -> seeOther url (toResponse "Redirecting...")
+ Bein/Web/Pages/New.hs view
@@ -0,0 +1,21 @@+module Bein.Web.Pages.New where++import Bein.Web.Types+import Bein.Web.Commands+import Happstack.Server+import Database.HDBC+import Control.Monad.Trans+import Bein.Web.Pages.Login++newObject :: BeinServerPart Response+newObject = authenticated $ do newId <- path createObject+ newUrl <- fullUrl ("/" ++ show newId)+ seeOther newUrl (toResponse "Redirecting...")+ +createObject :: String -> BeinServerPart Int+createObject typeToCreate = + asksUser >>= \user -> lift $ updateWithResponse "select new_object(?,?)" [toSql typeToCreate, toSql (uid user)] >>= \r ->+ case r of+ [] -> error "Did not receive value back from database in createObject!"+ [[newId]] -> return (fromSql newId)+ _ -> error "Received multiple rows from database in createObject!"
+ Bein/Web/Pages/Object.hs view
@@ -0,0 +1,749 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+module Bein.Web.Pages.Object where++import Control.Monad.Writer+import qualified Data.ByteString.Lazy.UTF8 as LU (toString)+import Data.Convertible+import Data.List (intersperse)+import System.Posix.Files+import qualified Data.ByteString.Lazy as B+import System.FilePath+import Prelude hiding (catch)+import Control.Exception+import Control.Monad.Reader+import System.IO+import Network+import Data.Maybe+import qualified Data.Map as M+import Data.List (delete, find)+import Bein.Web.Types+import Bein.Web.Commands+import Bein.Web.Pages.Common+import Bein.Web.Elements+import Bein.Web.Pages.Login+import Happstack.Server+import Data.Time+import Database.HDBC+import System.Locale+import qualified Text.XHtml as X (method)++object :: BeinServerPart Response+object = do+ obj <- asksObject + let pageTitle = Just $ "Editing " ++ (if (immutable (objHeader obj)) then "Immutable " else "") ++ + show (objType (objHeader obj)) ++ " " ++ show (objId obj)+ authenticated $ page pageTitle HideNone objectBody (noHtml,noHtml,noHtml)++objectBody :: (Html,Html,Html) -> BeinFormPart (Html,Html,Html) Html+objectBody (msg,inpAdd,outpAdd) = lift hasReadPermissions >> mconcatM [ runAndDeleteButtons, return msg, objectHeader, objectTypeBody inpAdd outpAdd ]++runAndDeleteButtons :: BeinFormPart (Html,Html,Html) Html+runAndDeleteButtons = lift asksObject >>= \obj -> paragraphM =<<: [+ objectFormTo "delete" deleteObject =<< + submitM "delete" "Delete" <!> ([thestyle "float: right;"] ++ if immutable (objHeader obj) then [disabled] else []),+ case objType (objHeader obj) of+ File -> objectFormTo "downloadfile" downloadFile =<<+ submitM "download" "Download" <!> if objBody obj == Nothing then [disabled] else []+ Program -> objectFormTo "downloadscript" downloadScript =<< + submitM "download" "Download" <!> if objBody obj == Nothing then [disabled] else []+ Execution -> displayRunButtons+ ]+ +data Button = Run | Reset | Abort | NotRunnable deriving (Eq,Show,Read)++runButtons :: Button -> BeinFormPart (Html,Html,Html) Html+runButtons b = lift asksObject >>= \obj -> mconcatM [+ if b == NotRunnable then submitM "" "Not runnable" <!> [disabled] else noHtmlM,+ objectFormTo "run" runExecution =<< if b == Run then submitM "run" "Run" else noHtmlM,+ objectFormTo "reset" resetExecution =<< if b == Reset then submitM "reset" "Reset" <!> + (if immutable (objHeader obj) then [disabled] else [])+ else noHtmlM,+ objectFormTo "abort" abortExecution =<< if b == Abort then submitM "abort" "Abort" else noHtmlM ]++displayRunButtons :: BeinFormPart (Html,Html,Html) Html+displayRunButtons = do + k <- lift asksObject >>= \obj -> case objBody obj of + Nothing -> return NotRunnable+ Just b -> let scr = program b >>= objBody >>= Just . script+ in if scr == Nothing || scr == Just "" || M.filter nullInput (executionInputs b) /= M.empty + then return NotRunnable+ else case status b of+ Waiting -> do r <- lift $ lift $ maybeRowQuery + "select status from current_jobs where id=?" [toSql (objId obj)] + case fmap (fromSql . head) r of+ Nothing -> return Run+ Just "dependency_failed" -> return Reset+ Just _ -> return Abort+ Running -> return Abort+ _ -> return Reset+ runButtons k+ +resetExecution :: BeinServerPart (FormResponse (Html,Html,Html))+resetExecution = do+ hasWritePermissions+ obj <- asksObject+ if immutable (objHeader obj) + then return (ContinuePage (redParagraph "Execution is immutable; cannot reset.",noHtml,noHtml))+ else do lift $ update "update executions set status = 'waiting' where id = ?" [toSql (objId obj)]+ return (ContinuePageWithWrapper (greenParagraph "Execution reset.",noHtml,noHtml) rereadObject)++deleteObject :: BeinServerPart (FormResponse (Html,Html,Html))+deleteObject = do+ hasWritePermissions+ obj <- asksObject+ if immutable (objHeader obj) + then return (ContinuePage (greenParagraph "Object is immutable; cannot delete.",noHtml,noHtml))+ else lift $ (do update "delete from headers where id = ?" [toSql (objId obj)]+ return (RedirectTo "/")) `catchR`+ (\e -> return $ ContinuePage (redParagraph $ "Failed to delete object: " ++ show e,noHtml,noHtml))+ +downloadFile :: BeinServerPart (FormResponse (Html,Html,Html)) +downloadFile = asksObject >>= \obj -> do + hasReadPermissions+ guard (objType (objHeader obj) == File)+ r <- lift $ maybeRowQuery "select content_type,in_repository(stored_as) from files where id = ?" [toSql (objId obj)] + case r of+ Nothing -> return (ContinuePage (redParagraph "File is not yet created or uploaded; cannot download.",noHtml,noHtml))+ Just [rct,rfn] -> do setHeaderM "Content-Type" (fromSql rct)+ liftM NewResponse $ fileServe [] (fromSql rfn)+ Just q -> error $ "Invalid response from database in downloadFile: " ++ show q++downloadScript :: BeinServerPart (FormResponse (Html,Html,Html))+downloadScript = asksObject >>= \obj -> do+ hasReadPermissions+ guard (objType (objHeader obj) == Program)+ r <- lift $ maybeRowQuery "select script from programs where id = ?" [toSql (objId obj)]+ case r of+ Nothing -> return (ContinuePage (redParagraph "No program defined; cannot download.",noHtml,noHtml))+ Just [rscr] -> do setHeaderM "Content-Type" "text/plain; charset=utf-8"+ return $ NewResponse $ toResponse $ (fromSql rscr :: String)+ Just q -> error $ "Invalid response from database in downloadScript: " ++ show q+ ++nullInput :: ExecutionInput -> Bool+nullInput (ExecutionStringInput v) = isNothing v+nullInput (ExecutionNumberInput v) = isNothing v+nullInput (ExecutionObjectInput v) = isNothing v++runExecution :: BeinServerPart (FormResponse (Html,Html,Html))+runExecution = asksObject >>= \obj -> do+ hasWritePermissions+ guard (objType (objHeader obj) == Execution)+ portName <- lift $ configField daemon_port+ st <- ask+ liftIO $ (do h <- connectTo "" (UnixSocket portName) + hSetBuffering h LineBuffering+ hPutStr h $ "run\n" ++ show (objId obj) ++ "\n.\n"+ r <- getCommandBlock h+ r' <- mconcatM [ html "Started job. Daemon responded: ", brM, preM << r ]+ return $ ContinuePageWithWrapper (greenParagraph r',noHtml,noHtml) rereadObject)+ `catch` (\(_ :: IOException) -> do+ runReaderT (update "select run(?)" [toSql (objId obj)]) st+ return $ ContinuePageWithWrapper (greenParagraph "Daemon unreachable; job pending its return.",noHtml,noHtml) rereadObject)++abortExecution :: BeinServerPart (FormResponse (Html,Html,Html))+abortExecution = asksObject >>= \obj -> do+ hasWritePermissions+ guard (objType (objHeader obj) == Execution)+ portName <- lift $ configField daemon_port+ liftIO $ (do h <- connectTo "" (UnixSocket portName)+ hSetBuffering h LineBuffering+ hPutStr h $ "kill\n" ++ show (objId obj) ++ "\n.\n"+ r <- getCommandBlock h+ r' <- mconcatM [ html "Killed job. Daemon responded:", brM, preM << r ]+ return $ ContinuePageWithWrapper (greenParagraph r',noHtml,noHtml) rereadObject)+ `catch` (\(e :: IOException) -> return $ ContinuePageWithWrapper (redParagraph $ "Daemon unreacahble, failed to kill job: " ++ + show e,noHtml,noHtml) rereadObject)+ ++objectHeader :: BeinFormPart (Html,Html,Html) Html+objectHeader = do+ user <- lift $ asksUser+ BeinObject { objHeader = h } <- lift $ asksObject+ objectFormTo "header" updateObjectHeader =<< thedivM <! [identifier "object-header"] =<<: [+ h2M << "Header",+ paragraphM =<<: [ alignedLabelM "Label", textfieldM "label" <!> [value (label h)] ],+ paragraphM =<<: [ alignedLabelM "Last modified", html (formatTime defaultTimeLocale "%F %R" (lastModified h)) ],+ paragraphM =<<: [ alignedLabelM "Created", html (formatTime defaultTimeLocale "%F %R" (created h)) ],+ paragraphM =<<: [ alignedLabelM "Owner", html (userName $ owner h) ],+ paragraphM =<<: [ alignedLabelM "Group", groupBox "group" ([group h] ++ delete (group h) (groups user)) (group h) ],+ paragraphM =<<: [ alignedLabelM "Permissions", permissionBoxes (gr h) (gw h) (wr h) (ww h) ],+ paragraphM =<<: [ alignedLabelM "Notes", textareaM <! [name "notes", identifier "notes", rows "7", cols "80"] << notes h ],+ paragraphM =<<: [ submitM "Save" "Save" <!> [thestyle "float: right;"], html " " ]+ ]+ +permissionBoxes :: Bool -> Bool -> Bool -> Bool -> BeinFormPart (Html,Html,Html) Html+permissionBoxes currentGR currentGW currentWR currentWW = mconcatM [ + html "Group can ", + labelM <! [for "gr"] << "Read", checkboxM "gr" "gr" currentGR,+ labelM <! [for "gw"] << "Write", checkboxM "gw" "gw" currentGW,+ html " / World can ",+ labelM <! [for "wr"] << "Read", checkboxM "wr" "wr" currentWR,+ labelM <! [for "ww"] << "Write", checkboxM "ww" "ww" currentWW ]++updateObjectHeader :: BeinServerPart (FormResponse (Html,Html,Html))+updateObjectHeader = do+ hasWritePermissions+ user <- asksUser+ BeinObject { objId = oid, objHeader = h } <- asksObject+ withDataFn (readObjectHeader user h) (f oid) `mplus` return (ContinuePage (redParagraph "Invalid form entry.",noHtml,noHtml))+ where f oid h = updateObject "update headers set label=?, gid=?,gr=?,gw=?,wr=?,ww=?, notes=? where id=?"+ [toSql (label h), toSql (gid (group h)), toSql (gr h), toSql (gw h), toSql (wr h), toSql (ww h), toSql (notes h), toSql oid]+ "Failed to update header."+ +readObjectHeader :: User -> ObjectHeader -> RqData ObjectHeader+readObjectHeader user h = do+ newLbl <- look "label"+ newGid <- lookRead "group"+ newGroup <- case find (\q -> gid q == newGid) ([group h] ++ delete (group h) (groups user)) of+ Nothing -> fail ""+ Just g -> return g+ ngr <- lookCheckbox "gr"+ ngw <- lookCheckbox "gw"+ nwr <- lookCheckbox "wr"+ nww <- lookCheckbox "ww"+ newNotes <- look "notes"+ return $ h { label = newLbl, group = newGroup, gr = ngr, gw = ngw, wr = nwr, ww = nww, notes = newNotes }+ +updateObject :: String -> [SqlValue] -> String -> BeinServerPart (FormResponse (Html,Html,Html))+updateObject cmd args errMsg = do+ hasWritePermissions+ lift $ (update cmd args >> return (ContinuePageWithWrapper (noHtml,noHtml,noHtml) rereadObject))+ `catchR` (\e -> return $ ContinuePage (redParagraph $ errMsg ++ " " ++ show e,noHtml,noHtml))+++objectTypeBody :: Html -> Html -> BeinFormPart (Html,Html,Html) Html+objectTypeBody inpAdd outpAdd = lift asksObject >>= \obj -> case objType (objHeader obj) of+ File -> fileBody+ Program -> programBody inpAdd outpAdd+ Execution -> executionBody+ +data ObjectState = Future | Mutable | Immutable deriving (Eq,Show,Read)++fileBody :: BeinFormPart (Html,Html,Html) Html+fileBody = lift asksObject >>= \obj -> do+ dep <- lift $ lift $ f $ maybeRowQuery dependsQuery [toSql (objId obj)]+ let st = objectState obj+ fileBody' obj dep st+ where f :: Monad m => m (Maybe [SqlValue]) -> m (Maybe Int)+ f = liftM $ fmap (fromSql . head)+ dependsQuery :: String+ dependsQuery = "select depends_on from dependencies where object = ? and dependency_Type = 'created_by'"++objectState :: BeinObject -> ObjectState+objectState obj | objBody obj == Nothing = Future+ | immutable (objHeader obj) = Immutable+ | True = Mutable++fileBody' :: BeinObject -> Maybe Int -> ObjectState -> BeinFormPart (Html,Html,Html) Html+fileBody' _ Nothing Future = mconcatM [+ h2M << "File",+ paragraphM << "You have not yet uploaded a file.",+ paragraphM =<< multipartFormTo "upload" uploadFile =<< mconcatM [ afileM "file", submitM "upload" "Upload" ]+ ]+fileBody' obj Nothing Mutable = mconcatM [ + fileHeader obj,+ h3M << "Replace file",+ paragraphM =<< multipartFormTo "replace" replaceFile =<< mconcatM [ afileM "file", submitM "upload" "Upload" ] + ]+fileBody' obj Nothing Immutable = do+ baseUrl <- lift $ lift $ configField http_base_url+ v <- lift $ lift $ query ("select execution_id,execution_label from " ++ + "executions_forcing_immutability where file_id = ?") [toSql (objId obj)]+ let v' :: [(Int,String)] = map (\x -> case x of [a,b] -> (fromSql a, fromSql b)+ _ -> error "Invalid fields from database in fileBody' Nothing Immutable") v+ let f (a::Int,b::String) = anchorM <! [href (joinURL baseUrl ("/" ++ show a))] =<<: [+ html (show a ++ " "), + if b == "" then italicsM << "(no label)" else html ("'" ++ b ++ "'") ]+ v'' = intersperse brM $ map f v'+ mconcatM [+ fileHeader obj,+ paragraphM << "File is immutable because it is an input to the executions:",+ paragraphM =<<: v''+ ]+fileBody' _ (Just exId) Future = do+ baseUrl <- lift $ lift $ configField http_base_url+ mconcatM [+ h2M << "File",+ paragraphM =<<: [ html "File to be created when execution ", anchorM <! [href (joinURL baseUrl ("/" ++ show exId))] << show exId,+ html " is run." ] ]+fileBody' obj (Just exId) _ = do + baseUrl <- lift $ lift $ configField http_base_url+ mconcatM [+ fileHeader obj,+ paragraphM =<<: [ html "File created as output of execution ", anchorM <! [href (joinURL baseUrl ("/" ++ show exId))] << show exId,+ html "." ] ]++fileHeader :: BeinObject -> BeinFormPart (Html,Html,Html) Html+fileHeader obj = do+ let b = fromJust $ objBody obj+ filePath <- lift $ lift $ configField file_repository+ thisFileSize <- liftIO $ getFileSize $ joinPath [filePath, storedAs b]+ mconcatM [+ h2M << "File",+ paragraphM =<<: [ alignedLabelM "Filename:", html (userFilename b) ],+ paragraphM =<<: [ alignedLabelM "Content-Type:", html (contentType b) ],+ paragraphM =<<: [ alignedLabelM "File size:", html (prettyPrintFileSize thisFileSize) ] ]++getFileSize :: FilePath -> IO Integer+getFileSize f = getFileStatus f >>= return . toInteger . fileSize++prettyPrintFileSize :: Integer -> String+prettyPrintFileSize s | s < kb = show s ++ " bytes"+ | s < mb = show (s `div` kb) ++ "kb"+ | s < gb = show (s `div` mb) ++ "Mb"+ | True = show (s `div` gb) ++ "Gb"+ where kb :: Integer+ kb = 1024 -- 2^10+ mb :: Integer+ mb = 1048576 -- 2^20+ gb :: Integer+ gb = 1073741824 -- 2^30++uploadFile :: BeinServerPart (FormResponse (Html,Html,Html))+uploadFile = withDataFn (lookInput "file") f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where f inp = do+ hasWritePermissions+ obj <- asksObject + filePath <- lift $ configField file_repository+ lift (maybeRowQuery "select unique_name(in_repository(''),50)" []) >>= \r -> case r of+ Just [targetName] -> do let targetName' = fromSql targetName+ targetFullPath = joinPath [filePath, targetName']+ liftIO $ B.writeFile targetFullPath (inputValue inp)+ lift $ update "insert into files (id,user_filename,stored_as,content_type) values (?,?,?,?)" + [toSql (objId obj), toSql (inputFilename inp), toSql targetName', + toSql (showContentType (inputContentType inp)) ]+ return $ ContinuePageWithWrapper (greenParagraph "Successfully uploaded file.",noHtml,noHtml) rereadObject+ _ -> error "Did not receive a name from the database in uploadFile."+ +replaceFile :: BeinServerPart (FormResponse (Html,Html,Html))+replaceFile = f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where f = do + hasWritePermissions + obj <- asksObject + lift $ update "delete from files where id = ?" [toSql (objId obj)]+ uploadFile+ + +showContentType :: ContentType -> String+showContentType (ContentType { ctType = t, ctSubtype = st, ctParameters = p }) =+ t ++ "/" ++ st ++ parameterString+ where parameterString = concatMap (\(k,v) -> "; " ++ k ++ "=" ++ v) p++programBody :: Html -> Html -> BeinFormPart (Html,Html,Html) Html+programBody inpAdd outpAdd = do+ obj <- lift asksObject+ b <- case objBody obj of+ Nothing -> do lift $ lift $ update "insert into programs(id) values (?)" [toSql (objId obj)]+ lift $ lift $ liftM (fromJust . objBody . fromJust) $ getObject (objId obj)+ Just b -> return b+ case immutable (objHeader obj) of+ True -> programImmutableBody b+ False -> programBodyForm b inpAdd outpAdd+ +programImmutableBody :: ObjectBody -> BeinFormPart (Html,Html,Html) Html+programImmutableBody b = do+ mconcatM [+ h2M << "Program",+ paragraphM =<<: [ alignedLabelM "Language:", html $ show $ language b ],+ paragraphM =<<: [ alignedLabelM "Script:", brM, preM << script b ],+ h3M << "Inputs",+ mconcatM $ map showProgramInput $ M.toList (programInputs b),+ h3M << "Outputs",+ mconcatM $ map showProgramOutput $ M.toList (programOutputs b),+ showResourceSpecification (resourceSpec b) + ]+ +programInputToString :: ProgramInput -> String+programInputToString p = case p of+ InputSequence -> "sequence"+ InputFile -> "file"+ InputString -> "string"+ InputNumber -> "number"++showProgramInput :: (String,ProgramInput) -> BeinFormPart (Html,Html,Html) Html+showProgramInput (lbl,ty) = mconcatM [ alignedLabelM lbl, html $ "(" ++ programInputToString ty ++ ")" ]+ +showProgramOutput :: (String,ProgramOutput) -> BeinFormPart (Html,Html,Html) Html+showProgramOutput (lbl,_) = mconcatM [ alignedLabelM lbl, html "(file)" ] ++programBodyForm :: ObjectBody -> Html -> Html -> BeinFormPart (Html,Html,Html) Html+programBodyForm b inpAdd outpAdd = do+ tell [("input",updateInput),("output",updateOutput)]+ mconcatM [+ h2M << "Program",+ objectFormTo "script" updateLanguageAndScript =<< mconcatM [+ paragraphM =<<: [ alignedLabelM "Language:", radioM "language" "Perl" <!> (if language b == Perl then [checked] else []), + html "Perl", radioM "language" "R" <!> (if language b == R then [checked] else []), html "R" ],+ paragraphM =<<: [ alignedLabelM "Script:", brM, textareaM <! [name "script", identifier "script", cols "80", rows "25"] << script b ],+ paragraphM =<< submitM "save" "Save" + ],+ h3M << "Inputs",+ thedivM <! [identifier "inputs"] =<<: [ mconcatM $ map programInputForm $ M.toList (programInputs b), return inpAdd ],+ objectFormTo "addinput" addInput =<< submitM "addinput" "Add input",+ h3M << "Outputs",+ thedivM <! [identifier "outputs"] =<<: [ mconcatM $ map programOutputForm $ M.toList (programOutputs b), return outpAdd ],+ objectFormTo "addoutput" addOutput =<< submitM "addoutput" "Add output",+ resourceSpecificationForm (resourceSpec b)+ ]+ +addInput :: BeinServerPart (FormResponse (Html,Html,Html))+addInput = do + obj <- asksObject+ u <- fullUrl $ show (objId obj) ++ "/input"+ frm <- formM <! [X.method "post", action u] =<< programInputFormBody "" InputString+ return $ ContinuePage (noHtml,frm,noHtml)++addOutput :: BeinServerPart (FormResponse (Html,Html,Html))+addOutput = do+ obj <- asksObject + u <- fullUrl $ show (objId obj) ++ "/output"+ frm <- formM <! [X.method "post", action u] =<< programOutputFormBody "" OutputFile+ return $ ContinuePage (noHtml,noHtml,frm)++programInputForm :: (String,ProgramInput) -> BeinFormPart (Html,Html,Html) Html +programInputForm (lbl,ty) = paragraphM =<<: [ objectFormTo "input" updateInput =<< programInputFormBody lbl ty ]+ +programInputFormBody :: Monad m => String -> ProgramInput -> m Html+programInputFormBody lbl ty = mconcatM [+ hiddenM "previouslabel" lbl, + textfieldM "newlabel" <!> [value lbl],+ html "Type:",+ selectM <! [identifier "type", name "type"] =<<: [+ typeOption InputFile ty,+ typeOption InputNumber ty,+ typeOption InputString ty ], + submitM "delete" "Delete",+ submitM "update" "Update"+ ]+ where typeOption t c = optionM <! attrs t c << programInputToString t+ attrs t c | t == c = [value (show t), selected]+ | True = [value (show t)]+ +data ProgramInputAction = DeleteProgramInput { oldLabel :: String } | UpdateProgramInput { oldLabel :: String, newLabel :: String, inputType :: ProgramInput }+ deriving (Eq,Show,Read)++updateInput :: BeinServerPart (FormResponse (Html,Html,Html))+updateInput = do+ hasWritePermissions+ mconcat [ withDataFn readInputForm f, return $ ContinuePage (redParagraph $ "Invalid arguments to POST.",noHtml,noHtml) ]+ where readInputForm :: RqData ProgramInputAction+ readInputForm = readOneOf ["update","delete"] >>= \r -> case r of + "Delete" -> do ol <- look "previouslabel"+ return $ DeleteProgramInput ol+ "Update" -> do ol <- look "previouslabel"+ nl <- look "newlabel"+ ty <- lookRead "type"+ return $ UpdateProgramInput ol nl ty+ _ -> fail "unknown command to updateInput"+ f (DeleteProgramInput "") = return $ ContinuePageWithWrapper (greenParagraph $ "Deleted input.",noHtml,noHtml) rereadObject+ f (DeleteProgramInput ol) = do+ obj <- asksObject+ lift $ (do update "delete from program_inputs where id=? and label=?" [toSql (objId obj), toSql ol]+ return $ ContinuePageWithWrapper (greenParagraph "Deleted input.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to delete input: " ++ show e,noHtml,noHtml) rereadObject))+ f (UpdateProgramInput "" "" _) = return $ ContinuePageWithWrapper (redParagraph $ "Cannot create input with empty label.",noHtml,noHtml) + rereadObject+ f (UpdateProgramInput "" nl ty) = do+ obj <- asksObject+ lift $ (do update "insert into program_inputs(id,label,type) values(?,?,?)"+ [toSql (objId obj), toSql nl, toSql (programInputToString ty)]+ return $ ContinuePageWithWrapper (greenParagraph "Updated program input.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper+ (redParagraph $ "Failed to update input: " ++ show e,noHtml,noHtml) rereadObject))+ f (UpdateProgramInput ol nl ty) = do+ obj <- asksObject+ lift $ (do update "update program_inputs set label=?,type=? where id=? and label=?"+ [toSql nl, toSql (programInputToString ty), toSql (objId obj), toSql ol]+ return $ ContinuePageWithWrapper (greenParagraph "Updated program input.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to update input: " ++ show e,noHtml,noHtml) rereadObject))+ +data ProgramOutputAction = DeleteProgramOutput { oldOutputLabel :: String } + | UpdateProgramOutput { oldOutputLabel :: String, newOutputLabel :: String }+ deriving (Eq,Show,Read)++updateOutput :: BeinServerPart (FormResponse (Html,Html,Html)) +updateOutput = do+ hasWritePermissions+ withDataFn readOutputForm f+ where readOutputForm :: RqData ProgramOutputAction+ readOutputForm = readOneOf ["update","delete"] >>= \r -> case r of+ "Delete" -> look "previouslabel" >>= return . DeleteProgramOutput+ "Update" -> do+ ol <- look "previouslabel"+ nl <- look "newlabel"+ return $ UpdateProgramOutput ol nl+ _ -> fail "Invalid command to updateOutput."+ f :: ProgramOutputAction -> BeinServerPart (FormResponse (Html,Html,Html))+ f (DeleteProgramOutput "") = return $ ContinuePageWithWrapper (greenParagraph "Deleted output.",noHtml,noHtml) rereadObject+ f (DeleteProgramOutput ol) = do+ obj <- asksObject+ lift (do update "delete from program_outputs where id=? and label=?" [toSql (objId obj), toSql ol]+ return $ ContinuePageWithWrapper (greenParagraph "Deleted output.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to delete output: " ++ show e,noHtml,noHtml) rereadObject))+ f (UpdateProgramOutput "" "") = return $ ContinuePageWithWrapper (redParagraph $ "Output label cannot be empty.",noHtml,noHtml) rereadObject+ f (UpdateProgramOutput "" nl) = do+ obj <- asksObject+ lift (do update "insert into program_outputs(id,label,type) values (?,?,'file')" [toSql (objId obj), toSql nl]+ return $ ContinuePageWithWrapper (greenParagraph "Updated output.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to update output: " ++ show e,noHtml,noHtml) rereadObject))+ f (UpdateProgramOutput ol nl) = do+ obj <- asksObject+ lift (do update "update program_outputs set label=? where id=? and label=?" [toSql nl, toSql (objId obj), toSql ol]+ return $ ContinuePageWithWrapper (greenParagraph "Updated output.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to update output: " ++ show e,noHtml,noHtml) rereadObject))+ + +readOneOf :: [String] -> RqData String +readOneOf vs = asks fst >>= readOneOf' vs+ where readOneOf' :: [String] -> [(String,Input)] -> RqData String+ readOneOf' [] _ = fail "none of inputs found"+ readOneOf' (q:qs) inps = case lookup q inps of+ Nothing -> readOneOf' qs inps+ Just i -> return $ LU.toString $ inputValue $ i+ +programOutputForm :: (String,ProgramOutput) -> BeinFormPart (Html,Html,Html) Html+programOutputForm (lbl,ty) = paragraphM =<<: [ objectFormTo "output" updateOutput =<< programOutputFormBody lbl ty ]+ +programOutputFormBody :: Monad m => String -> ProgramOutput -> m Html+programOutputFormBody lbl _ = mconcatM [+ hiddenM "previouslabel" lbl,+ textfieldM "newlabel" <!> [value lbl],+ html "Type: file",+ submitM "delete" "Delete",+ submitM "update" "Update" ]++ +updateLanguageAndScript :: BeinServerPart (FormResponse (Html,Html,Html))+updateLanguageAndScript = do+ hasWritePermissions+ withDataFn readLanguageAndScript f+ where readLanguageAndScript :: RqData (ProgramLanguage,String)+ readLanguageAndScript = do+ l <- lookRead "language"+ scr <- look "script"+ return (l,scr)+ f :: (ProgramLanguage,String) -> BeinServerPart (FormResponse (Html,Html,Html))+ f (l,scr) = do obj <- asksObject+ lift $ (do update "update programs set language = ?, script = ? where id = ?" + [toSql (if l == Perl then "perl" else "r"), toSql scr, toSql (objId obj)]+ return $ ContinuePageWithWrapper (greenParagraph "Successful.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper + (redParagraph $ "Error updating language and script: " ++ show e,noHtml,noHtml)+ rereadObject))+++executionBody :: BeinFormPart (Html,Html,Html) Html+executionBody = do+ obj <- lift $ asksObject+ q <- lift $ lift $ maybeRowQuery "select id from current_jobs where id=?" [toSql (objId obj)]+ if immutable (objHeader obj) || (fmap status (objBody obj) /= Just Waiting && fmap status (objBody obj) /= Nothing) || q /= Nothing+ then showExecutionBody+ else executionBodyForm++executionBodyForm :: BeinFormPart (Html,Html,Html) Html+executionBodyForm = do+ obj <- lift $ asksObject+ b <- case objBody obj of+ Nothing -> do lift $ lift $ update "insert into executions(id) values (?)" [toSql (objId obj)]+ lift $ lift $ liftM (fromJust . objBody . fromJust) $ getObject (objId obj)+ Just b -> return b+ baseUrl <- lift $ lift $ configField http_base_url+ mconcatM [ + h2M << "Execution",+ paragraphM =<<: [ alignedLabelM "Status:", html (show (status b)) ],+ paragraphM =<<: [ alignedLabelM "Program:", + case program b of + Just p -> anchorM <! [href (joinURL baseUrl ("/" ++ show (objId p)))] << objectTag p+ Nothing -> html "No program defined." ],+ objectFormTo "program" setProgram =<< paragraphM =<<: [ html "Change program to:", brM, typeList Program, submitM "change" "Change program" ],+ h3M << "Inputs",+ mconcatM $ map showInput (M.toList (executionInputs b)),+ h3M << "Outputs",+ mconcatM $ map showOutput (M.toList (executionOutputs b)),+ resourceSpecificationForm (resourceSpec b),+ h3M << "Execution log",+ mconcatM $ map showExecutionLog (executionLog b)+ ]+ +showExecutionBody :: BeinFormPart (Html,Html,Html) Html+showExecutionBody = do+ obj <- lift $ asksObject+ let b = fromJust $ objBody obj+ baseUrl <- lift $ lift $ configField http_base_url+ mconcatM [+ h2M << "Execution",+ paragraphM =<<: [ alignedLabelM "Status:", html (show (status b)) ],+ paragraphM =<<: [ alignedLabelM "Program:", case program b of+ Just p -> anchorM <! [href (joinURL baseUrl ("/" ++ show (objId p)))] << objectTag p+ Nothing -> html "No program defined. How did you get this to be immutable?" ],+ h3M << "Inputs",+ mconcatM $ map displayInput (M.toList (executionInputs b)),+ h3M << "Outputs",+ mconcatM $ map displayOutput (M.toList (executionOutputs b)),+ showResourceSpecification (resourceSpec b),+ h3M << "Excution log",+ mconcatM $ map showExecutionLog (executionLog b)+ ]++showInput :: (String,ExecutionInput) -> BeinFormPart (Html,Html,Html) Html+showInput (lbl,ExecutionStringInput v) = objectFormTo "setstringinput" setStringInput =<< paragraphM =<<: [+ alignedLabelM lbl, hiddenM "label" lbl, textfieldM "value" <!> [value (fromMaybe "" v)], submitM "update" "Update" ]+showInput (lbl,ExecutionNumberInput v) = objectFormTo "setnumberinput" setNumberInput =<< paragraphM =<<: [+ alignedLabelM lbl, hiddenM "label" lbl, textfieldM "value" <!> [value (fromMaybe "" (fmap show v))], submitM "update" "Update" ]+showInput (lbl,ExecutionObjectInput v) = objectFormTo "setobjectinput" setObjectInput =<< paragraphM =<<: [ alignedLabelM lbl, hiddenM "label" lbl, html $ maybe "(unspecified)" objectTag v, html "Change to:", typeList File, submitM "update" "Update" ]+ +displayInput :: (String,ExecutionInput) -> BeinFormPart (Html,Html,Html) Html+displayInput (lbl,ExecutionStringInput v) = + paragraphM =<<: [ alignedLabelM lbl, html $ fromMaybe "(undefined)" v ]+displayInput (lbl,ExecutionNumberInput v) =+ paragraphM =<<: [ alignedLabelM lbl, html $ fromMaybe "(undefined)" (fmap show v) ]+displayInput (lbl,ExecutionObjectInput v) = do+ paragraphM =<<: [ alignedLabelM lbl, + case v of+ Nothing -> html "(unspecified)"+ Just obj -> do inputUrl <- lift $ fullUrl ("/" ++ show (objId obj))+ anchorM <! [href inputUrl] << objectTag obj + ]++setNumberInput :: BeinServerPart (FormResponse (Html,Html,Html))+setNumberInput = do+ hasWritePermissions+ withDataFn lookLabelNumber f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where lookLabelNumber :: RqData (String,Double)+ lookLabelNumber = do l <- look "label"+ v <- lookRead "value"+ return (l,v)+ f :: (String,Double) -> BeinServerPart (FormResponse (Html,Html,Html))+ f (lbl,n) = do obj <- asksObject+ lift $ (do update "update execution_number_inputs set value = ? where id = ? and label = ?"+ [toSql n, toSql (objId obj), toSql lbl]+ return $ ContinuePageWithWrapper (greenParagraph "Input set successfully.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper + (redParagraph $ "Failed to set number input: " ++ show e,noHtml,noHtml) rereadObject))++setObjectInput :: BeinServerPart (FormResponse (Html,Html,Html))+setObjectInput = do+ hasWritePermissions+ withDataFn lookLabelObjId f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where lookLabelObjId :: RqData (String,Int)+ lookLabelObjId = do l <- look "label"+ v <- lookRead "file"+ return (l,v)+ f :: (String,Int) -> BeinServerPart (FormResponse (Html,Html,Html))+ f (lbl,oid) = do obj <- asksObject+ lift $ (do update "update execution_object_inputs set value = ? where id = ? and label = ?"+ [toSql oid, toSql (objId obj), toSql lbl]+ return $ ContinuePageWithWrapper (greenParagraph "Input set successfully.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper+ (redParagraph $ "Failed to set object input: " ++ show e,noHtml,noHtml) rereadObject))++setStringInput :: BeinServerPart (FormResponse (Html,Html,Html)) +setStringInput = hasWritePermissions >> (withDataFn lookLabelValue f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml)))+ where f :: (String,String) -> BeinServerPart (FormResponse (Html,Html,Html))+ f (l,v) = do obj <- asksObject+ lift $ (do update "update execution_string_inputs set value = ? where id = ? and label = ?" + [toSql v, toSql (objId obj), toSql l]+ return $ ContinuePageWithWrapper (greenParagraph "Input set successfully.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper + (redParagraph $ "Failed to set string input: " ++ show e,noHtml,noHtml) rereadObject))+ lookLabelValue :: RqData (String,String)+ lookLabelValue = do l <- look "label"+ v <- look "value"+ return (l,v)++showOutput :: (String,ExecutionOutput) -> BeinFormPart (Html,Html,Html) Html+showOutput (lbl,ExecutionFileOutput outObj) = do+ outputUrl <- lift $ fullUrl ("/" ++ show (objId outObj))+ paragraphM =<<: [ alignedLabelM lbl, anchorM <! [href outputUrl] << objectTag outObj ]+ +displayOutput :: (String,ExecutionOutput) -> BeinFormPart (Html,Html,Html) Html+displayOutput (lbl,ExecutionFileOutput outObj) = do+ outputUrl <- lift $ fullUrl ("/" ++ show (objId outObj))+ paragraphM =<<: [ alignedLabelM lbl, anchorM <! [href outputUrl] << objectTag outObj ]++resourceSpecificationForm :: ResourceSpec -> BeinFormPart (Html,Html,Html) Html+resourceSpecificationForm rspec = objectFormTo "updateresourcespec" updateResourceSpec =<< mconcatM [+ h3M << "Resource Specification",+ fieldPara "Resource string" "resreq" resReq,+ fieldPara "Max CPU" "maxcpu" (maybe "" show . maxCpu),+ fieldPara "Max file size" "maxfilesize" (maybe "" show . maxFileSize),+ fieldPara "Max RAM" "maxram" (maybe "" show . maxRam),+ fieldPara "Max swap" "maxswap" (maybe "" show . maxSwap),+ fieldPara "Max processes" "maxprocs" (maybe "" show . maxProcs),+ submitM "save" "Save" ]+ where fieldPara a b c = paragraphM =<<: [ alignedLabelM a, textfieldM b <!> [value (c rspec)] ]++nonempty :: String -> (a -> String) -> a -> String+nonempty d f v = case f v of + "" -> d+ r -> r++showResourceSpecification :: ResourceSpec -> BeinFormPart (Html,Html,Html) Html+showResourceSpecification rspec = mconcatM [+ h3M << "Resource Specification",+ fieldPara "Resource string" (nonempty "(no request)" resReq),+ fieldPara "Max CPU" (maybe "(unlimited)" show . maxCpu),+ fieldPara "Max file size" (maybe "(unlimited)" show . maxFileSize),+ fieldPara "Max RAM" (maybe "(unlimited)" show . maxRam),+ fieldPara "Max swap" (maybe "(unlimited)" show . maxSwap),+ fieldPara "Max processes" (maybe "(unlimited)" show . maxProcs)+ ]+ where fieldPara :: String -> (ResourceSpec -> String) -> BeinFormPart (Html,Html,Html) Html+ fieldPara a c = paragraphM =<<: [ alignedLabelM a, html (c rspec) ]+++updateResourceSpec :: BeinServerPart (FormResponse (Html,Html,Html))+updateResourceSpec = hasWritePermissions >> withDataFn lookRspec f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where lookRspec :: RqData ResourceSpec+ lookRspec = do rreq <- look "resreq"+ rcpu <- lookMaybeRead "maxcpu" + rfilesize <- lookMaybeRead "maxfilesize"+ rram <- lookMaybeRead "maxram"+ rswap <- lookMaybeRead "maxswap"+ rprocs <- lookMaybeRead "maxprocs"+ return $ ResourceSpec { resReq = rreq, maxCpu = rcpu,+ maxFileSize = rfilesize, maxRam = rram,+ maxSwap = rswap, maxProcs = rprocs }+ f rspec = asksObject >>= \obj -> + lift $ (do update "update resource_specification set resreq=?,maxcpu=?,maxfilesize=?,maxram=?,maxswap=?,maxprocs=? where id=?"+ [toSql (resReq rspec), maybeToSql (maxCpu rspec), maybeToSql (maxFileSize rspec),+ maybeToSql (maxRam rspec), maybeToSql (maxSwap rspec), maybeToSql (maxProcs rspec), toSql (objId obj)]+ return $ ContinuePageWithWrapper (greenParagraph "Resource specification successfully updated.",noHtml,noHtml) rereadObject+ `catchR` (\e -> return $ ContinuePageWithWrapper (redParagraph $ "Failed to update resource specification: " ++ show e,noHtml,noHtml) rereadObject))++maybeToSql :: Convertible a SqlValue => Maybe a -> SqlValue +maybeToSql Nothing = SqlNull+maybeToSql (Just a) = toSql a+ +lookMaybeRead :: Read a => String -> RqData (Maybe a)+lookMaybeRead f = look f >>= \r -> case r of+ "" -> return Nothing+ _ -> case reads r of+ [(v,"")] -> return (Just v)+ _ -> fail ""+ +showExecutionLog :: (LocalTime,String) -> BeinFormPart (Html,Html,Html) Html+showExecutionLog (t,v) = paragraphM =<<: [ alignedLabelM (formatTime defaultTimeLocale "%F %R" t), html v ]+ ++typeList :: ObjectType -> BeinFormPart (Html,Html,Html) Html+typeList t = programs >>= \p -> selectM <! [identifier typeStr, name typeStr] =<<: map programToOption p+ where programs :: BeinFormPart (Html,Html,Html) [BeinObject]+ programs = do user <- lift $ asksUser+ rids <- lift $ lift $ query ("select id from headers where type=? and (uid=? or array[gid] <@ array" ++ (show $ map gid $ groups user) ++ ") order by last_modified desc") [toSql typeStr, toSql (uid user)]+ let ids = map (fromSql . head) rids+ lift $ lift $ mapM ((liftM fromJust) . getObject) ids+ programToOption o = optionM <! [value (show $ objId o)] << objectTag o+ typeStr = case t of File -> "file"; Execution -> "execution"; Program -> "program"++setProgram :: BeinServerPart (FormResponse (Html,Html,Html))+setProgram = do+ hasWritePermissions + withDataFn (lookRead "program") f `mplus` return (ContinuePage (redParagraph "Invalid field entry.",noHtml,noHtml))+ where f :: Int -> BeinServerPart (FormResponse (Html,Html,Html))+ f progId = do obj <- asksObject+ lift $ (do update "update executions set program = ? where id = ?" [toSql progId, toSql (objId obj)]+ return (ContinuePageWithWrapper (greenParagraph "Set program.",noHtml,noHtml) rereadObject)+ `catchR` (\e -> return (ContinuePageWithWrapper (redParagraph $ "Failed to set program: " ++ show e,noHtml,noHtml) + rereadObject)))
+ Bein/Web/Pages/Settings.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Bein.Web.Pages.Settings where++import Data.List+import Bein.Web.Pages.Login+import Database.HDBC+import Control.Monad.Trans+import Bein.Web.Pages.Common+import Bein.Web.Elements+import Bein.Web.Types+import Bein.Web.Commands+import Happstack.Server hiding (method)++settings :: BeinServerPart Response+settings = authenticated $ page (Just "Settings") HideSettings settingsPage noHtml++settingsPage :: Html -> BeinFormPart Html Html+settingsPage msg = + return msg <> defaults <> groupSettings++defaults :: BeinFormPart Html Html+defaults = do+ user <- lift $ asksUser+ mconcatM [ h2M << "Defaults", + formTo "defaults" setPermissions =<< paragraphM =<<: [ + alignedLabelM "Default permissions", html "Group can ", + labelM <! [for "gr"] << "Read", checkboxM "gr" "gr" (defaultGR user),+ labelM <! [for "gw"] << "Write", checkboxM "gw" "gw" (defaultGW user),+ html " / World can ",+ labelM <! [for "wr"] << "Read", checkboxM "wr" "wr" (defaultWR user),+ labelM <! [for "ww"] << "Write", checkboxM "ww" "ww" (defaultWW user),+ submitM "save" "Save" ] ]+ +setPermissions :: BeinServerPart (FormResponse Html)+setPermissions = withDataFn readPermissions updatePermissions+ where readPermissions :: RqData (Bool,Bool,Bool,Bool)+ readPermissions = do+ ngr <- lookCheckbox "gr"+ ngw <- lookCheckbox "gw"+ nwr <- lookCheckbox "wr"+ nww <- lookCheckbox "ww"+ return (ngr,ngw,nwr,nww)+ updatePermissions :: (Bool,Bool,Bool,Bool) -> BeinServerPart (FormResponse Html)+ updatePermissions (newgr,newgw,newwr,newww) = asksUser >>= \user ->+ updateSettings "update users set default_gr=?,default_gw=?,default_wr=?,default_ww=? where uid = ?"+ [toSql newgr, toSql newgw, toSql newwr, toSql newww, toSql $ uid user]+ "Failed to set default permissions:"+ +updateSettings :: String -> [SqlValue] -> String -> BeinServerPart (FormResponse Html)+updateSettings cmd args errMsg = + lift $ (update cmd args >> return (ContinuePageWithWrapper noHtml rereadUser))+ `catchR` (\e -> return $ ContinuePage (redParagraph $ errMsg ++ " " ++ show e))+++groupSettings :: BeinFormPart Html Html+groupSettings = mconcatM [+ h2M << "Groups",+ defaultGroupForm,+ groupMembership ]+ +defaultGroupForm :: BeinFormPart Html Html +defaultGroupForm = lift asksUser >>= \user -> + formTo "defaultgroup" setDefaultGroup =<< paragraphM =<<: [+ alignedLabelM "Default group",+ groupBox "defaultgroup" (groups user) (defaultGroup user),+ submitM "save" "Save" ]+ where setDefaultGroup :: BeinServerPart (FormResponse Html)+ setDefaultGroup = asksUser >>= \user -> withDataFn (readDefaultGroup user) (\thisGroup ->+ updateSettings "update users set default_group = ? where uid = ?" [toSql (gid thisGroup), toSql (uid user)]+ "Failed to change default group:")+ readDefaultGroup :: User -> RqData Group+ readDefaultGroup user = do+ newGid <- lookRead "defaultgroup"+ case find (\q -> gid q == newGid) (groups user) of+ Nothing -> fail ""+ Just g -> return g+ +groupMembership :: BeinFormPart Html Html+groupMembership = lift asksUser >>= \user -> mconcatM [+ paragraphM =<< alignedLabelM "Group membership",+ tableM =<<: tableHeader : map groupLine (groups user),+ paragraphM =<< newGroupForm ]+ where tableHeader = trM =<<: [ thM << "Gid", thM << "Group name", thM << "Add user...", thM << "Leave group" ]+ +newGroupForm :: BeinFormPart Html Html+newGroupForm = do+ frm <- mconcatM [ strongM << "New group: ", textfieldM "newgroupname", submitM "create" "Create" ]+ formTo "creategroup" createGroup frm+ where createGroup :: BeinServerPart (FormResponse Html)+ createGroup = do+ user <- asksUser+ withDataFn (look "newgroupname") (\newGroupName ->+ updateSettings "select create_group(?,?)" [toSql newGroupName, toSql (uid user)]+ ("Failed to create group " ++ newGroupName ++ ":"))+ +data GroupOperation = Rename Int String | AddUser Int String | LeaveGroup Int deriving (Eq,Show,Read)++groupLine :: Group -> BeinFormPart Html Html+groupLine g = do+ frm <- mconcatM [+ hiddenM "gid" (show $ gid g),+ tdM << show (gid g),+ tdM =<<: [ textfieldM "groupname" <!> [value (groupName g)], submitM "rename" "Rename" ],+ tdM =<<: [ textfieldM "username", submitM "adduser" "Add User" ],+ tdM =<< submitM "leavegroup" "Leave group" ]+ trM =<< formTo "altergroup" updateGroup frm+ + where updateGroup :: BeinServerPart (FormResponse Html)+ updateGroup = withDataFn readGroup updateGroup'+ updateGroup' :: GroupOperation -> BeinServerPart (FormResponse Html)+ updateGroup' (Rename thisGid newName) = + updateSettings "update groups set name = ? where gid = ?"+ [toSql newName, toSql thisGid] "Failed to rename group:"+ updateGroup' (AddUser thisGid newUsername) = do+ u <- lift $ getUser (WithUserName newUsername)+ g' <- lift $ getGroup (WithGid thisGid)+ guard2 (return $ ContinuePage $ redParagraph ("User " ++ newUsername ++ " does not exist."))+ (return $ ContinuePage $ redParagraph ("No group exists with gid " ++ show thisGid ++ "."))+ (\user thisGroup -> updateSettings "insert into group_members(uid,gid) values (?,?)"+ [toSql (uid user), toSql (gid thisGroup)] "Could not add member to group:") u g'+ updateGroup' (LeaveGroup thisGid) = asksUser >>= \user ->+ updateSettings "delete from group_members where uid = ? and gid = ?" [toSql (uid user), toSql thisGid]+ "Failed to remove you from group."+ readGroup :: RqData GroupOperation+ readGroup = do+ thisGid <- lookRead "gid"+ r <- lookSubmit "rename"+ a <- lookSubmit "adduser"+ l <- lookSubmit "leavegroup"+ case () of + _ | r -> look "groupname" >>= \thisGroup -> return (Rename thisGid thisGroup)+ _ | a -> look "username" >>= \u -> return (AddUser thisGid u)+ _ | l -> return (LeaveGroup thisGid)+ _ -> error "In groupLine, no submit buttons were pressed in form."+
+ Bein/Web/Pages/SignOut.hs view
@@ -0,0 +1,10 @@+module Bein.Web.Pages.SignOut where++import Bein.Web.Authentication+import Bein.Web.Types+import Happstack.Server++signOut :: BeinServerPart Response+signOut = do+ clearSession+ seeOther "/" $ toResponse "Redirecting..."
+ Bein/Web/Routing.hs view
@@ -0,0 +1,35 @@+module Bein.Web.Routing where++import Data.Monoid+import Bein.Web.Types+import Bein.Web.Commands+import Bein.Web.Pages.Index+import Bein.Web.Pages.Object+import Bein.Web.Pages.Settings+import Bein.Web.Pages.SignOut+import Bein.Web.Pages.New+import Happstack.Server+import Control.Monad.Trans+import System.FilePath+import Bein.Web.Pages.Login++routing :: BeinServerPart Response+routing = mconcat [+ nullDir >> index,+ dir "login" $ login,+ dir "settings" $ settings,+ guardObject $ object,+ exactDir "signout" $ signOut,+ dir "new" $ newObject,+ staticData+ ]++staticData :: BeinServerPart Response +staticData = mconcat [ staticFile "default.css" "text/css; charset=utf-8" ]+-- staticFile "jquery.js" "text/javascript",+-- staticFile "script.js" "text/javascript" ]+ where staticFile dirName contType = dir dirName $ do + d <- lift $ configField static_content_directory+ setHeaderM "Content-Type" contType+ fileServe [] (joinPath [d,dirName])+
+ Bein/Web/Types.hs view
@@ -0,0 +1,7 @@+module Bein.Web.Types (+ module Bein.Types,+ module Bein.Web.Types.Local+) where++import Bein.Types+import Bein.Web.Types.Local
+ Bein/Web/Types/Local.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types #-}+module Bein.Web.Types.Local where++import Control.Concurrent.STM+import Database.HDBC.PostgreSQL+import Data.Time+import qualified Data.Map as M+import Bein.Types+import Happstack.Server+import Control.Monad.Reader+import Control.Concurrent+import System.IO+import Control.Monad.Writer++data WebState = WebState { stDb :: Connection, stConfigT :: TVar Configuration, stDaemonPort :: MVar Handle, + stUser :: Maybe User, stObject :: BeinObject }++instance BeinState WebState where+ configT = stConfigT+ db = stDb+ +type BeinServerPart = ServerPartT (ReaderT WebState IO)+ +data FormResponse a = ContinuePage a + | ContinuePageWithWrapper a (BeinServerPart Response -> BeinServerPart Response) + | NewResponse Response + | RedirectTo String++type BeinFormPart a = WriterT [(String, BeinServerPart (FormResponse a))] BeinServerPart++--type BeinForm a = XHtmlForm (ReaderT WebState IO) a+--type BeinFormlet a = XHtmlFormlet (ReaderT WebState IO) a++--instance (Applicative m, Monad m) => Applicative (ReaderT s m) where+-- pure = return+-- (<*>) = ap++data AuthType = Password String | Host String | NoLogin deriving (Eq,Show,Read)+data Group = Group { gid :: Int, groupName :: String } deriving (Eq,Show,Read)+data User = User { uid :: Int,+ userName :: String,+ groups :: [Group],+ defaultGR :: Bool,+ defaultGW :: Bool,+ defaultWR :: Bool,+ defaultWW :: Bool,+ defaultGroup :: Group,+ isAdministrator :: Bool,+ authType :: AuthType } deriving (Eq,Show,Read)++data BeinObject = BeinObject { objId :: Int, objHeader :: ObjectHeader,+ objBody :: Maybe ObjectBody }+ deriving (Eq,Show,Read)+++data ObjectHeader = ObjectHeader {+ label :: String,+ notes :: String,+ owner :: User,+ group :: Group,+ gr :: Bool,+ gw :: Bool,+ wr :: Bool,+ ww :: Bool,+ created :: LocalTime,+ lastModified :: LocalTime,+ objType :: ObjectType,+ immutable :: Bool+} deriving (Eq,Show,Read)++data ObjectType = File | Program | Execution deriving (Eq,Show,Read)++data ObjectBody = FileBody { userFilename :: String, storedAs :: FilePath, contentType :: String }+ | ProgramBody { language :: ProgramLanguage, script :: String,+ programInputs :: M.Map String ProgramInput,+ programOutputs :: M.Map String ProgramOutput, + resourceSpec :: ResourceSpec }+ | ExecutionBody { resourceSpec :: ResourceSpec,+ program :: Maybe BeinObject,+ status :: ExecutionStatus,+ executionInputs :: M.Map String ExecutionInput,+ executionOutputs :: M.Map String ExecutionOutput,+ executionLog :: [(LocalTime,String)] }+ deriving (Eq,Show,Read)+ +data ExecutionInput = ExecutionStringInput (Maybe String)+ | ExecutionNumberInput (Maybe Double)+ | ExecutionObjectInput (Maybe BeinObject) deriving (Eq,Show,Read)+ +data ExecutionOutput = ExecutionFileOutput BeinObject deriving (Eq,Show,Read)++data ResourceSpec = ResourceSpec {+ resReq :: String,+ maxCpu :: Maybe Int,+ maxFileSize :: Maybe Int,+ maxRam :: Maybe Int,+ maxSwap :: Maybe Int,+ maxProcs :: Maybe Int+} deriving (Eq,Show,Read)++data ExecutionStatus = Waiting | Running | Complete | Failed | DependencyFailed Int deriving (Eq,Show,Read)+ +data ProgramLanguage = Perl | R deriving (Eq,Show,Read)++data ProgramInput = InputSequence | InputFile | InputString | InputNumber deriving (Eq,Show,Read)++data ProgramOutput = OutputFile deriving (Eq,Show,Read)++data UserQuery = WithUid Int | WithUserName String | WithHost String deriving (Eq,Show,Read)+data GroupQuery = WithGid Int | WithGroupName String deriving (Eq,Show,Read)++data PageTitle = JustTitle String | TitleSubtitle String String deriving (Eq,Show,Read)+++data RereadOnUpdate = NoReread | RereadUser | RereadObject | RereadUserAndObject deriving (Eq,Show,Read)
+ INSTALL view
@@ -0,0 +1,36 @@+Installing Bein+---------------++Bein consists of four components: a PostgreSQL database, a daemon named 'beind', an execution minion named 'bein-minion', and a web interface named 'bein-httpd'. All should run as user 'bein' on the same system. There is also a program called 'beinctl' which handles setting up and tearing down the database.++1. Make sure PostgreSQL is running and has the PL/Python language available. Bein connects to the database via a Unix domain socket, which appears as a file '/tmp/.s.PGSQL.5432'. Make sure that file exists when PostgreSQL is running. If it does not, you will need to spend some time with the PostgreSQL manuals getting it configured correctly.++2. Create a user 'bein' on the operating system, and then, as a user with the ability to create roles in PostgreSQL, run++> createdb bein+> createuser bein++Tell it 'no' when it asks if the user 'bein' should be a superuser. Make sure there is a line like ++local bein bein ident++in PostgreSQL's 'pg_hba.conf' file, typically stored in its data directory. This lets programs running as operating system user 'bein' log into database 'bein' via the Unix domain socket on the local machine with no further authentication.++3. Uncompress the Bein package, and in the resulting directory run++> cabal configure+> cabal build+> cabal install++4. Initialize the database by running++> beinctl init++5. As user 'bein', run 'beind start' to start the execution daemon, and 'bein-httpd start' to star the web interface. Both should automatically connect to the database and configure themselves.+++TODO:+* Add information on installing the Haskell Platform and necessary libraries like Happstack and Happstack-auth.+* How to set up your path to run programs in the ~/.cabal/bin/ directory.+* Add more detail on starting and controlling the system.+* Setting up forwarding to bein-httpd.
+ README view
@@ -0,0 +1,19 @@+Bein+----++Bein is a provenance and workflow system for bioinformatics. Typically a bioinformaticist ends up with a dozen scripts and a thousand or so files from running the scripts with slightly varying parameters and no way to keep track of what came from where. Bein resolves this by keeping scripts, and their executions on inputs and the resulting outputs, in a database, and providing a web interface to the system.++Organization of the build directory+-----------------------------------++The build directory contains the following items:++bein.cabal -- The equivalent of a Makefile for Haskell+doc/ -- Documentation for the system+priv/files/ -- A default directory for data files stored in Bein+priv/scratch/ -- A default working directory for scripts run by Bein+Setup.lhs -- Part of the infrastructure needed by bein.cabal. DO NOT EDIT.+sql/ -- All code for setting up the PostgreSQL database+src/ -- Haskell source code+templates/ -- Template files for the web interface+
bein.cabal view
@@ -1,5 +1,5 @@ name: bein-version: 0.2+version: 0.3 synopsis: Bein is a provenance and workflow management system for bioinformatics. description: To avoid having thousands of files produced in a random way from a bunch of scripts, as is typically the case for a bioinformaticist, Bein keeps track of scripts, and their executions on various inputs. It provides a web front end, and will integrate with LSF clusters. category: Application@@ -8,12 +8,14 @@ author: Fred Ross maintainer: fred.ross@epfl.ch build-type: Simple-Cabal-Version: >= 1.4+Cabal-Version: >= 1.6+Data-Files: INSTALL README sql/*.sql static/default.css Executable beinctl Main-is: Bein/BeinCtl.hs Build-Depends: base >= 3 && < 5, HDBC, HDBC-postgresql, process Ghc-Options: -Wall -threaded -fno-warn-unused-do-bind+ Other-Modules: Bein.Types, Bein.Configuration, Bein.ShellScripting Hs-Source-Dirs: . Executable beind@@ -22,6 +24,10 @@ hdaemonize >= 0.3, hsyslog, parsec, random, unix, network, convertible, stm, mtl, filepath Ghc-Options: -Wall -threaded -fno-warn-unused-do-bind+ Other-Modules: Bein.Types, Bein.Commands, Bein.Configuration,+ Bein.SocketHandler, Bein.Daemon.Types, + Bein.Daemon.Commands, Bein.Daemon.Protocol,+ Bein.Daemon.SignalHandlers Hs-Source-Dirs: . Executable beinclient@@ -35,6 +41,10 @@ Build-Depends: base >= 3 && < 5, network, hsyslog, parsec, HDBC, HDBC-postgresql, process, unix, stm, mtl, filepath, directory Ghc-Options: -Wall -threaded -fno-warn-unused-do-bind+ Other-Modules: Bein.Types, Bein.Commands, Bein.SocketHandler,+ Bein.Minion.Types, Bein.Minion.Arguments,+ Bein.Minion.Commands, Bein.Minion.Protocol,+ Bein.Configuration Hs-Source-Dirs: . Executable beinhttpd@@ -44,4 +54,14 @@ happstack-util, containers, xhtml, time, old-locale, utf8-string, bytestring Ghc-Options: -Wall -threaded -fno-warn-unused-do-bind+ Other-Modules: Bein.Web.Elements.Attributes, Bein.Web.Elements.Base,+ Bein.Web.Elements.Tags, Bein.Web.Elements,+ Bein.Types, Bein.Commands, Bein.Web.Types.Local,+ Bein.Configuration, Bein.Web.Types,+ Bein.Web.Commands.Local, Bein.Web.Commands,+ Bein.Web.Pages.Common, Bein.Web.Authentication,+ Bein.Web.Pages.SignOut, Bein.Web.Pages.Login,+ Bein.Web.Pages.Index, Bein.Web.Pages.Object,+ Bein.Web.Pages.Settings, Bein.Web.Pages.New,+ Bein.Web.Routing Hs-Source-Dirs: .
+ sql/core_tables.sql view
@@ -0,0 +1,463 @@+\set ON_ERROR_STOP++-- Bein's authentication is quite simple: every object belongs+-- permanently to the user who created it (and it cannot be+-- transferred), and to a group of users. Each object is always+-- readable and writable by its owner, and the permissions to read and+-- write are set for group and world a la unix.++-- Anyone who is an administrator can access the configuration table+-- of the database, start and stop the daemon, check everyone's jobs,+-- etc. The read/write options don't apply to him. He's root,+-- essentially. An administrator will probably want a separate+-- account for his own work so it's not continually clogged by+-- everyone else's data.++create table groups (+ gid serial primary key,+ name varchar unique not null+);++-- on insert:+-- on update:+-- on delete:+-- * fail if trying to delete group 'nobody'+-- * fail if trying to delete group which is default for a user++create type authentication_enum as+ enum ('password','host','nologin');++create table users (+ uid integer primary key,+ name varchar unique not null,+ default_gr boolean not null,+ default_gw boolean not null,+ default_wr boolean not null,+ default_ww boolean not null,+ default_group integer references groups(gid),+ administrator boolean not null default false,+ auth_type authentication_enum not null default 'password',+ auth_secret text+);++-- on insert:+-- * create a group of the same name as the user, and add user to it.+-- on update:+-- on delete:+-- * fail if trying to delete user 'nobody'+-- * delete the group corresponding to this user.++insert into groups (gid,name) values (0,'nobody');++insert into users (uid,name,default_gr,default_gw,default_wr,default_ww,default_group,auth_type)+values (0,'nobody',true,true,true,true,0,'nologin');++create table group_members (+ uid integer references users(uid)+ on delete cascade+ on update cascade+ deferrable,+ gid integer references groups(gid)+ on delete cascade+ on update cascade,+ primary key (uid,gid)+);++insert into group_members (uid,gid) values (0,0); -- nobody is part of group nobody++-- on insert:+-- on update:+-- on delete:+-- * set all objects owned by user with group gid to be owned by user's group+-- * if no more users in group, delete group++-- Every object has a header, which is independent of its type. The+-- header stores descriptions, permissions, and timestamps, and a+-- pointer to the object's type.+create type object_type_enum as + enum ('program', 'execution', 'file', 'sequence');++create table headers (+ id serial primary key, -- which creates a sequence header_id_seq+ label varchar not null default '',+ notes varchar not null default '',+ uid integer default 0 + references users(uid)+ on delete set default+ on update cascade,+ gid integer references groups(gid)+ on delete set default+ on update cascade,+ gr boolean not null,+ gw boolean not null,+ wr boolean not null,+ ww boolean not null,+ created timestamp not null,+ last_modified timestamp not null,+ type object_type_enum not null,+ unique (id,type)+);++-- on insert:+-- * set created and last_modified time stamps+-- * if this is a copy, insert a row into copying_dependencies+-- on update:+-- * update last_modified time stamp+-- * fail if setting gid to a group the uid is not part of+-- on delete:+-- * fail if immutable+++-- In this version, there is no implementation of sequence. They+-- don't exist yet and won't until a later version. The other three+-- types - program, execution, and file - follow:++-- Programs+create type script_language as enum ('perl','r');++create table programs (+ id integer primary key references headers(id)+ on delete cascade on update cascade,+ language script_language default 'perl' not null,+ script varchar default ''+);++-- on insert:+-- * create empty resource request+-- on update:+-- * fail if id is immutable+-- * update last_modified in headers+-- on delete:+-- * fail if id is immutable++create type input_enum as enum ('sequence', 'number', 'string', 'file');++create table program_inputs (+ id integer references programs(id)+ on delete cascade on update cascade,+ label varchar not null,+ type input_enum,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- * add corresponding row to any executions with value null+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- * alter rows on referencing execution rows+-- on delete:+-- * fail if immutable+-- * delete corresponding execution rows++create type program_output as enum ('sequence', 'file');++create table program_outputs (+ id integer references headers(id)+ on delete cascade on update cascade,+ label varchar not null,+ type program_output,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- * insert additional execution output on corresponding executions+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- * update execution outputs as necessary+-- on delete:+-- * fail if immutable+-- * delete execution output++-- Executions+create type execution_status as enum ('waiting','running','complete','failed','dependency_failed');++create table executions (+ id integer references headers(id) on delete cascade on update cascade primary key,+ program integer references programs(id) on delete set null on update cascade,+ status execution_status default 'waiting',+ failed_dependency integer references executions(id)+);++-- on insert:+-- * create empty resource request+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- * update all inputs and outputs if program changed+-- on delete:+-- * fail if immutable++create table execution_inputs (+ id integer references executions(id) on delete cascade on update cascade,+ label varchar not null,+ type input_enum not null,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- * insert row into appropriate type input table+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- * delete row from appropriate type, create in new type+-- on delete:+-- * fail if immutable+-- * delete row from appropriate type table++create table execution_string_inputs (+ id integer,+ label varchar,+ value varchar,+ foreign key (id,label) references execution_inputs (id,label)+ on delete cascade on update cascade,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- on update:+-- * update last_modified in headers+-- * fail if immutable+-- on delete:+-- * fail if immutable++create table execution_number_inputs (+ id integer,+ label varchar,+ value float,+ foreign key (id,label) references execution_inputs (id,label)+ on delete cascade on update cascade,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- on update:+-- * update last_modified in headers+-- * fail if immutable+-- on delete:+-- * fail if immutable++create table execution_object_inputs (+ id integer,+ label varchar,+ value integer,+ value_type object_type_enum,+ foreign key (id,label) references execution_inputs (id,label)+ on delete cascade on update cascade,+ foreign key (value,value_type) references headers (id,type)+ on delete set null on update cascade,+ primary key (id,label)+);++-- on insert:+-- * fail if immutable+-- on update:+-- * update last_modified in headers+-- * fail if immutable+-- on delete:+-- * fail if immutable++create table execution_outputs (+ id integer references executions(id) on delete cascade on update cascade,+ label varchar,+ target integer, + type object_type_enum,+ primary key (id,label),+ foreign key (target,type) references headers(id,type)+ match simple+ on update no action on delete no action+ deferrable +);++-- on insert:+-- * fail if immutable+-- * fail if target,type is not a future+-- * create future of appropriate type and put it in target,type pair+-- on update:+-- * update last_modified in headers+-- * fail if immutable+-- * fail if target,type is not a future+-- * delete previous future if changing target,type+-- on delete:+-- * fail if immutable+-- * delete output object++create table execution_logs (+ id integer references executions(id) + on delete cascade on update cascade,+ log_time timestamp not null,+ log_message varchar not null,+ primary key (id,log_time)+);++-- on insert:+-- * fail if immutable+-- on update:+-- * update last_modified in headers+-- * fail if immutable+-- on delete:+-- * fail if immutable++-- Both programs and executions have the same resource specification+-- fields, so they are extracted into their own table.+create table resource_specification (+ id integer primary key,+ type object_type_enum,+ -- See the LSF User's Manual for the meaning of the resreq+ -- string.+ resreq varchar default '',+ -- In the following fields, null signifies infinity, i.e., no+ -- limit.+ maxcpu integer default null,+ maxfilesize integer default null,+ maxram integer default null,+ maxswap integer default null,+ maxprocs integer default null,+ foreign key (id,type) references headers(id,type)+ on delete cascade on update cascade+);++-- on insert:+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- on delete:+-- * fail if immutable+++-- Files++-- There is a decision to be made when defining files. If we want to+-- have lazy copies of files, we need to divide files into a table+-- serving as the body of the Bein object, which contains a pointer to+-- a reference-counted second table that actually holds the file+-- information.++-- Lazy copying is probably important for sequences, but for files it+-- really isn't. Files are black boxes, and the only time you would+-- want to copy one is when it is immutable and you want to replace it+-- with another file. In this case the lazy copy is simply not+-- helpful. Therefore I am going with the simpler form of a table+-- pointing to a file.++-- Files are stored externally. PostgreSQL's large binary object+-- store is limited to blobs of under 2GB, and Bein will face much+-- larger files. Instead I set a directory in the configuration where+-- the files are to be stored, and keep their file name there in the+-- database instead. Since the database never needs to manipulate+-- files, this is just fine.+create table files (+ id integer references headers(id)+ on delete cascade on update cascade+ primary key,+ user_filename varchar not null,+ content_type varchar not null default 'application/octet-stream',+ stored_as varchar unique not null+);++-- on insert:+-- * fail if stored_as does not refer to a filename that exists+-- on update:+-- * fail if immutable+-- * update last_modified in headers+-- * if changing stored_as, move file to new name, failing if location already occupied+-- on delete:+-- * fail if immutable+-- * delete file from disk+++-- Configuration++-- All of Bein's configuration, what of it there is, is stored as key+-- value pairs in a table called configuration.+create type configuration_key as enum (+ 'file_repository',+ 'scratch_directory',+ 'static_content_directory',+ 'perl_executable',+ 'r_executable',+ 'max_executions',+ 'minion_command',+ 'daemon_port',+ 'minion_port',+ 'http_port',+ 'http_base_url',+ 'template_path',+ 'authentication');++create table configuration (+ key configuration_key primary key,+ value varchar+);++insert into configuration (key,value) values ('file_repository','/tmp/bein_files');+insert into configuration (key,value) values ('scratch_directory','/tmp/bein_scratch');+insert into configuration (key,value) values ('static_content_directory','/home/ross/bein/static');+insert into configuration (key,value) values ('perl_executable','/usr/bin/perl');+insert into configuration (key,value) values ('r_executable','/usr/bin/R');+insert into configuration (key,value) values ('max_executions',1000);+insert into configuration (key,value) values ('minion_command','beinminion');+insert into configuration (key,value) values ('daemon_port','/tmp/.s.BEIND');+insert into configuration (key,value) values ('minion_port','.s.MINION');+insert into configuration (key,value) values ('http_port',8082);+insert into configuration (key,value) values ('http_base_url','');+insert into configuration (key,value) values ('authentication','None');+insert into configuration (key,value) values ('template_path','/home/ross/bein/templates');++create or replace function delete_fails() returns trigger as $$+begin+ raise exception 'Cannot delete configuration keys, only update them.';+end;+$$ language plpgsql;++create trigger delete_fails before delete on configuration for each statement execute procedure delete_fails();++-- Dependencies++-- Objects are used as templates for other objects, inputs for other+-- objects, are created byother objects, etc. These relations+-- determine the mutability of a given object, so we have to store it.+-- Both program and input dependencies can be queried from the+-- execution table, but template and created by must be stored here.+-- In the end, they should be seen uniformly as a unioned view,+-- implemented as 'dependencies'.++create type dependency as enum ('template', 'program', 'input', 'created_by');++create table copying_dependencies (+ object integer references headers(id) on delete cascade on update cascade primary key,+ depends_on integer references headers(id) on delete cascade on update cascade+);++create or replace view dependencies (object,depends_on,dependency_type) as+select object,depends_on,'template' from copying_dependencies union all+select id,value,'input' from execution_object_inputs where value is not null union all+select id,program,'program' from executions where program is not null union all+select target,id,'created_by' from execution_outputs;++create type job_status as enum ('waiting','pending','running','dependency_failed');++create table current_jobs (+ id integer primary key references executions(id) on delete cascade on update cascade,+ status job_status default 'waiting',+ running_as_pid integer,+ scratch_dir text+);++create table jobs_awaiting (+ id integer references current_jobs(id) on delete cascade on update cascade,+ awaited_by integer references current_jobs(id) on delete cascade on update cascade,+ primary key (id,awaited_by)+);++create table sessions (+ key char(20) primary key,+ uid integer references users(uid),+ last_activity timestamp not null+);
+ sql/immutability_test_data.sql view
@@ -0,0 +1,48 @@+-- There are four relations we want to exercise:++-- template, program:++-- The program of a running execution is immutable, which means 501 +-- should be immutable if the rest of the system works. In that case+-- 500, its template, should also be immutable.++-- This is also the test for program dependency.++insert into headers (id,uid,type) values (500,0,'program');+insert into programs (id) values (500);+insert into headers (id,uid,type) values (501,0,'program');+insert into programs (id) values (501);+insert into program_inputs (id,label,type)+values (501,'boris','file');+insert into program_outputs (id,label,type) values (501,'myoutput','file');+insert into copying_dependencies (object,depends_on) values (501,500);+insert into headers (id,uid,type) values (502,0,'execution');+insert into executions (id,program,status)+values (502,501,'running');++-- input:++-- Object with id 503 should be immutable, since it is the input to a running execution.++insert into headers (id,uid,type) values (503,0,'file');+insert into files (id,user_filename,stored_as) +values (503,'hilda','abcdefg');+update execution_object_inputs set value = 503 where id = 502 and label = 'boris';++-- created_by:++-- Now we have a sequence of executions, both running. The first one, 502, should be immutable.++insert into headers (id,type) values (504,'execution');+insert into executions (id,program,status) values (504,501,'running');+insert into execution_inputs (id,label,type) values (504,'boris','file');+insert into execution_outputs (id,label,type)+values (502,'myoutput','file');+-- We immediately grab the new object id again with currval.+update execution_object_inputs set value = currval('headers_id_seq') where id = 504 and label = 'boris';++select id,immutable(id),true as expected from headers where id = 500;+select id,immutable(id),true as expected from headers where id = 501;+select id,immutable(id),true as expected from headers where id = 502;+select id,immutable(id),true as expected from headers where id = 503;+select id,immutable(id),false as expected from headers where id = 504;
+ sql/test_data.sql view
@@ -0,0 +1,44 @@+create or replace function test_data() returns void as $$+declare+ prog integer;+ oid integer;+ i integer;+begin+ select nextval('headers_id_seq') into prog;+ insert into headers (id,uid,type) values (prog,0,'program');+ insert into programs (id,script) values (prog,E'print "Hello, world!\\n";');+ insert into program_inputs (id,label,type) values (prog,'afile','file');+ insert into program_outputs (id,label,type) values (prog,'afile','file');+ for i in 1 .. 10 loop+ select nextval('headers_id_seq') into oid;+ insert into headers (id,uid,type) values (oid,0,'execution');+ insert into executions (id,program) values (oid,prog);+ end loop;+end;+$$ language plpgsql;++insert into users (uid,name,default_gr,default_gw,default_wr,default_ww,auth_secret) values (1,'fred',true,true,true,true,'4557ca660bca40225ba58749d212d65c650d01ed');++insert into group_members(uid,gid) values (1,0);++insert into headers (id,uid,type) values (500,0,'program');+insert into programs (id,script) values (500,E'print "Hello, world!";\n');+insert into headers (id,uid,type) values (501,0,'execution');+insert into executions (id,program) values (501,500);+++insert into headers (type) values ('program');+insert into programs (id,script) values (2,'test');+insert into program_inputs (id,label,type) values (2,'file','file');+insert into program_outputs (id,label,type) values (2,'file','file');++insert into headers (uid,type) values (0,'execution');++insert into executions (id,program,status) values (5,2,'waiting');+insert into executions (id,program,status) values (6,2,'waiting');+insert into executions (id,program,status) values (7,2,'waiting');+insert into executions (id,program,status) values (8,2,'waiting');+insert into executions (id,program,status) values (9,2,'waiting');+++
+ sql/triggers.sql view
@@ -0,0 +1,1012 @@+\set ON_ERROR_STOP++create or replace function add_execution_input() returns trigger as $$+declare+ rec record;+begin+ for rec in select id from executions where program = new.id loop+ insert into execution_inputs(id,label,type) + values (rec.id,new.label,new.type);+ end loop;+ return new;+end;+$$ language plpgsql;++create trigger add_execution_input_on_program_input_insert_trigger before insert+on program_inputs for each row execute procedure add_execution_input();++-- insert into groups values (1,'boris');+-- insert into users values (1,'boris',true,true,true,true,1,false);++-- insert into headers(uid,gid,type,gr,gw,wr,ww,created,last_modified) +-- values (1,1,'program',false,false,false,false,now(),now());+-- insert into headers(uid,gid,type,gr,gw,wr,ww,created,last_modified) +-- values (1,1,'execution',false,false,false,false,now(),now());++-- insert into programs(id,language,script) values (7,'perl','');+-- insert into executions(id,program) values (8,7);++-- insert into program_inputs values (7,'hey','number');++-- create or replace function prevent_manual_setting_of_execution_objects() returns trigger as $$+-- begin+-- if new.target is not null then+-- raise exception 'Cannot manually set execution outputs!';+-- else+-- return new;+-- end if;+-- end;+-- $$ language plpgsql;++-- create trigger aa_prevent_manual_execution_output_setting before insert or update+-- on execution_outputs for each row execute +-- procedure prevent_manual_setting_of_execution_objects();++-- insert into execution_outputs (id,label,target,type) values (8,'meep',null,null);++create or replace function only_program_or_execution_into_resource_specification()+returns trigger as $$+begin+ if new.type = 'program' or new.type = 'execution' then+ return new;+ else+ raise exception 'Resource specifications are invalid for type %', new.type;+ end if;+end;+$$ language plpgsql;++create trigger only_program_or_execution_into_resource_specification +before insert or update on resource_specification for each row execute+procedure only_program_or_execution_into_resource_specification();++-- insert into headers(uid,gid,type,gr,gw,wr,ww,created,last_modified) +-- values (1,1,'file',false,false,false,false,now(),now());+-- This succeeds:+-- insert into resource_specification(id,type) values (7,'program');+-- This fails:+-- insert into resource_specification(id,type) values (9,'file');++create or replace function update_last_modified() returns trigger as $$+begin+ update headers set last_modified = now() where id = new.id;+ return new;+end;+$$ language plpgsql;++create or replace function update_last_modified_on_headers() returns trigger as $$+begin+ new.last_modified = now();+ return new;+end;+$$ language plpgsql;++-- To avoid infinite recursion, we have to handle the headers table case separately+-- and not do an update on it (or the trigger just gets called again forever until+-- we run out of return stack). Instead, we modify the last_modified row in new+-- for headers, and the rest then refer to this trigger.+create trigger update_last_modified before insert or update on headers for each row execute procedure update_last_modified_on_headers();++create trigger update_last_modified before insert or update on programs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on program_inputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on program_outputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on executions for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on execution_inputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on execution_string_inputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on execution_number_inputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on execution_object_inputs for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on execution_outputs for each row execute procedure update_last_modified();++create trigger update_last_modified before insert or update on execution_logs for each row execute procedure update_last_modified();++create trigger update_last_modified before insert or update on resource_specification for each row execute procedure update_last_modified();+create trigger update_last_modified before insert or update on files for each row execute procedure update_last_modified();++create or replace function delete_group_without_members() returns trigger as $$+declare+ num_users integer;+begin+ select count(uid) into num_users from group_members where gid = old.gid;+ if num_users < 1 then+ delete from groups where gid = old.gid;+ end if;+ return old;+end;+$$ language plpgsql;++create trigger delete_empty_group after update or delete on group_members for each row execute procedure delete_group_without_members();++create or replace function set_new_default_group() returns trigger as $$+declare+ newgid integer;+begin+ select gid into newgid from group_members where uid = old.uid and gid != old.gid limit 1;+ if newgid is null then+ raise exception 'Cannot delete the last group a user is part of.';+ else+ update users set default_group = newgid where uid = old.uid;+ return old;+ end if;+end;+$$ language plpgsql;++create trigger new_new_default_group before delete on group_members for each row execute procedure set_new_default_group();++-- insert into groups values (2,'hilda');+-- insert into group_members values (1,2);++-- select * from group_members;+-- select * from groups;++-- delete from group_members where gid = 2;++create or replace function one_user_per_host() returns trigger as $$+declare+ c integer;+begin+ select count(uid) into c from users where auth_secret = new.auth_secret and uid != new.uid;+ if new.auth_type = 'host' and c > 0 then+ raise exception 'There is already a user associated with this host.';+ end if;+ return new;+end;+$$ language plpgsql;++create trigger one_user_per_host before insert or update on users for each row execute procedure one_user_per_host();++create or replace function create_group_for_each_user() returns trigger as $$+declare+ groupid integer; +begin+ set constraints group_members_uid_fkey deferred;+ -- the other case is taken care of by foreign key constraints+ if new.default_group is null then+ groupid := nextval('groups_gid_seq');+ insert into groups(gid,name) values (groupid,new.name);+ insert into group_members (uid,gid) values (new.uid,groupid);+ new.default_group := groupid;+ else+ insert into group_members (uid,gid) values (new.uid,new.default_group);+ end if;+ return new;+end;+$$ language plpgsql;++create trigger add_default_group before insert on users for each row execute procedure create_group_for_each_user();++-- insert into users values (13,'hilda',true,true,true,true,2,false);++create or replace function force_auth_secret() returns trigger as $$+begin+ if (new.auth_type = 'host' or new.auth_type = 'password') and new.auth_secret is null then+ raise exception 'Must specify value (even empty) for host or password based authentication.';+ else+ return new;+ end if;+end;+$$ language plpgsql;+create trigger force_auth_secret before insert or update on users for each row execute procedure force_auth_secret();++create or replace function add_resource_specification() returns trigger as $$+declare+begin+ insert into resource_specification (id,type) values (new.id,cast(tg_argv[0] as object_type_enum));+ return new;+end;+$$ language plpgsql;++create trigger default_resource_spec_executions after insert on executions for each row execute procedure add_resource_specification('execution');++create trigger default_resource_spec_programs after insert on programs for each row execute procedure add_resource_specification('program');++-- insert into headers(uid,gid,type,gr,gw,wr,ww,created,last_modified) +-- values (1,1,'program',false,false,false,false,now(),now());++-- insert into programs (id) values (10);++create or replace function insert_default_future() returns trigger as $$+declare+ new_target integer;+ new_type object_type_enum;+begin+ if new.type is null then+ return old;+ elsif tg_op = 'UPDATE' then+ -- this gets touchy because the call to delete was+ -- cascading an to remove or set null the row,+ -- which called this trigger a second time.+ set constraints execution_outputs_target_fkey deferred;+ if new.type != old.type then+ new_target := insert_future(new.id, new.type);+ new_type := new.type;+ delete from headers where id = old.target;+ new.target := new_target;+ new.type := new_type;+ end if;+ return new;+ elsif tg_op = 'INSERT' then+ new.target := insert_future(new.id, new.type);+ end if;+ return new; +end;+$$ language plpgsql;++create or replace function insert_future(creator_id integer, new_type object_type_enum)+returns integer as $$+declare+ puid integer;+ pgid integer;+ pgr boolean;+ pgw boolean;+ pwr boolean;+ pww boolean;+ new_id integer;+begin+ select uid,gid,gr,gw,wr,ww + into puid,pgid,pgr,pgw,pwr,pww+ from headers where id = creator_id;+ new_id := nextval('headers_id_seq');+ insert into headers (id,uid,gid,gr,gw,wr,ww,type) values+ (new_id,puid,pgid,pgr,pgw,pwr,pww,new_type);+ return new_id;+end;+$$ language plpgsql;+++create trigger create_default_future before insert or update on execution_outputs for each row execute procedure insert_default_future();+++-- insert into execution_outputs (id,label,type) values (502,'meep','file');+-- update execution_outputs set type ='file';+-- select * from execution_outputs;+++++++create or replace function set_created_timestamp() returns trigger as $$+begin+ new.created = now();+ return new;+end;+$$ language plpgsql;++create trigger set_created_timestamp before insert on headers for each row execute procedure set_created_timestamp();++create or replace function add_typed_row() returns trigger as $$+begin+ if new.type = 'sequence' then+ raise exception 'Sequences are not yet implemented.'; + elsif new.type = 'number' then+ insert into execution_number_inputs (id,label,value) + values (new.id,new.label,null);+ elsif new.type = 'string' then+ insert into execution_string_inputs (id,label,value)+ values (new.id,new.label,null);+ elsif new.type = 'file' then+ insert into execution_object_inputs (id,label,value,value_type)+ values (new.id,new.label,null,'file');+ end if;+ return new;+end;+$$ language plpgsql;++create trigger add_typed_row after insert on execution_inputs for each row execute procedure add_typed_row();++-- insert into execution_inputs (id,label,type) values (8,'meep','string');++create or replace function delete_output_future() returns trigger as $$+begin+ delete from headers where id = old.target;+ return old;+end;+$$ language plpgsql;++create trigger delete_output_future after delete on execution_outputs for each row execute procedure delete_output_future();++create or replace function refuse_to_delete_nobody() returns trigger as $$+begin+ if old.name = 'nobody' then+ raise exception 'Cannot delete fallback entry ''nobody''';+ else+ return old;+ end if;+end;+$$ language plpgsql;++create trigger refuse_to_delete_nobody before delete on users for each row execute procedure refuse_to_delete_nobody();+create trigger refuse_to_delete_nobody before delete on groups for each row execute procedure refuse_to_delete_nobody();++create or replace function reset_group_on_owned_objects() returns trigger as $$+declare+ defaultgid integer;+begin+ select default_group into defaultgid from users where uid = old.uid;+ update headers set gid = defaultgid where uid = old.uid;+ return old;+end;+$$ language plpgsql;++create trigger reset_group_on_owned_objects after delete on group_members for each row execute procedure reset_group_on_owned_objects();++create or replace function prevent_deleting_default_group() returns trigger as $$+declare+ num_as_default integer;+begin+ select count(uid) into num_as_default from users where default_group = old.gid;+ if num_as_default > 0 then+ raise exception 'Group is default for at least one user; cannot delete.';+ end if;+ return old;+end;+$$ language plpgsql;++create trigger prevent_deleting_default_group before delete on groups for each row execute procedure prevent_deleting_default_group();++-- This turns out not to be the desired behavior:+-- create or replace function prevent_user_setting_foreign_group() returns trigger as $$+-- declare+-- res integer;+-- begin+-- select uid into res from group_members where uid = new.uid and gid = new.gid;+-- if res is null then+-- raise exception 'UID % is not part of GID %; cannot set GID on object.', +-- new.uid, new.gid;+-- else+-- return new;+-- end if;+-- end;+-- $$ language plpgsql;++-- create trigger prevent_user_setting_foreign_group before update or insert on headers for each row execute procedure prevent_user_setting_foreign_group();++create or replace function impose_default_permissions_and_group() returns trigger as $$+declare+ user_record record;+begin+ select default_gr,default_gw,default_wr,default_ww,default_group into user_record+ from users where uid = new.uid;+ if new.gr is null then+ new.gr := user_record.default_gr;+ end if;+ if new.gw is null then+ new.gw := user_record.default_gw;+ end if;+ if new.wr is null then+ new.wr := user_record.default_wr;+ end if;+ if new.ww is null then+ new.ww := user_record.default_ww;+ end if;+ if new.gid is null then+ new.gid := user_record.default_group;+ end if;+ return new;+end;+$$ language plpgsql;++create trigger impose_default_permissions_and_group before insert on headers for each row execute procedure impose_default_permissions_and_group();++-- insert into headers (uid,type) values (11,'program');++create or replace function immutable(tid integer) returns boolean as $$+declare+ dep_id integer;+ num_nonwaiting integer;+ obj_type object_type_enum;+begin+ if tid is null then+ return false;+ end if;+ for dep_id in select object from copying_dependencies where depends_on = tid loop+ if immutable(dep_id) then+ return true;+ end if;+ end loop;+ select type into obj_type from headers where id = tid;+ if obj_type::text = 'program' then+ select count(id) into num_nonwaiting from executions + where program = tid and status != 'waiting';+ if num_nonwaiting > 0 then+ return true;+ end if;+ elsif obj_type::text = 'file' or obj_type::text = 'sequence' then+ select count(a.id) into num_nonwaiting + from execution_object_inputs as a+ join executions as b on a.id = b.id+ where b.status != 'waiting' and a.value = tid;+ if num_nonwaiting > 0 then+ return true;+ end if;+ elsif obj_type::text = 'execution' then+ for dep_id in select target from execution_outputs where id = tid loop+ if immutable(dep_id) then+ return true;+ end if;+ end loop;+ end if;+ return false;+end;+$$ language plpgsql;++create or replace function fail_if_immutable() returns trigger as $$+begin+ if tg_op = 'DELETE' then+ if immutable(old.id) then+ raise exception 'Cannot alter immutable object.';+ else + return old;+ end if;+ else+ if immutable(new.id) then+ raise exception 'Cannot alter immutable object.';+ else+ return new;+ end if;+ end if;+end;+$$ language plpgsql;++create trigger immutability before delete on headers +for each row execute procedure fail_if_immutable('old');++create trigger immutability_u before update or delete on programs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on program_inputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on program_outputs+for each row execute procedure fail_if_immutable();++create trigger immutability_u before update or delete on executions+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_inputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_string_inputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_number_inputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_object_inputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_outputs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before insert or update or delete on execution_logs+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before update or delete on resource_specification+for each row execute procedure fail_if_immutable();++create trigger immutability_iu before update or delete on files+for each row execute procedure fail_if_immutable();+++-- Copy function++create or replace function copy(tid integer, new_owner integer) returns integer as $$+declare+ r record;+ new_id integer;+ new_filename text;+begin+ select label,notes,uid,gid,gr,gw,wr,ww,type into r+ from headers where id = tid;+ new_id := nextval('headers_id_seq');+ if new_owner is null or r.uid = new_owner then+ insert into headers (id,label,notes,uid,gid,gr,gw,wr,ww,type)+ values (new_id, r.label, r.notes, r.uid, r.gid,+ r.gr, r.gw, r.wr, r.ww, r.type);+ else+ insert into headers (id, label,notes,uid,type)+ values (new_id, r.label, r.notes, new_owner, r.type);+ end if;+ if not is_future(tid) then+ if r.type :: text = 'program' then+ select language,script into r from programs where id = tid;+ insert into programs (id,language,script) + values (new_id, r.language, r.script);+ for r in select label,type from program_inputs where id = tid loop+ insert into program_inputs (id,label,type) values (new_id,r.label,r.type);+ end loop;+ for r in select label,type from program_outputs where id = tid loop+ insert into program_outputs (id,label,type) + values (new_id,r.label,r.type);+ end loop;+ elsif r.type :: text = 'execution' then+ select program into r from executions where id = tid;+ insert into executions (id,program) values (new_id,r.program);+ for r in select label,type from execution_inputs where id = tid loop+ insert into execution_inputs (id,label,type)+ values (new_id,r.label,r.type);+ end loop;+ for r in select label,value from execution_string_inputs where id = tid loop+ raise notice 'String input: %', r;+ update execution_string_inputs set value = r.value+ where id = new_id and label = r.label;+ end loop;+ for r in select label,value from execution_number_inputs where id = tid loop+ update execution_number_inputs set value = r.value+ where id = new_id and label = r.label;+ end loop;+ for r in select label,type from execution_outputs+ where id = tid loop+ insert into execution_outputs (id,label,type)+ values (new_id, r.label, r.type);+ end loop;+ -- Logs are not copied.+ elsif r.type :: text = 'sequence' then+ raise warning 'Sequence type not implemented yet; no body to copy.';+ elsif r.type :: text = 'file' then+ new_filename := unique_name(in_repository(''),50);+ select user_filename,stored_as into r from files where id = tid;+ perform copy_file(in_repository(r.stored_as), in_repository(new_filename));+ insert into files (id,user_filename,stored_as)+ values (new_id,r.user_filename,new_filename);+ end if;+ end if;+ insert into copying_dependencies (object,depends_on) values (new_id,tid);+ return new_id;+end;+$$ language plpgsql;++++create or replace function update_execution_inputs() returns trigger as $$+declare+ r record;+begin+ for r in select id from executions where program = new.id loop+ if old.label != new.label then+ update execution_inputs set label = new.label where id = r.id;+ end if;+ if old.type != new.type then+ update execution_inputs set type = new.type where id = r.id;+ end if;+ end loop;+ return new;+end;+$$ language plpgsql;++create trigger update_execution_inputs before update on program_inputs+for each row execute procedure update_execution_inputs();++create or replace function update_typed_row() returns trigger as $$+begin+ if new.type != old.type then+ if old.type :: text = 'number' then+ delete from execution_number_inputs where id = old.id;+ elsif old.type :: text = 'string' then+ delete from execution_string_inputs where id = old.id;+ else+ delete from execution_object_inputs where id = old.id;+ end if;+ if new.type :: text = 'number' then+ insert into execution_number_inputs (id,label,value)+ values (new.id,new.label,null);+ elsif new.type :: text = 'string' then+ insert into execution_string_inputs (id,label,value)+ values (new.id,new.label,null);+ else+ insert into execution_object_inputs (id,label,value,value_type)+ values (new.id,new.label,null,cast(new.type :: text as object_type_enum));+ end if;+ end if;+ return new;+end;+$$ language plpgsql;++create trigger updated_type_row before update on execution_inputs+for each row execute procedure update_typed_row();++create or replace function delete_typed_row() returns trigger as $$+begin+ if old.type :: text = 'string' then+ delete from execution_string_inputs where id = old.id and label = old.label;+ elsif old.type :: text = 'number' then+ delete from execution_number_inputs where id = old.id and label = old.label;+ else+ delete from execution_object_inputs where id = old.id and label = old.label;+ end if;+ return old;+end;+$$ language plpgsql;++create trigger delete_typed_row after delete on execution_inputs+for each row execute procedure delete_typed_row();++create or replace function insert_execution_output() returns trigger as $$+declare+ r integer;+begin+ for r in select id from executions where program = new.id loop+ insert into execution_outputs (id,label,type)+ values (r, new.label, cast(cast(new.type as text) as object_type_enum));+ end loop;+ return new;+end;+$$ language plpgsql;++create trigger insert_execution_output before insert on program_outputs+for each row execute procedure insert_execution_output();++create or replace function delete_execution_inputs() returns trigger as $$+declare+ r integer;+begin+ for r in select id from executions where program = old.id loop+ delete from execution_inputs where id = r and label = old.label;+ end loop;+ return old;+end;+$$ language plpgsql;++create trigger delete_execution_inputs after delete on program_inputs+for each row execute procedure delete_execution_inputs();++create or replace function delete_execution_outputs() returns trigger as $$+declare+ r integer;+begin+ for r in select id from executions where program = old.id loop+ delete from execution_outputs where id = r and label = old.label;+ end loop;+ return old;+end;+$$ language plpgsql;++create trigger delete_execution_outputs after delete on program_outputs+for each row execute procedure delete_execution_outputs();++create or replace function update_execution_outputs() returns trigger as $$+declare+ r integer;+begin+ for r in select id from executions where program = old.id loop+ update execution_outputs set label = new.label, + type = cast(cast(new.type as text) as object_type_enum)+ where id = r and label = old.label;+ end loop;+ return new;+end;+$$ language plpgsql;++create trigger update_execution_outputs after update on program_outputs+for each row execute procedure update_execution_outputs();++create or replace function fill_execution_io(ex integer) returns void as $$+declare+ prog integer;+ lbl text;+ typev input_enum;+ typeq object_type_enum;+begin+ select program into prog from executions where id = ex;+ delete from execution_inputs where id = ex;+ delete from execution_outputs where id = ex;+ for lbl,typev in select label,type from program_inputs where id = prog loop+ insert into execution_inputs (id,label,type) values (ex,lbl,typev);+ end loop;+ for lbl,typeq in select label,type from program_outputs where id = prog loop+ insert into execution_outputs (id,label,type) + values (ex, lbl, cast(cast(typeq as text) as object_type_enum));+ end loop;+end;+$$ language plpgsql;++create or replace function fill_on_insert() returns trigger as $$+begin+ if new.program is not null then+ perform fill_execution_io(new.id);+ end if;+ return new;+end;+$$ language plpgsql;++create or replace function fill_on_update() returns trigger as $$+begin+ if new.program != old.program and new.program is not null then+ perform fill_execution_io(new.id);+ end if;+ return new;+end;+$$ language plpgsql;++create trigger update_io after update on executions for each row execute procedure fill_on_update();+create trigger insert_io after insert on executions for each row execute procedure fill_on_insert();+++create or replace function no_default_foreign_group() returns trigger as $$+declare+ r record;+ group_name varchar;+begin+ select uid into r from group_members where uid = new.uid and gid = new.default_group;+ if r is null then+ select name into group_name from groups where gid = new.default_group;+ raise exception 'User % is not part of group %; cannot set it as default', + new.name, group_name;+ else+ return new;+ end if;+end;+$$ language plpgsql;++create trigger no_default_foreign_group before insert or update on users+for each row execute procedure no_default_foreign_group();++create or replace function is_future(tid integer) returns boolean as $$+declare+ r integer;+ objtype object_type_enum;+begin+ select type into objtype from headers where id = tid;+ if objtype = 'sequence' then+ raise exception 'Sequences are not implemented yet.';+ elsif objtype = 'file' then+ select id into r from files where id = tid;+ elsif objtype = 'program' then+ select id into r from programs where id = tid;+ elsif objtype = 'execution' then+ select id into r from executions where id = tid;+ end if;+ return r is null;+end;+$$ language plpgsql;++-- File functions++create or replace function in_repository(name text) returns text as $$+declare+ filedir text;+begin+ select value into filedir from configuration where key = 'file_repository';+ return join_path(filedir,name);+end;+$$ language plpgsql;++create or replace function assert_file_exists() returns trigger as $$+begin+ if simple_file_exists(in_repository(new.stored_as)) then+ return new;+ else+ raise exception 'Target file % does not exist.', new.stored_as;+ end if;+end;+$$ language plpgsql;++create trigger assert_file_exists before insert or update on files+for each row execute procedure assert_file_exists();++-- insert into files (id,user_filename,stored_as)+-- values (35,'boris','/tmp/hilda');++-- update files set stored_as = '/tmp/asdfasdf';++create or replace function move_stored_file() returns trigger as $$+begin+ perform move_file(in_repository(old.stored_as), in_repository(new.stored_as));+ return new;+end;+$$ language plpgsql;++create trigger aa_move_stored_file before update on files+for each row execute procedure move_stored_file();++create or replace function delete_repository_file() returns trigger as $$+begin+ perform unlink_file(in_repository(old.stored_as));+ return old;+end;+$$ language plpgsql;++create trigger delete_repository_file after delete on files+for each row execute procedure delete_repository_file();++create or replace function import(filepath text, targetobjid integer, targetowner integer, import_type char(4)) +returns integer as $$+declare+ objid integer;+ new_filename text;+ owner integer;+begin+ if targetobjid is null then+ objid := nextval('headers_id_seq');+ else+ objid := targetobjid;+ end if;+ if targetowner is null then+ owner := 0;+ else+ owner := targetowner;+ end if;+ new_filename := unique_name(in_repository(''),50);+ if import_type = 'copy' then+ perform copy_file(filepath, in_repository(new_filename));+ elsif import_type = 'move' then+ perform move_file(filepath, in_repository(new_filename));+ else+ raise exception 'Invalid import mode % (must be ''copy'' or ''move'').', import_mode;+ end if;+ insert into headers (id,uid,type) values (objid,owner,'file');+ insert into files (id,user_filename,stored_as)+ values (objid,path_basename(filepath),new_filename);+ return objid;+end;+$$ language plpgsql;++create or replace function export(objid integer, targetpath text, targetfile text, export_mode char(4))+returns void as $$+declare+ target text;+ r record;+begin+ select id,user_filename,stored_as into r from files where id = objid;+ if targetfile is null then+ target := join_path(targetpath,r.stored_as);+ else+ target := join_path(targetpath,targetfile);+ end if;+ if export_mode = 'copy' then+ perform copy_file(in_repository(r.stored_as),target);+ elsif export_mode = 'link' then+ perform link_file(in_repository(r.stored_as),target);+ perform chmod_file(in_repository(r.stored_as), 7, 4, 4);+ else+ raise exception 'Invalid export mode % (must be ''copy'' or ''link'').', + export_mode;+ end if; +end;+$$ language plpgsql;++create or replace function is_valid_auth(a text) returns boolean as $$+begin+ if a = 'None' or a = 'SameUser' or a ~ E'User \\d+' then+ return true;+ else+ return false;+ end if;+end;+$$ language plpgsql;++create or replace function valid_authentication() returns trigger as $$+begin+ if new.key = 'authentication' and not(is_valid_auth(new.value)) then+ raise exception 'Invalid value for authentication.';+ else + return new;+ end if;+end;+$$ language plpgsql;+++create trigger fva before update on configuration for each row execute procedure valid_authentication();++create or replace function complete_job(job integer) returns void as $$+declare+ d integer;+begin+ for d in select awaited_by from jobs_awaiting where id = job loop+ update current_jobs set status = 'pending' where id = d;+ end loop;+ delete from jobs_awaiting where id = job;+ delete from current_jobs where id = job;+end;+$$ language plpgsql;++create or replace function fail_job(job integer) returns void as $$+declare+ d integer;+begin+ for d in select awaited_by from jobs_awaiting where id = job LOOP+ update executions set (status,failed_dependency) = ('dependency_failed',job) where id = d;+ end loop;+ delete from current_jobs where id = job;+end;+$$ language plpgsql;++create or replace function end_job_trigger() returns trigger as $$+begin+ if new.program is null then+ return old;+ elsif new.status = 'complete' then+ perform complete_job(new.id);+ elsif new.status = 'failed' or new.status = 'dependency_failed' then+ perform fail_job(new.id);+ end if;+ return new;+end;+$$ language plpgsql;++create trigger update_joblist before update on executions for each row execute procedure end_job_trigger();++create or replace view execution_dependencies as+select distinct n.id as id, o.id as depends_on+from execution_object_inputs as n +left join execution_outputs as o on n.value = o.target;++create or replace function run(ex integer) returns void as $$+declare+ ndeps integer;+ dex integer;+ started integer;+begin+ select count(depends_on) into ndeps from execution_dependencies where id = ex;+ select count(id) into started from current_jobs where id = ex;+ if ndeps > 0 then+ if started = 0 then insert into current_jobs (id,status) values (ex,'waiting'); end if;+ for dex in select depends_on from execution_dependencies where id = ex loop+ perform run(dex);+ insert into jobs_awaiting (id,awaited_by) values (dex,ex);+ end loop;+ else+ if started = 0 then insert into current_jobs (id,status) values (ex,'pending'); end if;+ end if;+end;+$$ language plpgsql;++create or replace function new_session(userid integer) returns char(20) as $$+declare+ s char(20);+begin+ loop+ select unique_name(20) into s;+ if (select count(key) from sessions where key=s) = 0 then+ insert into sessions(key,uid,last_activity) values (s,userid,now());+ return s;+ end if;+ end loop;+end;+$$ language plpgsql;++create or replace function touch_session(char(20)) returns void as $$+ update sessions set last_activity = now() where key = $1;+$$ language sql;++create or replace function remove_expired_sessions() returns void as $$+ delete from sessions where now() - last_activity > interval '30' minute;+$$ language sql;++create or replace function create_group(newname text,username integer) returns integer as $$+declare+ newgid integer;+begin+ if (select gid from groups where name = newname) is not null then+ return -1;+ else+ newgid := nextval('groups_gid_seq');+ insert into groups (gid,name) values (newgid,newname);+ insert into group_members(uid,gid) values (username,newgid);+ return newgid;+ end if;+end;+$$ language plpgsql;++create or replace function new_object(type_to_create object_type_enum, new_owner_id integer) returns integer as $$+declare+ newid integer;+begin+ select nextval('headers_id_seq') into newid;+ insert into headers(id,uid,type) values (newid,new_owner_id,type_to_create);+ if type_to_create = 'program' then+ insert into programs(id) values (newid);+ elsif type_to_create = 'execution' then+ insert into executions(id) values (newid);+ elsif type_to_create = 'sequence' then+ raise exception 'Sequences are not yet implemented; cannot create one.';+ end if;+ return newid;+end;+$$ language plpgsql;++create or replace view executions_forcing_immutability(file_id,execution_id,execution_label) as+select inp.value as file_id, inp.id as execution_id, hd.label as execution_label+from execution_object_inputs as inp+left join executions as ex on inp.id = ex.id+left join headers as hd on hd.id = inp.id+where ex.status != 'waiting' and inp.value is not null;
+ sql/untrusted_functions.sql view
@@ -0,0 +1,64 @@+\set ON_ERROR_STOP++create or replace function simple_file_exists(filename text) returns boolean as $$+ import os.path+ return os.path.isfile(filename)+$$ language plpythonu;++create or replace function move_file(source text, target text) returns void as $$+ import shutil+ shutil.move(source,target)+$$ language plpythonu;++create or replace function copy_file(source text, target text) returns void as $$+ import shutil+ shutil.copy(source,target)+$$ language plpythonu;++create or replace function link_file(source text, target text) returns void as $$+ import os+ os.symlink(source,target)+$$ language plpythonu;++create or replace function unlink_file(filename text) returns void as $$+ import os+ os.unlink(filename)+$$ language plpythonu;++create or replace function chmod_file+(filename text, ownerp integer, groupp integer, worldp integer)+returns void as $$+ import os+ os.chmod(filename, 0100*ownerp + 010*groupp + worldp)+$$ language plpythonu;++create or replace function join_path(path1 text, path2 text) returns text as $$+ import os.path+ return os.path.join(path1,path2)+$$ language plpythonu; ++create or replace function unique_name(pathname text, len integer) returns text as $$+ import os.path+ import random+ while True:+ s = ''+ for i in range(len):+ s += random.choice('ABCDEFGHIJKLMNOPQRSTUVWZYZabcdefghijklmnopqrstuvwxyz0123456789')+ if not(os.path.exists(os.path.join(pathname,s))):+ return s+$$ language plpythonu;++create or replace function unique_name(len integer) returns text as $$+ import os.path+ import random+ s = ''+ for i in range(len):+ s += random.choice('ABCDEFGHIJKLMNOPQRSTUVWZYZabcdefghijklmnopqrstuvwxyz0123456789')+ return s+$$ language plpythonu;++create or replace function path_basename (filepath text) returns text as $$+ import os.path+ return os.path.basename(filepath)+$$ language plpythonu;+
+ sql/utility_functions.sql view
@@ -0,0 +1,21 @@+\set ON_ERROR_STOP++create or replace view null_inputs as+select sin.id as id,+ (sin.sin is null or sin.sin) and + (nin.nin is null or nin.nin) and + (oin.oin is null or oin.oin) as no_null_inputs+from (select id from executions) as ex+left join (select id,every(value is not null) as sin from execution_string_inputs group by id) as sin on ex.id = sin.id+left join (select id,every(value is not null) as nin from execution_number_inputs group by id) as nin on ex.id = nin.id+left join (select id,every(value is not null) as oin from execution_object_inputs group by id) as oin on ex.id = oin.id;++create or replace view runnable as+select ex.id as id,+ not(is_future(ex.id)) as not_future,+ ex.status = 'waiting' as is_waiting,+ pr.script != '' as nonempty_script,+ ni.no_null_inputs as no_null_inputs+from executions as ex+left join programs as pr on ex.program = pr.id+left join null_inputs as ni on ex.id = ni.id;
+ static/default.css view
@@ -0,0 +1,393 @@+/* Confirmed use */+body {+ background: #ffffff;+ color: #000000;+ margin: 0.3em;+}++div#footer {+ text-align: center;+ margin: 0 auto;+ border-top: 1px solid black;+ max-width: 35em;+ margin-top: 2em;+}++.main-panel {+ max-width: 40em;+ margin: 0 auto;+}++div#object-list {+ border: 1px solid grey;+}++div.compact {+ display: block;+ border-bottom: 1px solid grey;+ width: 100%;+}++div.compact > div.left {+ display: inline-block;+ vertical-align: top;+ margin-left: 0;+ margin-right: 1%;+ padding-left: 0;+ padding-right: 0;+ width: 40%;+}++div.left > p.title {+ font-family: serif;+ font-weight: bold;+ color: black;+ font-size: 1em;+ margin-top: 0.2em;+}++div.left > p {+ font-family: sans-serif;+ color: #555555;+ font-size: 0.8em;+ margin-top: -0.9em;+}++p.title > a {+ text-decoration: none;+ color: black;+}++p.title > a:hover {+ text-decoration: underline;+}++div.compact > div.right {+ display: inline-block;+ vertical-align: top;+ margin-left: 1%;+ margin-right: 0;+ padding-left: 0;+ padding-right: 0;+ width: 58%;+}+++h1 {+ font-family: sans-serif;+ text-align: center;+ color: black;+ font-size: 2.5em;+ padding: 1em;+ padding-bottom: 0.7em;+ padding-top: 0.7em;+ margin-bottom: 0;+}++h1.title-with-subtitle {+ padding-bottom: 0;+}++h1.subtitle {+ color: #777777;+ font-size: 2em;+ margin-top: 0;+ line-height: 0.8em;+ padding-top: 0;+ padding-bottom: 0.7em;+}++p#header-links {+ font-family: serif;+ position: absolute;+ top: 0;+ right: 0;+ margin-top: 0.2em;+ margin-right: 0.2em;+}++p#object-list-new-line {+ margin: 0;+ line-height: 1em;+ padding: 0;+ text-align: center;+ background: #cccccc;+ padding: 0.2em;+}++p#object-list-new-line > a {+ display: inline-block;+ background: #aaaaaa;+ padding-bottom: 0.3em;+ padding-top: 0.3em;+ padding-left: 2%;+ padding-right: 2%;+ margin: 0.1em;+ text-decoration: none;+ text-align: center;+ color: black;+ width: 25%;+}++p#object-list-new-line > a:hover {+ background: #eeeeee;+}++.inline-label {+ width: 23%;+ float: left;+ text-align: right;+ margin-right: 2.5%;+ margin-top: 0;+ display: block;+ font-weight: bold;+}+++++/* Old */+++++/*++++++++div#start-object-list {+ margin: 0 auto;+ max-width: 40em;+}++++input.object-list-search-box {+ width: 100%;+ font-size: 1.5em;+ font-family: serif;+ margin-right: 0;+ padding-right: 0;+}+++a.object-list-header-new {+ display: inline-block;+ width: 9%;+ font-family: serif;+ font-size: 1.5em;+ margin: 0;+ padding-left: 0;+ text-align: center;+ vertical-align: center;+}++a:hover.object-list-header-new {+ background: #eeeeee;+}++div.object-list-body {+ border: 1px solid grey;++}++div.object-list-external {+ background: #dddddd;+ margin: 0;+ padding-top: 0.1em;+ padding-bottom: 0.1em;+ margin-bottom: 0.2em;+}++div.object-list-external-header {+ margin-bottom: 0.2em;+ font-family: sans-serif;+}++div.object-list-external-entries {+ margin-left: 1em;+}++div.object-list-external-footer {+ text-align: right;+}++div.object-list-entry {+ display: block;+ border-bottom: 1px solid grey;+ width: 100%;+}++div.object-list-entry-left {+ display: inline-block;+ width: 30%;+ vertical-align: top;+}++div.object-list-entry-right {+ display: inline-block;+ width: 60%;+ vertical-align: top;+}++.object_control {+ font-family: sans-serif;+ color: red;+ text-decoration: underline;+ font-size: 0.8em;+}++div.object-list-footer {+ text-align: right;+ font-family: sans-serif;+}++span.hilight {+ color: #ff0000;+ font-family: sans-serif;+ font-size: 0.9em;+}++p.entry_head {+ font-family: serif;+ font-weight: bold;+ color: black;+}++p.entry_subhead {+ font-family: sans-serif;+ color: #555555;+ font-size: 0.8em;+ margin-top: -0.9em;+}+++++.dropdown_panel {+ padding-top: 0.6em;+ padding-bottom: 1em;+ padding-left: 2em;+ margin-right: 0em;+ border-bottom: 0.2em solid grey;+ border-left: 0.5em solid grey;+ border-top: 1px solid grey;+ font-size: 1.5em;+}++.new_object_cancel_button {+ display: block;+ max-width: 48%;+}++.new_object_create_button {+ display: block;+ float: right;+ max-width: 48%;+}++.new_object_radio_buttons {+ margin-left: 3.5em;+ margin-bottom: 1em;+}+++.label-box {+ width: 82%;+}++.notes-box {+ width: 82%;+ height: 7em;+}++.mock-box {+ width: 100%;+ height: 7em;+}++.left_button {+ display: block;+ max-width: 48%;+ margin-top: 0;+}++.right_button {+ display: block;+ float: right;+ max-width: 48%;+ margin-top: 0;+}++.group_container {+ display: inline-block;+ width: 82%;+}++a.undecorated_link {+ text-decoration: none;+ color: black;+}++div.twopane {+ display: block;+ border-bottom: 1px solid grey;+ width: 100%;+}++div.threepane {+ display: block;+ border-bottom: 1px solid grey;+ width: 100%;+}++div.threepane_left {+ display: inline-block;+ vertical-align: top;+ width: 29%;+ margin-left: 0;+ margin-right: 1%;+ padding-left: 0;+ padding-right: 0;+}++div.threepane_middle {+ display: inline-block;+ width: 57%;+ vertical-align: top;+ margin-left: 1%;+ margin-right: 1%;+ padding-left: 0;+ padding-right: 0;+}++div.threepane_right {+ display: inline-block;+ vertical-align: top;+ width: 10%;+ margin-left: 1%;+ margin-right: 0;+ padding-left: 0;+ padding-right: 0;+}++.twopane_left > a:link {+ text-decoration: none;+}++.twopane_left > a:hover {+ text-decoration: underline;++.threepane_left > a:link {+ text-decoration: none;+}++.threepane_left > a:hover {+ text-decoration: underline;+}++*/