Commit a2879bc9 authored by Mart Lubbers's avatar Mart Lubbers
Browse files

update tty to support more than one device

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