iTasksTTY.icl 4.86 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 -> a) (Shared ([a],[b],Bool)) -> Task () | iTask a & iTask b
syncSerialChannel opts enc dec rw = Task eval
Mart Lubbers's avatar
Mart Lubbers committed
73
	where
74
75
76
77
78
79
80
81
82
83
84
85
86
87
		eval 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)
				# (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 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]})
Mart Lubbers's avatar
Mart Lubbers committed
88
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
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
import StdDebug, StdMisc
106
107
108
109
110
111
112
113
114
115
/*
 * The actual backgroundtask synchronizing the device
 *
 * @param Device path
 * @param encoding function
 * @param decoding function
 * @param shared channels
 * @param IWorld
 * @return Maybe an exception
 */
116
117
serialDeviceBackgroundTask :: String (b -> String) (String -> a) (Shared ([a],[b],Bool)) !*IWorld -> (MaybeError TaskException (), *IWorld) | iTask a & iTask b
serialDeviceBackgroundTask dp enc dec rw iworld
118
119
	= case read rw iworld of
		(Error e, iworld) = (Error $ exception "share couldn't be read", iworld)
120

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

124
		(Ok (r,s,ss), iworld)
125
126
127
128
129
130
131
132
133
134
135
136
137
		# (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
			# (ml, tty) = case TTYavailable tty of
				(False, tty) = ([], tty)
				(_, tty) = appFst (pure o dec) $ TTYreadline tty
			# iworld = {iworld & resources=[TTYd (dp, bgid, tty):iworld.resources]}
			| isEmpty ml && isEmpty s = (Ok (), iworld)
			# (merr, iworld) = notify rw iworld
			| isError merr = (Error $ fromError merr, iworld)
			= write (r++ml,[],False) rw iworld