module RunAsync import StdEnv import StdMaybe import ArgEnv import TCPIP import FilePath from File import ::FileError, writeFile, moveFile from Maybe import qualified ::Maybe(..) import Error from JSON_NG import ::JSONNode, generic JSONEncode, toJSON, instance toString JSONNode from OSError import ::OSError(..), ::OSErrorCode, ::OSErrorMessage, ::MaybeOSError(..) from Process import callProcess import Text import Void Start :: *World -> *World Start world # options = parseCommandLine # world = case options.mode of Timeout msec = world Process path args = process path args options.outfile world _ = world //# world = notify options world = world :: Options = { mode :: !Mode , hostname :: !String , port :: !Int , url :: !String , taskId :: !Int , outfile :: !Maybe String } :: AsyncResult = { success :: !Bool , exitcode :: !Int , message :: !String } derive JSONEncode AsyncResult :: Mode = None | Timeout Int | Process !FilePath ![String] defaultOptions :: Options defaultOptions = { mode = None , hostname = "localhost" , port = 80 , url = "/services/json/tasks/%t/refresh" , taskId = 0 , outfile = Nothing } parseCommandLine :: Options parseCommandLine # commandLine = getCommandLine = parse commandLine 1 (size commandLine - 1) defaultOptions where parse :: {{#Char}} !Int !Int !Options -> Options parse args i n options | i > n = options | i < n && args.[i] == "--hostname" = parse args (i + 2) n { options & hostname = args.[i + 1]} | i < n && args.[i] == "--port" = parse args (i + 2) n { options & port = (toInt args.[i + 1])} | i < n && args.[i] == "--url" = parse args (i + 2) n { options & url = args.[i + 1]} | i < n && args.[i] == "--taskid" = parse args (i + 2) n { options & taskId = (toInt args.[i + 1])} | i < n && args.[i] == "--timeout" = parse args (i + 2) n { options & mode = Timeout (toInt args.[i + 1])} | i < n && args.[i] == "--outfile" = parse args (i + 2) n { options & outfile = Just (args.[i + 1])} | i < n && args.[i] == "--process" = { options & mode = Process args.[i + 1] [args.[x] \\ x <- [i + 2 .. n]] } = abort ("Invalid argument: " +++ args.[i]) process :: !FilePath ![String] !(Maybe FilePath) !*World -> *World process path args outfile world # (res, world) = call path args world | isNothing outfile = world # tempfile = (fromJust outfile) +++ ".tmp" # (_, world) = writeFile tempfile (toString (toJSON res)) world # (_, world) = moveFile tempfile (fromJust outfile) world = world where call :: !FilePath ![String] !*World -> *(AsyncResult, *World) call path args world # (res, world) = callProcess path args 'Maybe'.Nothing world | isError res = ({ AsyncResult | success = False, exitcode = -1, message = snd (fromError res)}, world) = ({ AsyncResult | success = True, exitcode = fromOk res, message = ""}, world) notify :: !Options *World -> *World notify options world # url = replaceSubString "%t" (toString options.taskId) options.url request = "GET " +++ url +++ " HTTP/1.0\r\n\r\n" ticksPerSecond = 1000 # (mbIPAddr, world) = lookupIPAddress options.hostname world | isNothing mbIPAddr = world # (tReport, mbDuplexChan, world) = connectTCP_MT (Just (5*ticksPerSecond)) (fromJust mbIPAddr,options.port) world | tReport <> TR_Success = world # { sChannel=sc, rChannel=rc } = fromJust mbDuplexChan # (sc, world) = send (toByteSeq request) sc world # (bs, rc, world) = receive rc world # world = closeRChannel rc world # world = closeChannel sc world = world