implementation module iTasks.API.Extensions.User import iTasks import Text import qualified Data.Map as DM gText{|User|} _ val = [maybe "" toString val] derive JSONEncode User, UserConstraint derive JSONDecode User, UserConstraint derive gDefault User, UserConstraint derive gEq User, UserConstraint derive gText UserConstraint derive gEditor User, UserConstraint derive gEditMeta User, UserConstraint derive gUpdate User, UserConstraint derive gVerify User, UserConstraint instance toString User where toString (SystemUser) = "System" toString (AnonymousUser _) = "Anonymous" toString (AuthenticatedUser uid _ title) = maybe uid (\t -> t +++ " <" +++ uid +++ ">") title instance == User where (==) (SystemUser) (SystemUser) = True (==) (AnonymousUser a) (AnonymousUser b) = a == b (==) (AuthenticatedUser a _ _) (AuthenticatedUser b _ _) = a == b (==) _ _ = False instance < User where (<) (AnonymousUser a) (AnonymousUser b) = a < b (<) (AuthenticatedUser a _ _) (AuthenticatedUser b _ _) = a < b (<) _ _ = False instance toUserConstraint UserConstraint where toUserConstraint r = r toTitle _ = "Untitled" instance toUserConstraint User where toUserConstraint (SystemUser) = AnyUser toUserConstraint (AnonymousUser _) = AnyUser toUserConstraint (AuthenticatedUser uid _ _) = UserWithId uid toTitle _ = "Untitled" instance toUserConstraint UserId where toUserConstraint userId = UserWithId userId toTitle _ = "Untitled" instance toUserConstraint (a,b) | toUserConstraint a & toString b where toUserConstraint (a,b) = toUserConstraint a toTitle (a,b) = toString b instance toString UserConstraint where toString AnyUser = "Anybody" toString (UserWithId uid) = uid toString (UserWithRole role) = "Any user with role " +++ role //* Authentication JSONEncode{|Username|} _ (Username u) = [JSONString u] JSONDecode{|Username|} _ [JSONString u:c] = (Just (Username u),c) JSONDecode{|Username|} _ c = (Nothing,c) gEditor{|Username|} dp vv=:(val,mask,ver) meta vst=:{VSt|taskId,disabled} | disabled # val = checkMask mask val = (NormalEditor [(UIViewString defaultSizeOpts {UIViewOpts|value = fmap (\(Username v) -> v) val},'DM'.newMap)],vst) | otherwise # value = checkMaskValue mask ((\(Username v) -> v) val) = (NormalEditor [(UIEditString defaultHSizeOpts {UIEditOpts|taskId=taskId,editorId=editorId dp,value=value},editorAttributes vv meta)],vst) gUpdate{|Username|} target upd val iworld = basicUpdateSimple target upd val iworld gVerify{|Username|} mv options = simpleVerify mv options gEditMeta{|Username|} _ = [{label=Nothing,hint=Just "Enter a username",unit=Nothing}] derive gDefault Username derive gEq Username derive gText Username instance toString Username where toString (Username u) = u instance == Username where (==) (Username a) (Username b) = a == b instance < Username where (<) (Username a) (Username b) = a < b JSONEncode{|Password|} _ (Password p) = [JSONString p] JSONDecode{|Password|} _ [JSONString p:c] = (Just (Password p),c) JSONDecode{|Password|} _ c = (Nothing,c) gText{|Password|} AsHeader _ = [""] gText{|Password|} _ _ = ["********"] gEditor{|Password|} dp vv=:(val,mask,ver) meta vst=:{VSt|taskId,disabled} | disabled = (NormalEditor [(UIViewString defaultSizeOpts {UIViewOpts|value = Just "********"},'DM'.newMap)],vst) | otherwise # value = checkMaskValue mask ((\(Password v) -> v) val) = (NormalEditor [(UIEditPassword defaultHSizeOpts {UIEditOpts|taskId=taskId,editorId=editorId dp,value=value},editorAttributes vv meta)],vst) gUpdate{|Password|} target upd val iworld = basicUpdateSimple target upd val iworld gVerify{|Password|} mv options = simpleVerify mv options gEditMeta{|Password|} _ = [{label=Nothing,hint=Just "Enter a password",unit=Nothing}] derive gDefault Password derive gEq Password instance toString Password where toString (Password p) = p instance == Password where (==) (Password a) (Password b) = a == b instance < Password where (<) (Password a) (Password b) = a < b derive class iTask Credentials currentUser :: RWShared () User User currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) currentTaskInstanceAttributes where notify _ _ _ = const True taskInstanceUser :: RWShared InstanceNo User User taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) taskInstanceAttributesByNo where notify _ _ _ = const True userFromAttr :: a TaskAttributes -> MaybeError TaskException User userFromAttr _ attr = case 'DM'.get "auth-user" attr of Just userId = Ok (AuthenticatedUser userId (maybe [] (split ",") ('DM'.get "auth-roles" attr)) ('DM'.get "auth-title" attr)) _ = case 'DM'.get "session" attr of Just session = Ok (AnonymousUser session) _ = Ok SystemUser userToAttr :: a TaskAttributes User -> MaybeError TaskException (Maybe TaskAttributes) userToAttr _ attr (AuthenticatedUser userId userRoles userTitle) //Update user properties # attr = 'DM'.put "auth-user" userId attr # attr = if (isEmpty userRoles) ('DM'.del "auth-roles" attr) ('DM'.put "auth-roles" (join "," userRoles) attr) # attr = maybe ('DM'.del "auth-title" attr) (\title -> 'DM'.put "auth-title" title attr) userTitle = Ok (Just attr) userToAttr _ attr _ //Remove user properties # attr = 'DM'.del "auth-user" attr # attr = 'DM'.del "auth-roles" attr # attr = 'DM'.del "auth-title" attr = Ok (Just attr) processesForCurrentUser :: ReadOnlyShared [TaskListItem Void] processesForCurrentUser = mapRead readPrj (currentProcesses >+| currentUser) where readPrj (items,user) = filter (forWorker user) items forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of Just uid1 = case user of (AuthenticatedUser uid2 _ _) = uid1 == uid2 _ = False Nothing = case 'DM'.get "role" attributes of Just role = case user of (AuthenticatedUser _ roles _) = isMember role roles _ = False Nothing = True workOn :: !TaskId -> Task AttachmentStatus workOn taskId=:(TaskId no _) //Copy authentication attributes from current instance = get currentUser >>- \user -> set user (sdsFocus no taskInstanceUser) //Attach the instance >>| attach taskId /* * Alters the evaluation functions of a task in such a way * that before evaluation the currentUser field in iworld is set to * the given user, and restored afterwards. */ workAs :: !User !(Task a) -> Task a | iTask a workAs asUser task = get currentUser >>- \prevUser -> set asUser currentUser >>| task >>- \tvalue -> //TODO: What if the wrapped task never becomes stable? And what if the composition is terminated early because of a step? set prevUser currentUser @! tvalue /* * When a task is assigned to a user a synchronous task instance process is created. * It is created once and loaded and evaluated on later runs. */ assign :: !TaskAttributes !(Task a) -> Task a | iTask a assign attr task = parallel [(Embedded, \s -> processControl s),(Detached attr False, \_ -> task)] [] @? result where processControl tlist = viewSharedInformation () [ViewWith toView] (sdsFocus filter tlist) @? const NoValue where filter = {TaskListFilter|onlySelf=False,onlyTaskId = Nothing, onlyIndex = Just [1] ,includeValue=False,includeAttributes=True,includeProgress=True} toView (_,[{TaskListItem|progress=Just p,attributes}:_]) = { assignedTo = toSingleLineText (case ('DM'.get "user" attributes, 'DM'.get "role" attributes) of (Just u, _) -> Just (toString u) (_, Just r) -> Just (toString r) _ -> Nothing) , firstWorkedOn = p.InstanceProgress.firstEvent , lastWorkedOn = p.InstanceProgress.lastEvent , taskStatus = case p.InstanceProgress.value of None -> "No results so far..." Unstable -> "In progres..." Stable -> "Task done" Exception -> "Something went wrong" } result (Value [_,(_,v)] _) = v result _ = NoValue :: ProcessControlView = { assignedTo :: !String , firstWorkedOn :: !Maybe DateTime , lastWorkedOn :: !Maybe DateTime , taskStatus :: !String } derive class iTask ProcessControlView workerAttributes :: worker [(String, String)] -> TaskAttributes | toUserConstraint worker workerAttributes worker attr = case toUserConstraint worker of AnyUser = 'DM'.newMap UserWithId uid = 'DM'.fromList [("user", uid):attr] UserWithRole role = 'DM'.fromList [("role", role):attr] (@:) infix 3 :: !worker !(Task a) -> Task a | iTask a & toUserConstraint worker (@:) worker task = get currentUser -&&- get currentDateTime >>- \(me,now) -> assign (workerAttributes worker [ ("title", toTitle worker) , ("createdBy", toString (toUserConstraint me)) , ("createdAt", toString now) , ("priority", toString 5) , ("createdFor", toString (toUserConstraint worker)) ]) task appendTopLevelTaskFor :: !worker !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker appendTopLevelTaskFor worker evalDirect task = appendTopLevelTask (workerAttributes worker []) evalDirect task