implementation module iTasks.API.Core.IntegrationTasks import StdInt, StdFile, StdTuple, StdList import System.Directory, System.File, System.FilePath, Data.Error, System.OSError, Text.Encodings.UrlEncoding, Text, Data.Tuple, Text.JSON import Data.Either, System.OS, Text.URI, Internet.HTTP import iTasks._Framework.IWorld, iTasks._Framework.Task, iTasks._Framework.TaskState import iTasks._Framework.SDS, iTasks._Framework.TaskEval import iTasks._Framework.Generic.Interaction import iTasks.API.Core.Types, iTasks.API.Core.Tasks, iTasks.API.Core.LayoutCombinators import iTasks.API.Core.SDSs import iTasks.API.Common.InteractionTasks, iTasks.API.Common.TaskCombinators //TODO don't import from Common in Core from iTasks.API.Common.ImportTasks import importTextFile from System.File import qualified fileExists, readFile from Data.Map import qualified newMap, put from System.Process import qualified ::ProcessHandle, runProcess, checkProcess,callProcess from System.Process import :: ProcessHandle(..) from StdFunc import o derive JSONEncode ProcessHandle derive JSONDecode ProcessHandle instance toString (OSErrorCode,String) where toString (_,e) = e worldIO :: (*World -> *(!MaybeError e a,!*World)) -> Task a | iTask a & TC e & toString e worldIO f = mkInstantTask eval where eval taskId iworld=:{current={taskTime},world} = case f world of (Ok a,world) = (Ok a, {IWorld|iworld & world = world}) (Error e,world) = (Error (dynamic e,toString e), {IWorld|iworld & world = world}) callProcess :: !d ![ViewOption ProcessStatus] !FilePath ![String] !(Maybe FilePath) -> Task ProcessStatus | descr d callProcess desc opts cmd args dir = Task eval where //Start the process eval event evalOpts (TCInit taskId ts) iworld=:{IWorld|world} //Call the external process # (res,world) = 'System.Process'.runProcess cmd args dir world = case res of Error e = (ExceptionResult (dynamic e,snd e), {IWorld|iworld & world = world}) Ok handle = eval event evalOpts (TCBasic taskId ts (toJSON handle) False) {IWorld|iworld & world = world} //Check the process eval event evalOpts state=:(TCBasic taskId lastEvent encv stable) iworld=:{IWorld|world,current={TaskEvalState|taskInstance}} | stable # status = fromJust (fromJSON encv) # (rep,iworld) = makeRep taskId evalOpts status iworld # iworld = queueRefresh [taskInstance] ["Checked OS process for instance "<+++ taskInstance] iworld = (ValueResult (Value status True) {TaskEvalInfo|lastEvent=lastEvent,removedTasks=[],refreshSensitive=True} rep state, iworld) | otherwise //Check status # handle = fromJust (fromJSON encv) # (res,world) = 'System.Process'.checkProcess handle world = case res of Error e = (ExceptionResult (dynamic e,snd e), {IWorld|iworld & world = world}) Ok mbExitCode # (status,stable,state) = case mbExitCode of Just c = (CompletedProcess c,True, TCBasic taskId lastEvent (toJSON (CompletedProcess c)) False) Nothing = (RunningProcess cmd,False, state) # (rep,iworld) = makeRep taskId evalOpts status {IWorld|iworld & world = world} # iworld = queueRefresh [taskInstance] ["Checked OS process for instance "<+++ taskInstance] iworld = (ValueResult (Value status stable) {TaskEvalInfo|lastEvent=lastEvent,removedTasks=[],refreshSensitive=True} rep state, iworld) eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld) makeRep taskId evalOpts status iworld # layout = repLayoutRules evalOpts # (controls,iworld) = makeView opts status taskId layout iworld # prompt = toPrompt desc # editor = {UIForm| attributes = 'Data.Map'.newMap, controls = controls, size = defaultSizeOpts} = (TaskRep ({UIDef|content=UIForm (layout.LayoutRules.accuInteract prompt editor),windows=[]}),iworld) makeView [ViewWith viewFun] status taskId layout iworld # ver = verifyMaskedValue (Display (viewFun status),Touched) = visualizeAsEditor (Display (viewFun status),Touched,ver) taskId layout iworld makeView _ status taskId layout iworld # ver = verifyMaskedValue (Display (defaultViewFun status),Touched) = visualizeAsEditor (Display (defaultViewFun status),Touched,ver) taskId layout iworld //By default show a progress bar defaultViewFun (RunningProcess cmd) = {Progress|progress=ProgressUndetermined,description="Running " +++ cmd +++ "..."} defaultViewFun (CompletedProcess exit) = {Progress|progress=ProgressRatio 1.0,description=cmd +++ " done (" +++ toString exit +++ ")"} callInstantProcess :: !FilePath ![String] !(Maybe FilePath) -> Task Int callInstantProcess cmd args dir = mkInstantTask eval where eval taskId iworld=:{current={taskTime},world} # (res,world) = 'System.Process'.callProcess cmd args dir world = case res of Error e # ex = CallFailed e = (Error (dynamic ex,toString ex), {IWorld|iworld & world = world}) Ok i = (Ok i, {IWorld|iworld & world = world}) callHTTP :: !HTTPMethod !URI !String !(HTTPResponse -> (MaybeErrorString a)) -> Task a | iTask a callHTTP method url=:{URI|uriScheme,uriRegName=Just uriRegName,uriPort,uriPath,uriQuery,uriFragment} data parseFun = tcpconnect uriRegName port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect} @? taskResult where port = fromMaybe 80 uriPort path = uriPath +++ maybe "" (\q -> ("?"+++q)) uriQuery +++ maybe "" (\f -> ("#"+++f)) uriFragment //VERY SIMPLE HTTP 1.1 Request req = toString method +++ " " +++ path +++ " HTTP/1.1\r\nHost:"+++uriRegName+++"\r\nConnection: close\r\n\r\n"+++data onConnect _ _ = (Ok (Left []),Nothing,[req],False) whileConnected (Just data) (Left acc) _ = (Ok (Left (acc ++ [data])),Nothing,[],False) whileConnected Nothing acc _ = (Ok acc,Nothing,[],False) onDisconnect (Left acc) _ = case parseResponse (concat acc) of Nothing = (Error "Invalid response",Nothing) (Just rsp) = case parseFun rsp of Ok a = (Ok (Right a),Nothing) Error e = (Error e,Nothing) taskResult (Value (Right a) _) = Value a True taskResult _ = NoValue callHTTP _ url _ _ = throw ("Invalid url: " +++ toString url) callRPCHTTP :: !HTTPMethod !URI ![(String,String)] !(HTTPResponse -> a) -> Task a | iTask a callRPCHTTP method url params transformResult = callHTTP method url (urlEncodePairs params) (Ok o transformResult) from iTasks.API.Common.ExportTasks import exportTextFile from iTasks.API.Common.ImportTasks import importDocument withTemporaryDirectory :: (FilePath -> Task a) -> Task a | iTask a withTemporaryDirectory taskfun = Task eval where eval event evalOpts (TCInit taskId ts) iworld=:{server={buildID,paths={dataDirectory}}} # tmpDir = dataDirectory "tmp" (buildID +++ "-" +++ toString taskId +++ "-tmpdir") # (taskIda,iworld=:{world}) = getNextTaskId iworld # (mbErr,world) = createDirectory tmpDir world = case mbErr of Ok Void = eval event evalOpts (TCShared taskId ts (TCInit taskIda ts)) {iworld & world = world} Error e=:(ecode,emsg) = (ExceptionResult (dynamic e,emsg), {iworld & world = world}) eval event evalOpts (TCShared taskId ts treea) iworld=:{server={buildID,paths={dataDirectory}},current={taskTime},world} # tmpDir = dataDirectory "tmp" (buildID +++ "-" +++ toString taskId +++ "-tmpdir") # (mbCurdir,world) = getCurrentDirectory world | isError mbCurdir = (ExceptionResult (exception (fromError mbCurdir)), {IWorld|iworld & world = world}) # (mbErr,world) = setCurrentDirectory tmpDir world | isError mbErr = (ExceptionResult (exception (fromError mbErr)), {IWorld|iworld & world = world}) # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts # (Task evala) = taskfun tmpDir # (resa,iworld=:{world}) = evala event evalOpts treea {IWorld|iworld & world = world} # (_,world) = setCurrentDirectory (fromOk mbCurdir) world | isError mbErr = (ExceptionResult (exception (fromError mbErr)), {IWorld|iworld & world = world}) = case resa of ValueResult value info rep ntreea # info = {TaskEvalInfo|info & lastEvent = max ts info.TaskEvalInfo.lastEvent} = (ValueResult value info rep (TCShared taskId info.TaskEvalInfo.lastEvent ntreea),{IWorld|iworld & world = world}) ExceptionResult e = (ExceptionResult e,{IWorld|iworld & world = world}) eval event evalOpts (TCDestroy (TCShared taskId ts treea)) iworld=:{server={buildID,paths={dataDirectory}}} //First destroy inner task # tmpDir = dataDirectory "tmp" (buildID +++ "-" +++ toString taskId +++ "-tmpdir") # (Task evala) = taskfun tmpDir # (resa,iworld) = evala event evalOpts (TCDestroy treea) iworld //TODO: recursive delete of tmp dir to not fill up the task store = (resa,iworld) eval _ _ _ iworld = (ExceptionResult (exception "Corrupt task state in withShared"), iworld)