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

update monitor

parent 866770d7
......@@ -2,18 +2,29 @@ module Monitor
import iTasks
import iTasksTTY
import TTY
import Data.Either
import StdTuple
from Data.Func import $
Start w = startEngine monitor w
Start w = startEngine manage w
monitor :: Task ()
monitor = enterTTYSettings <<@ ApplyLayout frameCompact
>>! \ts->withShared ([], [], False) \channels->
manage = parallel
[(Embedded, \stl->tune (Title "New device") $ forever $
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
||- viewSharedInformation "Incoming messages" [ViewAs (take 20 o fst3)] channels
||- forever (
enterInformation "Send line of text" []
>>= \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
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
......@@ -26,103 +26,88 @@ import iTasks.Internal.SDS
import iTasks.Internal.TaskServer
import iTasks.Internal.TaskEval
:: *Resource | TTYd *(String, Int, *TTY)
:: *Resource | TTYd String *TTY
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 opts enc dec rw = withShared "" \sh->Task $ eval sh
where
eval sh event evalOpts tree=:(TCInit taskId ts) iworld
# (mtty, iworld) = getTTYResource opts.devicePath iworld
= case mtty of
Just (tty, _) = (ExceptionResult (exception "This tty was already open"), iworld)
Nothing = case TTYopen opts iworld.world of
(False, _, world)
where
eval sh event evalOpts tree=:(TCInit taskId ts) iworld
# (mtty, iworld=:{world,resources}) = getResource iworld
= case mtty of
[] = case TTYopen opts iworld.world of
(False, _, world)
# (err, world) = TTYerror world
= (ExceptionResult (exception err), {iworld & world=world})
(True, tty, world)
# iworld = {iworld & world=world}
= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec sh rw)) iworld of
(Error e, iworld) = (ExceptionResult (exception "background task couldn't be added"), iworld)
(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
{iworld & resources=[TTYd (opts.devicePath, bgid, tty):iworld.resources]})
eval _ _ _ tree=:(TCBasic _ ts _ _) iworld
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} rep tree, iworld)
eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
# (mtty, iworld) = getTTYResource opts.devicePath iworld
= case mtty of
Nothing = (ExceptionResult (exception "This tty was already closed"), iworld)
Just (tty, bgid)
# (ok, world) = TTYclose tty iworld.world
# iworld = {iworld & world=world}
= case removeBackgroundTask bgid iworld of
(Error e, iworld) = (ExceptionResult e, iworld)
(Ok _, iworld) = (DestroyedResult, iworld)
rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath
/*
* The actual backgroundtask synchronizing the device
*
* @param Device path
* @param encoding function
* @param decoding function
* @param shared channels
* @param IWorld
* @return Maybe an exception
*/
serialDeviceBackgroundTask :: String (b -> String) (String -> (Either String [a], String)) (Shared String) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask dp enc dec accShare rw iworld
= case read rw iworld of
(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
//We need to stop
(Ok (_,_,True), iworld) = (Ok (), iworld)
(Ok (r,s,ss), iworld)
# (merr, iworld) = read accShare iworld
| isError merr = (liftError merr, iworld)
# (Ok acc) = merr
# (mtty, iworld) = getTTYResource dp iworld
= case mtty of
Nothing = (Error (exception "The tty device is gone"), iworld)
Just (tty, bgid)
# tty = foldr TTYwrite tty $ reverse $ map enc s
# (newdata, tty) = readWhileAvailable tty
# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]}
= case dec (acc +++ newdata) of
(Left err, newacc) = (Error (exception "Error while parsing"), iworld)
(Right msgs, newacc)
# (merr, iworld) = if (msgs =: [])
if (s =: [])
(Ok (), iworld)
(write (r, [], False) rw iworld)
(write (r++msgs, [], False) rw iworld)
| isError merr = (liftError merr, iworld)
= write newacc accShare iworld
readWhileAvailable :: !*TTY -> (String, !*TTY)
= (exc err, {iworld & world=world})
(True, tty, world)
# (merr, iworld) = readRegister taskId ticker {iworld & world=world, resources=[TTYd opts.devicePath tty:resources]}
| isError merr = (ExceptionResult (fromError merr), iworld)
= (ValueResult
NoValue
{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
rep
(TCBasic taskId ts (JSONString "") False)
, iworld)
_ = (exc "This tty was already open", iworld)
eval _ _ _ tree=:(TCBasic taskId ts (JSONString acc) _) iworld
# (mtty, iworld) = getResource iworld
= case mtty of
[] = (exc"TTY resource lost", iworld)
[_,_:_] = (exc "Multiple matching resources", iworld)
[TTYd dp tty]
# (merr, iworld) = readRegister taskId ticker iworld
| isError merr = (ExceptionResult (fromError merr), iworld)
# (merr, iworld=:{resources}) = read rw iworld
| isError merr = (ExceptionResult (fromError merr), iworld)
= case fromOk merr of
//We need to stop
(_,_,True) =
(ValueResult
(Value () True)
{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
rep
(TCDestroy tree)
, {iworld & resources=[TTYd dp tty:resources]})
(r,s,ss)
# tty = foldr TTYwrite tty $ reverse $ map enc s
# (newdata, tty) = readWhileAvailable tty
# iworld = {iworld & resources=[TTYd dp tty:iworld.resources]}
= case dec (acc +++ toString newdata) of
(Left err, newacc) = (exc "Error while parsing", iworld)
(Right msgs, newacc)
# (merr, iworld) = if (msgs =: [] && s =: [])
(Ok (), iworld)
(write (r++msgs, [], False) rw iworld)
| isError merr = (ExceptionResult (fromError merr), iworld)
= (ValueResult
NoValue
{TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
rep
(TCBasic taskId ts (JSONString newacc) False)
, iworld)
eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
# (mtty, iworld) = getResource iworld
= case mtty of
[] = (exc "This tty was already closed", iworld)
[_,_:_] = (exc "Multiple matching resources", iworld)
[TTYd _ tty]
# (ok, world) = TTYclose tty iworld.world
# iworld & world = world
| not ok = (exc "Couldn't close device", iworld)
= (DestroyedResult, iworld)
rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath
ticker = sdsFocus {start=zero,interval=zero} iworldTimespec
getResource = iworldResource (\t=:(TTYd p _)->(p == opts.devicePath, t))
exc = ExceptionResult o exception
readWhileAvailable :: !*TTY -> ([Char], !*TTY)
readWhileAvailable tty
# (available, tty) = TTYavailable tty
| not available = ("", tty)
| not available = ([], tty)
# (c, tty) = TTYread 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