{-# 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 = do bu <- lift $ configField http_base_url bp <- lift $ configField http_base_path return $ joinURL bu bp 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