implementation module iTasks.API.Core.Tasks import StdList, StdBool, StdInt, StdTuple,StdMisc import System.Time, Data.Error, System.OSError, Data.Tuple, Text, Text.JSON import iTasks.Framework.Util, iTasks.Framework.HtmlUtil import iTasks.Framework.Generic, iTasks.Framework.Generic.Interaction, iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval, iTasks.Framework.TaskStore import iTasks.Framework.UIDefinition, iTasks.Framework.IWorld import iTasks.API.Core.LayoutCombinators from iTasks.Framework.SDS as SDS import qualified read, readRegister, write, writeFilterMsg from iTasks.API.Core.SDSs import topLevelTasks from StdFunc import o, id from Data.Map import qualified newMap, get, put, del from TCPChannels import lookupIPAddress, class ChannelEnv, instance ChannelEnv World, connectTCP_MT from TCPChannels import toByteSeq, send, class Send, instance Send TCP_SChannel_ from TCPChannels import :: TimeoutReport, :: Timeout, :: Port from TCPChannels import instance toString IPAddress from TCPChannels import class closeRChannel(..), instance closeRChannel TCP_RChannel_ from TCPChannelClass import :: DuplexChannel(..), closeChannel mkTaskIdent tid = Just (ModuleTaskName "iTasks.API.Core.Tasks" tid) return :: !a -> (Task a) | iTask a return a = mkInstantTask (\taskId iworld-> (Ok a, iworld)) throw :: !e -> Task a | iTask a & iTask, toString e throw e = mkInstantTask (\taskId iworld -> (Error (dynamic e,toString e), iworld)) get :: !(ReadWriteShared a w) -> Task a | iTask a get shared = mkInstantTask eval where eval taskId iworld=:{current={taskTime}} # (val,iworld) = 'SDS'.read shared iworld = case val of Ok val = (Ok val,iworld) Error e = (Error (dynamic (SharedException e), e), iworld) set :: !a !(ReadWriteShared r a) -> Task a | iTask a set val shared = mkInstantTask eval where eval taskId iworld=:{current={taskTime,taskInstance}} # (res,iworld) ='SDS'.write val shared iworld = case res of Ok _ = (Ok val,iworld) Error e = (Error (dynamic (SharedException e), e), iworld) upd :: !(r -> w) !(ReadWriteShared r w) -> Task w | iTask r & iTask w upd fun shared = mkInstantTask eval where eval taskId iworld=:{current={taskTime,taskInstance}} # (er, iworld) = 'SDS'.read shared iworld = case er of Error e = (Error (dynamic (SharedException e), e), iworld) Ok r # w = fun r # (er, iworld) = 'SDS'.write w shared iworld = case er of Ok _ = (Ok w, iworld) Error e = (Error (dynamic (SharedException e), e), iworld) watch :: !(ReadWriteShared r w) -> Task r | iTask r watch shared = Task (mkTaskIdent "watch") eval where eval event repOpts (TCInit taskId=:(TaskId instanceNo _) mtn ts) iworld # (val,iworld) = 'SDS'.readRegister instanceNo shared iworld # res = case val of Ok val = ValueResult (Value val False) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} (finalizeRep repOpts NoRep) (TCInit taskId mtn ts) Error e = exception (SharedException e) = (res,iworld) eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld) interact :: !d !(ReadOnlyShared r) (r -> (l,(v,InteractionMask))) (l r (v,InteractionMask) Bool Bool Bool -> (l,(v,InteractionMask))) -> Task l | descr d & iTask l & iTask r & iTask v interact desc shared initFun refreshFun = Task (mkTaskIdent "interact") eval where eval event repOpts (TCInit taskId=:(TaskId instanceNo _) mtn ts) iworld # (mbr,iworld) = 'SDS'.readRegister instanceNo shared iworld = case mbr of Error e = (exception e, iworld) Ok r # (l,(v,mask)) = initFun r = eval event repOpts (TCInteract taskId mtn ts (toJSON l) (toJSON r) (toJSON v) mask) iworld eval event repOpts (TCInteract taskId=:(TaskId instanceNo _) mtn ts encl encr encv mask) iworld=:{current={taskTime}} //Decode stored values # (l,r,v) = (fromJust (fromJSON encl), fromJust (fromJSON encr), fromJust (fromJSON encv)) //Determine next v by applying edit event if applicable # (nv,nmask,nts,iworld) = matchAndApplyEvent event taskId taskTime v mask ts iworld //Load next r from shared value # (mbr,iworld) = 'SDS'.readRegister instanceNo shared iworld | isError mbr = (exception (fromError mbr),iworld) # nr = fromOk mbr //Apply refresh function if r or v changed # rChanged = nr =!= r # vChanged = nts =!= ts # vValid = isValid (verifyMaskedValue (nv,nmask)) # (nl,(nv,nmask)) = if (rChanged || vChanged) (refreshFun l nr (nv,nmask) rChanged vChanged vValid) (l,(nv,nmask)) //Make visualization # nver = verifyMaskedValue (nv,nmask) # (rep,iworld) = visualizeView taskId repOpts (nv,nmask,nver) desc (visualizeAsLabel nl) iworld # value = if (isValid nver) (Value nl False) NoValue = (ValueResult value {TaskInfo|lastEvent=nts,involvedUsers=[],refreshSensitive=True} (finalizeRep repOpts rep) (TCInteract taskId mtn nts (toJSON nl) (toJSON nr) (toJSON nv) nmask), iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) matchAndApplyEvent (EditEvent eventNo taskId name value) matchId taskTime v mask ts iworld | taskId == matchId | otherwise # ((nv,nmask),iworld) = updateValueAndMask taskId (s2dp name) value (v,mask) iworld = (nv,nmask,taskTime,iworld) | otherwise = (v,mask,ts,iworld) matchAndApplyEvent (FocusEvent eventNo taskId) matchId taskTime v mask ts iworld = (v,mask, if (taskId == matchId) taskTime ts, iworld) matchAndApplyEvent _ matchId taskTime v mask ts iworld = (v,mask,ts,iworld) visualizeView taskId repOpts value=:(v,vmask,vver) desc valueAttr iworld # layout = repLayoutRules repOpts # (controls,iworld) = visualizeAsEditor value taskId layout iworld # uidef = {UIDef|content=UIControlStack (layout.LayoutRules.accuInteract (toPrompt desc) {UIControlStack|attributes='Data.Map'.put VALUE_ATTRIBUTE valueAttr 'Data.Map'.newMap,controls=controls,size=defaultSizeOpts}),windows=[]} = (TaskRep uidef [(toString taskId,toJSON v)], iworld) tcpconnect :: !String !Int !(ReadOnlyShared r) (r -> (MaybeErrorString l,[String],Bool)) (l r [String] Bool Bool -> (MaybeErrorString l,[String],Bool)) -> Task l | iTask l & iTask r tcpconnect host port shared initFun commFun = Task (mkTaskIdent "tcpconnect") eval where eval event repOpts tree=:(TCInit taskId mtn ts) iworld=:{IWorld|io={done,todo},world} //Connect # (mbIP,world) = lookupIPAddress host world | mbIP =: Nothing = (ExceptionResult (dynamic lookupErr) lookupErr, {iworld & io = {done=done,todo=todo},world = world}) # (tReport,mbConn,world) = connectTCP_MT Nothing (fromJust mbIP,port) world = case mbConn of Nothing = (ExceptionResult (dynamic connectErr) connectErr, {iworld & io = {done=done,todo=todo},world = world}) Just {DuplexChannel|rChannel,sChannel} # ip = fromJust mbIP # task=:(ConnectionTask init _ _) = connTask taskId shared initFun commFun # (out,close,state,iworld=:{IWorld|io={done,todo},world}) = init (toString ip) {iworld & io = {done=done,todo=todo},world = world} # (sChannel,world) = case out of [] = (sChannel,world) data = foldl (\(s,w) d -> send (toByteSeq d) s w) (sChannel,world) data | close # world = closeRChannel rChannel world # world = closeChannel sChannel world = (ValueResult NoValue {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} NoRep (TCBasic taskId mtn ts JSONNull False),{iworld & io = {done=done,todo=todo},world=world}) | otherwise //Add connection task to todo queue # todo = todo ++ [ConnectionInstance ip {rChannel=rChannel,sChannel=sChannel} task state] = (ValueResult NoValue {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} NoRep (TCBasic taskId mtn ts JSONNull False),{iworld & io = {done=done,todo=todo},world=world}) eval event repOpts tree=:(TCBasic taskId _ ts _ _) iworld=:{ioValues} = case 'Data.Map'.get taskId ioValues of Nothing = (ValueResult NoValue {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} NoRep tree, iworld) Just (IOValue (l :: l^) s) = (ValueResult (Value l s) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} NoRep tree, iworld) Just (IOException e) = (ExceptionResult (dynamic e) e,iworld) _ # e = "Corrupt IO task result" = (ExceptionResult (dynamic e) e,iworld) eval event repOpts tree=:(TCDestroy (TCBasic taskId _ _ _ _)) iworld=:{ioValues} # iworld = {iworld & ioValues = 'Data.Map'.del taskId ioValues} = (DestroyedResult,iworld) lookupErr = "Failed to lookup host "+++ host connectErr = "Failed to connect to host "+++ host connTask :: !TaskId (ReadOnlyShared r) (r -> (MaybeErrorString l,[String],Bool)) (l r [String] Bool Bool -> (MaybeErrorString l,[String],Bool)) -> ConnectionTask | iTask r & iTask l connTask taskId=:(TaskId instanceNo _) shared initFun commFun = ConnectionTask init eval close where init host iworld # (val,iworld=:{ioValues}) = 'SDS'.read shared iworld = case val of Ok r # (mbl,sends,close) = initFun r = case mbl of Ok l # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOValue (dynamic l) False) ioValues} = (sends, close, dynamic (r,l), iworld) Error e # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOException e) ioValues} = (sends,True, dynamic e, iworld) Error e = ([],True, dynamic (toString e), iworld) eval (Just data) ((prevr,l) :: (r^,l^)) iworld # (val,iworld=:{ioValues}) = 'SDS'.read shared iworld = case val of Ok r # (mbl,sends,close) = commFun l r [data] (r =!= prevr) False = case mbl of Ok l # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOValue (dynamic l) False) ioValues} # iworld = queueRefresh [instanceNo] iworld = (sends,close,dynamic (r,l), iworld) Error e # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOException e) ioValues} # iworld = queueRefresh [instanceNo] iworld = (sends,True,dynamic e, iworld) Error e = ([],True,dynamic (toString e), iworld) eval _ state iworld = ([],False,state,iworld) //TODO: ALSO DEAL WITH CASE WHERE SHARE CHANGED, BUT NO DATA close ((prevr,l) :: (r^,l^)) iworld # (val,iworld=:{ioValues}) = 'SDS'.read shared iworld = case val of Ok r # (mbl,_,_) = commFun l r [] (r =!= prevr) True = case mbl of Ok l # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOValue (dynamic l) True) ioValues} # iworld = queueRefresh [instanceNo] iworld = (dynamic (r,l), iworld) Error e # iworld = {iworld & ioValues = 'Data.Map'.put taskId (IOException e) ioValues} # iworld = queueRefresh [instanceNo] iworld = (dynamic e, iworld) Error e = (dynamic (toString e), iworld) appWorld :: !(*World -> *World) -> Task Void appWorld fun = mkInstantTask eval where eval taskId iworld=:{IWorld|world} = (Ok Void, {IWorld|iworld & world = fun world}) accWorld :: !(*World -> *(!a,!*World)) -> Task a | iTask a accWorld fun = mkInstantTask eval where eval taskId iworld=:{IWorld|world} # (res,world) = fun world = (Ok res, {IWorld|iworld & world = world}) accWorldError :: !(*World -> (!MaybeError e a, !*World)) !(e -> err) -> Task a | iTask a & TC, toString err accWorldError fun errf = mkInstantTask eval where eval taskId iworld=:{IWorld|current={taskTime},world} # (res,world) = fun world = case res of Error e # err = errf e = (Error (dynamic err,toString err), {IWorld|iworld & world = world}) Ok v = (Ok v, {IWorld|iworld & world = world}) accWorldOSError :: !(*World -> (!MaybeOSError a, !*World)) -> Task a | iTask a accWorldOSError fun = accWorldError fun OSException shutDown :: Task Void shutDown = mkInstantTask (\taskId iworld -> (Ok Void, {IWorld|iworld & shutdown = True}))