Commit 61f95c21 authored by Mart Lubbers's avatar Mart Lubbers

update monitor

parent 866770d7
...@@ -2,18 +2,29 @@ module Monitor ...@@ -2,18 +2,29 @@ module Monitor
import iTasks import iTasks
import iTasksTTY import iTasksTTY
import TTY
import Data.Either import Data.Either
import StdTuple import StdTuple
from Data.Func import $
Start w = startEngine monitor w Start w = startEngine manage w
monitor :: Task () manage = parallel
monitor = enterTTYSettings <<@ ApplyLayout frameCompact [(Embedded, \stl->tune (Title "New device") $ forever $
>>! \ts->withShared ([], [], False) \channels-> enterInformation "TTY Settings" []
>>! \ts->appendTask Embedded (\_->tune (Title ts.devicePath) $ monitor ts @! ()) stl @! ())
]
[]
<<@ ArrangeWithTabs True
>>* [OnAction (Action "Shutdown") (always (shutDown 0))]
monitor ts = catchAll (
withShared ([], [], False) \channels->
syncSerialChannel ts id (\s->(Right [s], "")) channels syncSerialChannel ts id (\s->(Right [s], "")) channels
||- viewSharedInformation "Incoming messages" [ViewAs (take 20 o fst3)] channels ||- viewSharedInformation "Incoming messages" [ViewAs (take 20 o fst3)] channels
||- forever ( ||- forever (
enterInformation "Send line of text" [] enterInformation "Send line of text" []
>>= \line->upd (\(r,w,s)->(r,w++[line+++"\n"],s)) channels >>= \line->upd (\(r,w,s)->(r,w++[line+++"\n"],s)) channels
) ) @? const NoValue
@! () ) (\e->viewInformation "Exception occured" [] e)
>>* [OnAction (Action "Close") (always (treturn ""))]
...@@ -5,4 +5,16 @@ import iTasks ...@@ -5,4 +5,16 @@ import iTasks
derive class iTask TTYSettings derive class iTask TTYSettings
:: TTYException = TTYException String
/**
* Synchronizes the channel share
*
* @param Device settings
* @param Encoding function for messages to send
* @param Streaming decoding function to decode received data
* @param Channel SDS, first list are incoming messages, second list outgoing, third boolean is the stop flag
* @result Task that stops when the stop flag is set
* @throws TTYException
*/
syncSerialChannel :: TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b syncSerialChannel :: TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
...@@ -26,103 +26,88 @@ import iTasks.Internal.SDS ...@@ -26,103 +26,88 @@ import iTasks.Internal.SDS
import iTasks.Internal.TaskServer import iTasks.Internal.TaskServer
import iTasks.Internal.TaskEval import iTasks.Internal.TaskEval
:: *Resource | TTYd *(String, Int, *TTY) :: *Resource | TTYd String *TTY
derive class iTask TTYSettings, Parity, BaudRate, ByteSize derive class iTask TTYSettings, Parity, BaudRate, ByteSize
getTTYResource :: String *IWorld -> (Maybe *(*TTY, Int), *IWorld)
getTTYResource dp iw=:{resources}
# (mt, resources) = getTTYResource` resources
= (mt, {iw & resources=resources})
where
getTTYResource` :: *[*Resource] -> (Maybe *(*TTY, Int), *[*Resource])
getTTYResource` [] = (Nothing, [])
getTTYResource` [TTYd (dpath, bgid, tty):xs]
| dpath == dp = (Just (tty, bgid), xs)
getTTYResource` [x:xs]
# (mt, xs) = getTTYResource` xs
= (mt, [x:xs])
liftWorld f = \iw=:{world}->{iw & world=f world}
syncSerialChannel :: TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b syncSerialChannel :: TTYSettings (b -> String) (String -> (Either String [a], String)) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel opts enc dec rw = withShared "" \sh->Task $ eval sh syncSerialChannel opts enc dec rw = withShared "" \sh->Task $ eval sh
where where
eval sh event evalOpts tree=:(TCInit taskId ts) iworld eval sh event evalOpts tree=:(TCInit taskId ts) iworld
# (mtty, iworld) = getTTYResource opts.devicePath iworld # (mtty, iworld=:{world,resources}) = getResource iworld
= case mtty of = case mtty of
Just (tty, _) = (ExceptionResult (exception "This tty was already open"), iworld) [] = case TTYopen opts iworld.world of
Nothing = case TTYopen opts iworld.world of (False, _, world)
(False, _, world)
# (err, world) = TTYerror world # (err, world) = TTYerror world
= (ExceptionResult (exception err), {iworld & world=world}) = (exc err, {iworld & world=world})
(True, tty, world) (True, tty, world)
# iworld = {iworld & world=world} # (merr, iworld) = readRegister taskId ticker {iworld & world=world, resources=[TTYd opts.devicePath tty:resources]}
= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec sh rw)) iworld of | isError merr = (ExceptionResult (fromError merr), iworld)
(Error e, iworld) = (ExceptionResult (exception "background task couldn't be added"), iworld) = (ValueResult
(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False), NoValue
{iworld & resources=[TTYd (opts.devicePath, bgid, tty):iworld.resources]}) {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
rep
eval _ _ _ tree=:(TCBasic _ ts _ _) iworld (TCBasic taskId ts (JSONString "") False)
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} rep tree, iworld) , iworld)
_ = (exc "This tty was already open", iworld)
eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
# (mtty, iworld) = getTTYResource opts.devicePath iworld eval _ _ _ tree=:(TCBasic taskId ts (JSONString acc) _) iworld
= case mtty of # (mtty, iworld) = getResource iworld
Nothing = (ExceptionResult (exception "This tty was already closed"), iworld) = case mtty of
Just (tty, bgid) [] = (exc"TTY resource lost", iworld)
# (ok, world) = TTYclose tty iworld.world [_,_:_] = (exc "Multiple matching resources", iworld)
# iworld = {iworld & world=world} [TTYd dp tty]
= case removeBackgroundTask bgid iworld of # (merr, iworld) = readRegister taskId ticker iworld
(Error e, iworld) = (ExceptionResult e, iworld) | isError merr = (ExceptionResult (fromError merr), iworld)
(Ok _, iworld) = (DestroyedResult, iworld) # (merr, iworld=:{resources}) = read rw iworld
| isError merr = (ExceptionResult (fromError merr), iworld)
rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath = case fromOk merr of
//We need to stop
/* (_,_,True) =
* The actual backgroundtask synchronizing the device (ValueResult
* (Value () True)
* @param Device path {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
* @param encoding function rep
* @param decoding function (TCDestroy tree)
* @param shared channels , {iworld & resources=[TTYd dp tty:resources]})
* @param IWorld (r,s,ss)
* @return Maybe an exception # tty = foldr TTYwrite tty $ reverse $ map enc s
*/ # (newdata, tty) = readWhileAvailable tty
serialDeviceBackgroundTask :: String (b -> String) (String -> (Either String [a], String)) (Shared String) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b # iworld = {iworld & resources=[TTYd dp tty:iworld.resources]}
serialDeviceBackgroundTask dp enc dec accShare rw iworld = case dec (acc +++ toString newdata) of
= case read rw iworld of (Left err, newacc) = (exc "Error while parsing", iworld)
(Error e, iworld) = (Error $ exception "share couldn't be read", iworld) (Right msgs, newacc)
# (merr, iworld) = if (msgs =: [] && s =: [])
//We need to stop (Ok (), iworld)
(Ok (_,_,True), iworld) = (Ok (), iworld) (write (r++msgs, [], False) rw iworld)
| isError merr = (ExceptionResult (fromError merr), iworld)
(Ok (r,s,ss), iworld) = (ValueResult
# (merr, iworld) = read accShare iworld NoValue
| isError merr = (liftError merr, iworld) {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
# (Ok acc) = merr rep
# (mtty, iworld) = getTTYResource dp iworld (TCBasic taskId ts (JSONString newacc) False)
= case mtty of , iworld)
Nothing = (Error (exception "The tty device is gone"), iworld)
Just (tty, bgid) eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
# tty = foldr TTYwrite tty $ reverse $ map enc s # (mtty, iworld) = getResource iworld
# (newdata, tty) = readWhileAvailable tty = case mtty of
# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]} [] = (exc "This tty was already closed", iworld)
= case dec (acc +++ newdata) of [_,_:_] = (exc "Multiple matching resources", iworld)
(Left err, newacc) = (Error (exception "Error while parsing"), iworld) [TTYd _ tty]
(Right msgs, newacc) # (ok, world) = TTYclose tty iworld.world
# (merr, iworld) = if (msgs =: []) # iworld & world = world
if (s =: []) | not ok = (exc "Couldn't close device", iworld)
(Ok (), iworld) = (DestroyedResult, iworld)
(write (r, [], False) rw iworld)
(write (r++msgs, [], False) rw iworld) rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath
| isError merr = (liftError merr, iworld) ticker = sdsFocus {start=zero,interval=zero} iworldTimespec
= write newacc accShare iworld getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
exc = ExceptionResult o exception
readWhileAvailable :: !*TTY -> (String, !*TTY)
readWhileAvailable :: !*TTY -> ([Char], !*TTY)
readWhileAvailable tty readWhileAvailable tty
# (available, tty) = TTYavailable tty # (available, tty) = TTYavailable tty
| not available = ("", tty) | not available = ([], tty)
# (c, tty) = TTYread tty # (c, tty) = TTYread tty
# (cs, tty) = readWhileAvailable tty # (cs, tty) = readWhileAvailable tty
= (toString (toChar c) +++ cs, tty) = ([toChar c:cs], tty)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment