We planned to upgrade GitLab and Mattermost to the latest version this Friday morning. Expect some downtime!

Commit a2879bc9 authored by Mart Lubbers's avatar Mart Lubbers

update tty to support more than one device

parent 52e2fb4d
......@@ -7,6 +7,7 @@ from StdFunc import o, flip
import StdMisc
import StdString
import Data.List
import qualified Data.Map as DM
import System.Directory
import iTasks
......@@ -22,7 +23,7 @@ import iTasks._Framework.TaskServer
import iTasks._Framework.IWorld
import iTasks._Framework.Store
:: *Resource | TTYd !*TTY Int
:: *Resource | TTYd *[*(String,Int,!*TTY)]
derive class iTask TTYSettings, Parity, BaudRate, ByteSize
......@@ -32,7 +33,7 @@ getTTYDevices w = case readDirectory "/dev" w of
(Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
where
isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
prefixes = ["ttyS", "ttyACM", "ttyUSB", "tty.usbserial", "rfcomm"]
prefixes = ["tty", "rfcomm"]
enterTTYSettings :: Task TTYSettings
enterTTYSettings = accWorld getTTYDevices
......@@ -60,37 +61,51 @@ syncSerialChannel opts enc dec rw = Task eval
= (ExceptionResult (exception err), {iworld & world=world})
(True, tty, world)
# iworld = {iworld & world=world}
= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask enc dec rw)) iworld of
= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec rw)) iworld of
(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
(Ok bgid, iworld) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False), {iworld & resources=Just (TTYd tty bgid)})
(Ok bgid, iworld) = case iworld.resources of
Nothing = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
{iworld & resources=Just $ TTYd [(opts.devicePath, bgid, tty)]})
Just (TTYd m) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),
{iworld & resources=Just $ TTYd [(opts.devicePath, bgid, tty):m]})
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}
# (TTYd tty bgid) = fromJust resources
# (Just (TTYd ttys)) = resources
# ((tty, bgid), ttys) = flt opts.devicePath ttys
# (ok, world) = TTYclose tty world
# iworld = {iworld & world=world,resources=Nothing}
# iworld = {iworld & world=world,resources=Just $ TTYd ttys}
= case removeBackgroundTask bgid iworld of
(Error e, iworld) = (ExceptionResult (exception "h"), iworld)
(Ok _, iworld) = (DestroyedResult, iworld)
rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath
serialDeviceBackgroundTask :: (b -> String) (String -> a) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask enc dec rw iworld
flt :: String [(String, Int, *TTY)] -> ((*TTY, Int), [(String, Int, *TTY)])
flt m [] = abort "not found"
flt m [(p,b,t):ps]
| p == m = ((t, b), ps)
# (tty, pps) = flt m ps
= (tty, [(p,b,t):pps])
import StdDebug, StdMisc
serialDeviceBackgroundTask :: String (b -> String) (String -> a) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask dp enc dec 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)
# (Just (TTYd tty bgid)) = iworld.resources
# (Just (TTYd ttys)) = iworld.resources
# ((tty, bgid), ttys) = flt dp ttys
# tty = foldr TTYwrite tty $ reverse $ map enc s
# (ml, tty) = case TTYavailable tty of
(False, tty) = ([], tty)
(_, tty) = appFst (pure o dec) $ TTYreadline tty
# iworld = {iworld & resources=Just (TTYd tty bgid)}
# iworld = {iworld & resources=Just (TTYd [(dp, bgid, tty):ttys])}
| isEmpty ml && isEmpty s = (Ok (), iworld)
# (merr, iworld) = notify rw iworld
| isError merr = (Error $ fromError merr, iworld)
......
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