iTasksTTY.icl 5.35 KB
Newer Older
1
2
implementation module iTasksTTY

Mart Lubbers's avatar
Mart Lubbers committed
3
4
import TTY

5
import StdList
Mart Lubbers's avatar
Mart Lubbers committed
6
from StdFunc import o, flip
7
8
import StdMisc
import StdString
9
import Data.List
10
import qualified Data.Map as DM
11
12

import System.Directory
Mart Lubbers's avatar
Mart Lubbers committed
13
import iTasks
14
15
import Data.Tuple
import Control.Applicative
Mart Lubbers's avatar
Mart Lubbers committed
16
from Data.Func import $
17
18
from Text import class Text(startsWith), instance Text String

Mart Lubbers's avatar
Mart Lubbers committed
19
20
import iTasks.UI.Definition

21
22
23
24
25
26
import iTasks.Internal.IWorld
import iTasks.Internal.TaskState
import iTasks.Internal.Task
import iTasks.Internal.SDS
import iTasks.Internal.TaskServer
import iTasks.Internal.TaskEval
Mart Lubbers's avatar
Mart Lubbers committed
27

28
:: *Resource | TTYd *(String, Int, *TTY)
Mart Lubbers's avatar
Mart Lubbers committed
29
30
31

derive class iTask TTYSettings, Parity, BaudRate, ByteSize

32
33
34
35
36
37
getTTYDevices :: !*env -> *(![String], !*env)
getTTYDevices w = case readDirectory "/dev" w of
	(Error (errcode, errmsg), w) = abort errmsg
	(Ok entries, w) = (map ((+++) "/dev/") (filter isTTY entries), w)
	where
		isTTY s = not (isEmpty (filter (flip startsWith s) prefixes))
38
		prefixes = ["tty", "rfcomm"]
Mart Lubbers's avatar
Mart Lubbers committed
39

40
41
enterTTYSettings :: Task TTYSettings
enterTTYSettings = accWorld getTTYDevices
Mart Lubbers's avatar
Mart Lubbers committed
42
43
44
45
46
47
48
49
50
51
52
53
54
	>>= \ds->(
				enterChoice "Device" [] ds 
			-&&- updateInformation "Baudrate" [] B9600
			<<@ ArrangeHorizontal)
		-&&- (
				updateInformation "Bytesize" [] BytesizeEight
			-&&- updateInformation "Parity" [] ParityNone
			<<@ ArrangeHorizontal)
		-&&- (
				updateInformation "Stop2bits" [] False
			-&&- updateInformation "Xonoff" [] False
			<<@ ArrangeHorizontal)
	@ \((dev, br), ((bs, pr), (st, xo)))->makeTTYSettings dev br bs pr st xo
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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}

Mart Lubbers's avatar
Mart Lubbers committed
71
72
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
Mart Lubbers's avatar
Mart Lubbers committed
73
	where
Mart Lubbers's avatar
Mart Lubbers committed
74
		eval sh event evalOpts tree=:(TCInit taskId ts) iworld
75
76
77
78
79
80
81
82
83
		# (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)
				# (err, world) = TTYerror world
				= (ExceptionResult (exception err), {iworld & world=world})
				(True, tty, world)
				# iworld = {iworld & world=world}
Mart Lubbers's avatar
Mart Lubbers committed
84
				= case addBackgroundTask (BackgroundTask (serialDeviceBackgroundTask opts.devicePath enc dec sh rw)) iworld of
85
86
87
					(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]})
Mart Lubbers's avatar
Mart Lubbers committed
88

Mart Lubbers's avatar
Mart Lubbers committed
89
		eval _ _ _ tree=:(TCBasic _ ts _ _) iworld
90
		= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=False} rep tree, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
91

Mart Lubbers's avatar
Mart Lubbers committed
92
		eval _ event evalOpts tree=:(TCDestroy _) iworld=:{IWorld|resources,world}
93
94
95
96
97
98
99
100
101
		# (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)
Mart Lubbers's avatar
Mart Lubbers committed
102

103
104
		rep = ReplaceUI $ stringDisplay $ "Serial client " <+++ opts.devicePath

105
106
107
108
109
110
111
112
113
114
/*
 * The actual backgroundtask synchronizing the device
 *
 * @param Device path
 * @param encoding function
 * @param decoding function
 * @param shared channels
 * @param IWorld
 * @return Maybe an exception
 */
Mart Lubbers's avatar
Mart Lubbers committed
115
116
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
117
118
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
119

120
		//We need to stop
Mart Lubbers's avatar
Mart Lubbers committed
121
		(Ok (_,_,True), iworld) = (Ok (), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
122

123
		(Ok (r,s,ss), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
124
125
126
		# (merr, iworld) = read accShare iworld
		| isError merr = (liftError merr, iworld)
		# (Ok acc) = merr
127
128
129
130
131
		# (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
Mart Lubbers's avatar
Mart Lubbers committed
132
			# (newdata, tty) = readWhileAvailable tty
133
			# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]}
Mart Lubbers's avatar
Mart Lubbers committed
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
			= case dec (acc +++ newdata) of
				(Left err, newacc) = (Error (exception "Error while parsing"), iworld)
				(Right msgs, newacc)
					# (merr, iworld) = if (msgs =: [])
						(Ok (), iworld)
						(write (r++msgs, [], False) rw iworld)
					| isError merr = (liftError merr, iworld)
					= write newacc accShare iworld

readWhileAvailable :: !*TTY -> (String, !*TTY)
readWhileAvailable tty
# (available, tty) = TTYavailable tty
| not available = ("", tty)
# (c, tty) = TTYread tty
# (cs, tty) = readWhileAvailable tty
= (toString (toChar c) +++ cs, tty)