bein-0.3.1: Bein/Web/Commands/Local.hs
{-# 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