AsyncSDS.icl 22.3 KB
Newer Older
1 2
implementation module iTasks.Internal.AsyncSDS

3
import Data.Maybe, Data.Either, Data.List, Data.Func
4 5
import iTasks.Internal.TaskEval
import iTasks.Internal.TaskState
6
import Text, Text.GenJSON
7
import StdMisc, StdArray, StdBool
8 9 10 11 12 13 14
import Internet.HTTP

import iTasks.Engine
import iTasks.Internal.Distributed.Symbols
import iTasks.Internal.IWorld
import iTasks.Internal.SDS
import iTasks.Internal.Task
15
import iTasks.Internal.Util
16
import iTasks.SDS.Definition
17
import iTasks.UI.Definition
18
import iTasks.WF.Tasks.IO
Mart Lubbers's avatar
Mart Lubbers committed
19 20
import iTasks.WF.Derives
import iTasks.Internal.Serialization
21 22 23 24 25

import iTasks.Extensions.Distributed._Formatter

from iTasks.Internal.TaskServer import addConnection
from iTasks.SDS.Sources.Core import unitShare
26
import iTasks.Internal.SDSService
27 28

import qualified Data.Map as DM
29
import qualified Data.Set as DS
30 31 32

derive JSONEncode SDSNotifyRequest, RemoteNotifyOptions

Haye Böhm's avatar
Haye Böhm committed
33
createRequestString req = serializeToBase64 req
Haye Böhm's avatar
Haye Böhm committed
34

Haye Böhm's avatar
Haye Böhm committed
35
onConnect reqq connId _ _ = (Ok (Left []), Nothing, [createRequestString reqq +++ "\n"], False)
Haye Böhm's avatar
Haye Böhm committed
36

Haye Böhm's avatar
Haye Böhm committed
37
onData data (Left acc) _ = (Ok (Left (acc ++ [data])), Nothing, [], False)
Haye Böhm's avatar
Haye Böhm committed
38 39 40

onShareChange acc _ = (Ok acc, Nothing, [], False)

41 42
onDestroy s = (Ok s, [])

43
queueSDSRequest :: !(SDSRequest p r w) !String !Int !TaskId !{#Symbol} !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | TC r
44
queueSDSRequest req host port taskId symbols iworld
45
= case addConnection taskId host port Nothing connectionTask iworld of
46 47
	(Error e, iworld)  		= (Error e, iworld)
	(Ok (id, _), iworld)     	= (Ok id, iworld)
48
where
49
	connectionTask = wrapConnectionTask (handlers req) unitShare
50

51
	handlers :: (SDSRequest p r w) -> ConnectionHandlers (Either [String] (MaybeError TaskException r)) () () | TC r
52 53 54
	handlers _ = {ConnectionHandlers| onConnect = onConnect req,
		onData = onData,
		onShareChange = onShareChange,
55 56
		onDisconnect = onDisconnect,
		onDestroy = onDestroy}
57

58
	onDisconnect (Left acc) _
59 60 61
	# textResponse = concat acc
	| size textResponse < 1 = (Error ("queueSDSRequest: Server " +++ host +++ " disconnected without responding"), Nothing)
	= (Ok $ Right $ deserializeFromBase64 textResponse symbols, Nothing)
Haye Böhm's avatar
Haye Böhm committed
62 63

queueModifyRequest :: !(SDSRequest p r w) !String !Int !TaskId !{#Symbol} !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | TC r & TC w
64
queueModifyRequest req=:(SDSModifyRequest p r w) host port taskId symbols iworld = case addConnection taskId host port Nothing connectionTask iworld of
65 66
	(Error e, iworld)          = (Error e, iworld)
	(Ok (id, _), iworld)       = (Ok id, iworld)
Haye Böhm's avatar
Haye Böhm committed
67
where
68
	connectionTask = wrapConnectionTask (handlers req) unitShare
69

70
	handlers :: (SDSRequest p r w) -> ConnectionHandlers (Either [String] (MaybeError TaskException (r, w))) () () | TC r & TC w
71 72 73
	handlers _ = {ConnectionHandlers| onConnect = onConnect req,
		onData = onData,
		onShareChange = onShareChange,
74 75
		onDisconnect = onDisconnect,
		onDestroy=onDestroy}
76

77
	onDisconnect (Left acc) _
78 79 80
	# textResponse = concat acc
	| size textResponse == 0 = (Error ("queueModifyRequest: Server" +++ host +++ " disconnected without responding"), Nothing)
	= (Ok $ Right $ deserializeFromBase64 textResponse symbols, Nothing)
81

82
queueWriteRequest :: !(SDSRequest p r w) !String !Int !TaskId !{#Symbol} !*IWorld ->  (!MaybeError TaskException ConnectionId, !*IWorld) | TC r & TC w
83
queueWriteRequest req=:(SDSWriteRequest sds p w) host port taskId symbols iworld = case addConnection taskId host port Nothing connectionTask iworld of
84 85
	(Error e, iworld)          = (Error e, iworld)
	(Ok (id, _), iworld)       = (Ok id, iworld)
86 87 88 89 90 91 92
where
	connectionTask = wrapConnectionTask (handlers req) unitShare

	handlers :: (SDSRequest p r w) -> ConnectionHandlers (Either [String] (MaybeError TaskException ())) () () | TC r & TC w
	handlers req = {ConnectionHandlers| onConnect = onConnect req,
		onData = onData,
		onShareChange = onShareChange,
93 94
		onDisconnect = onDisconnect,
		onDestroy = onDestroy}
95 96 97 98 99 100

	onDisconnect (Left acc) _
	# textResponse = concat acc
	| size textResponse == 0 = (Error ("queueWriteRequest: Server" +++ host +++ " disconnected without responding"), Nothing)
	= (Ok $ Right $ deserializeFromBase64 textResponse symbols, Nothing)

Haye Böhm's avatar
Haye Böhm committed
101
queueServiceRequest :: !(SDSRemoteService p r w) p !TaskId !Bool !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | gText{|*|} p & TC p & TC r
102 103
queueServiceRequest (SDSRemoteService (Just _) _) _ _ _ iworld = (Error (exception "SDSRemoteService queing request while still a connection id"), iworld)
queueServiceRequest service=:(SDSRemoteService _ (HTTPShareOptions {host, port, createRequest, fromResponse})) p taskId _ iworld
104
= case addConnection taskId host port Nothing connectionTask iworld of
105 106
	(Error e, iworld) = (Error e, iworld)
	(Ok (id, _), iworld) = (Ok id, iworld)
107
where
Haye Böhm's avatar
Haye Böhm committed
108
	connectionTask = wrapConnectionTask (handlers service) unitShare
109

Haye Böhm's avatar
Haye Böhm committed
110
	handlers req = {ConnectionHandlers| onConnect = onConnect,
111 112
		onData = onData,
		onShareChange = onShareChange,
113 114
		onDisconnect = onDisconnect,
		onDestroy = onDestroy}
115

Haye Böhm's avatar
Haye Böhm committed
116 117 118 119
	onConnect _ _ _
	# req = createRequest p
	# sreq = toString {HTTPRequest|req & req_headers = 'DM'.put "Connection" "Close" req.HTTPRequest.req_headers}
	= (Ok (Left []), Nothing, [sreq], False)
120

121
	onData data (Left acc) _ = (Ok (Left (acc ++ [data])), Nothing, [], False)
122

123
	onShareChange acc _ = (Ok acc, Nothing, [], False)
124

Haye Böhm's avatar
Haye Böhm committed
125
	onDisconnect (Left []) _ = (Error ("queueServiceRequest: Server" +++ host +++ ":" +++ toString port +++ " disconnected without responding"), Nothing)
126
	onDisconnect (Left acc) _
127 128 129
	# textResponse = concat acc
	= case parseResponse textResponse of
		Nothing = (Error ("Unable to parse HTTP response, got: " +++ textResponse), Nothing)
Haye Böhm's avatar
Haye Böhm committed
130 131 132 133
		(Just parsed) = case fromResponse parsed p of
			(Error error) = (Error error, Nothing)
			(Ok a) = (Ok (Right a), Nothing)

134
queueServiceRequest service=:(SDSRemoteService _ (TCPShareOptions {host, port, createMessage, fromTextResponse})) p taskId register iworld
135
= case addConnection taskId host port Nothing connectionTask iworld of
136 137
	(Error e, iworld) = (Error e, iworld)
	(Ok (id, _), iworld) = (Ok id, iworld)
Haye Böhm's avatar
Haye Böhm committed
138
where
Haye Böhm's avatar
Haye Böhm committed
139 140
	connectionTask = wrapConnectionTask handlers unitShare
	handlers = {ConnectionHandlers| onConnect = onConnect,
Haye Böhm's avatar
Haye Böhm committed
141 142
		onData = onData,
		onShareChange = onShareChange,
143 144
		onDisconnect = onDisconnect,
		onDestroy = onDestroy}
Haye Böhm's avatar
Haye Böhm committed
145

146
	onConnect connId _ _	= (Ok (Nothing, []), Nothing, [createMessage p +++ "\n"], False)
Haye Böhm's avatar
Haye Böhm committed
147 148 149

	onData data (previous, acc) _
	# newacc = acc ++ [data]
150 151
	// If already a result, and we are registering, then we have received a refresh notification from the server.
	| register && isJust previous = (Ok (previous, newacc), Nothing, [], True)
152
	= case fromTextResponse (concat newacc) p register of
Haye Böhm's avatar
Haye Böhm committed
153
		Error e = (Error e, Nothing, [], True)
154 155 156 157 158
		// No full response yet, keep the old value.
		Ok (Nothing,response) 	= (Ok (previous, newacc), Nothing, maybe [] (\resp. [resp +++ "\n"]) response, False)
		Ok (Just r, Just resp) 	= (Ok (Just r, []), Nothing, [resp +++ "\n"], False)
		// Only close the connection when we have a value and when we are not registering.
		Ok (Just r, Nothing) 	= (Ok (Just r, []), Nothing, [], not register)
Haye Böhm's avatar
Haye Böhm committed
159 160 161

	onShareChange state _ = (Ok state, Nothing, [], False)
	onDisconnect state _ = (Ok state, Nothing)
162

Haye Böhm's avatar
Haye Böhm committed
163
queueServiceWriteRequest :: !(SDSRemoteService p r w) !p !w !TaskId !*IWorld -> (MaybeError TaskException (Maybe ConnectionId), !*IWorld) | TC p & TC w
164 165
queueServiceWriteRequest service=:(SDSRemoteService (Just _) _) _ _ _ iworld = (Error (exception "SDSRemoteService queing write request while still containing a connection id"), iworld)
queueServiceWriteRequest service=:(SDSRemoteService _ (HTTPShareOptions {host, port, writeHandlers})) p w taskId iworld
Haye Böhm's avatar
Haye Böhm committed
166
| isNothing writeHandlers = (Ok Nothing, iworld) // Writing not supported for this share.
167
= case addConnection taskId host port Nothing connectionTask iworld of
168 169
	(Error e, iworld) = (Error e, iworld)
	(Ok (id, _), iworld) = (Ok (Just id), iworld)
Haye Böhm's avatar
Haye Böhm committed
170 171 172 173 174 175 176
where
	(toWriteRequest, fromWriteResponse) = fromJust writeHandlers
	connectionTask = wrapConnectionTask handlers unitShare
	handlers = { ConnectionHandlers|onConnect = onConnect
				, onData 		= onData
				, onShareChange = onShareChange
				, onDisconnect 	= onDisconnect
177
				, onDestroy  	= onDestroy
Haye Böhm's avatar
Haye Böhm committed
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
				}
	onConnect connId _ _
	# req = toWriteRequest p w
	# sreq = toString {HTTPRequest|req & req_headers = 'DM'.put "Connection" "Close" req.HTTPRequest.req_headers}
	= (Ok (Left []), Nothing, [sreq], False)

	onData data (Left acc) _ = (Ok $ Left $ acc ++ [data], Nothing, [], False)

	onShareChange acc _ = (Ok acc, Nothing, [], False)

	onDisconnect (Left []) _ = (Error ("queueServiceWriteRequest: Server" +++ host +++ ":" +++ toString port +++ " disconnected without responding"), Nothing)
	onDisconnect (Left acc) _
	# textResponse = concat acc
	= case parseResponse textResponse of
		Nothing = (Error ("Unable to parse HTTP response, got: " +++ textResponse), Nothing)
		Just parsed = case fromWriteResponse p parsed of
			Error e = (Error e, Nothing)
			Ok pred = (Ok (Right pred), Nothing)

197
queueServiceWriteRequest service=:(SDSRemoteService _ (TCPShareOptions {host, port, writeMessageHandlers})) p w taskId iworld
Haye Böhm's avatar
Haye Böhm committed
198
| isNothing writeMessageHandlers = (Ok Nothing, iworld)
199
= case addConnection taskId host port Nothing connectionTask iworld of
Haye Böhm's avatar
Haye Böhm committed
200 201 202 203 204 205 206 207 208
	(Error e, iworld) = (Error e, iworld)
	(Ok (id, _), iworld) = (Ok (Just id), iworld)
where
	(toWriteMessage, fromWriteMessage) = fromJust writeMessageHandlers
	connectionTask = wrapConnectionTask handlers unitShare

	handlers = {ConnectionHandlers| onConnect = onConnect,
		onData = onData,
		onShareChange = onShareChange,
209 210
		onDisconnect = onDisconnect,
		onDestroy = onDestroy}
Haye Böhm's avatar
Haye Böhm committed
211 212 213 214 215 216 217 218 219 220 221 222 223 224

	onConnect connId _ _	= (Ok (Left ""), Nothing, [toWriteMessage p w +++ "\n"], False)

	onData data (Left acc) _
	# newacc = acc +++ data
	= case fromWriteMessage p newacc of
		Error e 		= (Error e, Nothing, [], True)
		Ok Nothing		= (Ok (Left newacc), Nothing, [], False)
		Ok (Just pred) 	= (Ok (Right pred), Nothing, [], True)
	onData data state _ = (Ok state, Nothing, [], True)

	onShareChange state _ = (Ok state, Nothing, [], False)
	onDisconnect state _ = (Ok state, Nothing)

225 226 227 228 229 230 231
queueRead :: !(SDSRemoteSource p r w) p !TaskId !Bool !SDSIdentity !*IWorld
	-> (!MaybeError TaskException ConnectionId, !*IWorld)
	| gText{|*|} p & TC p & TC r & TC w
queueRead rsds=:(SDSRemoteSource sds (Just _) _) _ _ _ _ iworld = (Error $ exception "queueRead while already a connection id", iworld)
queueRead rsds=:(SDSRemoteSource sds Nothing {SDSShareOptions|domain, port}) p taskId register reqSDSId iworld
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
	(Ok (ReadingDone r), iworld) = (readSymbols r, iworld)
232
	_ = abort "Reading symbols failed!"
233 234
# (request, iworld) = buildRequest register iworld
= queueSDSRequest request domain port taskId symbols iworld
235
where
236 237
	buildRequest True iworld=:{options}= (SDSRegisterRequest sds p reqSDSId (sdsIdentity rsds) taskId options.sdsPort, iworld)
	buildRequest False iworld = (SDSReadRequest sds p, iworld)
238

239
queueRemoteRefresh :: ![(TaskId, RemoteNotifyOptions)] !*IWorld -> *IWorld
240
queueRemoteRefresh [] iworld = iworld
241
queueRemoteRefresh [(reqTaskId, remoteOpts) : reqs] iworld=:{options}
242
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
Haye Böhm's avatar
Haye Böhm committed
243
	(Ok (ReadingDone r), iworld) = (readSymbols r, iworld)
244 245
# request = reqq reqTaskId remoteOpts.remoteSdsId
= case queueSDSRequest request remoteOpts.hostToNotify remoteOpts.portToNotify SDSSERVICE_TASK_ID symbols iworld of
246
	(_, iworld) = queueRemoteRefresh reqs iworld
247
where
248 249
	reqq :: !TaskId !SDSIdentity -> SDSRequest () String ()
	reqq taskId sdsId = SDSRefreshRequest taskId sdsId
250

251
queueWrite :: !w !(SDSRemoteSource p r w) p !TaskId !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | gText{|*|} p & TC p & TC r & TC w
252 253 254 255
queueWrite w rsds=:(SDSRemoteSource sds (Just _) _) _ _ iworld = (Error $ exception "queueWrite while already a connection id", iworld)
queueWrite w rsds=:(SDSRemoteSource sds Nothing share=:{SDSShareOptions|domain, port}) p taskId iworld
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
	(Ok (ReadingDone r), iworld) = (readSymbols r, iworld)
256
# request = SDSWriteRequest sds p w
257
= queueWriteRequest request domain port taskId symbols iworld
258

259
queueModify :: !(r -> MaybeError TaskException w) !(SDSRemoteSource p r w) p !TaskId !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | gText{|*|} p & TC p & TC r & TC w
260 261 262 263
queueModify f rsds=:(SDSRemoteSource sds (Just _)_) _ _ iworld = (Error $ exception "queueModify while already a connection id", iworld)
queueModify f rsds=:(SDSRemoteSource sds Nothing share=:{SDSShareOptions|domain, port}) p taskId iworld
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
	(Ok (ReadingDone r), iworld) = (readSymbols r, iworld)
264
# request = SDSModifyRequest sds p f
265
= queueModifyRequest request domain port taskId symbols iworld
266

Haye Böhm's avatar
Haye Böhm committed
267 268
getAsyncServiceValue :: !(SDSRemoteService p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe r) | TC r & TC w & TC p
getAsyncServiceValue service taskId connectionId ioStates
Haye Böhm's avatar
Haye Böhm committed
269
# getValue = case service of
270 271
	SDSRemoteService _ (HTTPShareOptions _) = getValueHttp
	SDSRemoteService _ (TCPShareOptions _) = getValueTCP
Haye Böhm's avatar
Haye Böhm committed
272 273
=  case 'DM'.get taskId ioStates of
		Nothing                             = Error (exception "No iostate for this task")
274 275 276 277
		Just ioState                        = case ioState of
			IOException exc                   = Error (exception exc)
			IOActive connectionMap            = getValue connectionId connectionMap
			IODestroyed connectionMap         = getValue connectionId connectionMap
Haye Böhm's avatar
Haye Böhm committed
278
where
Haye Böhm's avatar
Haye Böhm committed
279
	getValueHttp connectionId connectionMap = case 'DM'.get connectionId connectionMap of
280
		Just (value :: Either [String] r^, _) = case value of
Haye Böhm's avatar
Haye Böhm committed
281 282
			(Left _)                                = Ok Nothing
			(Right val)                     		= Ok (Just val)
283 284 285 286 287 288
		Just (dyn, _)
			# message = "Dynamic not of the correct service type, got: "
				+++ toString (typeCodeOfDynamic dyn)
				+++ ", required: "
				+++ toString (typeCodeOfDynamic (dynamic service))
			= Error (exception message)
Haye Böhm's avatar
Haye Böhm committed
289 290
		Nothing                             	= Ok Nothing

Haye Böhm's avatar
Haye Böhm committed
291 292
	getValueTCP connectionId connectionMap
	= case 'DM'.get connectionId connectionMap of
293 294 295
		Just (value :: (Maybe r^, [String]), _) = case value of
				(Nothing, _)                        = Ok Nothing
				(Just r,_)                     		= Ok (Just r)
296 297 298 299 300 301
		Just (dyn, _)
			# message = "Dynamic not of the correct service type, got: "
				+++ toString (typeCodeOfDynamic dyn)
				+++ ", required: "
				+++ toString (typeCodeOfDynamic (dynamic service))
			= Error (exception message)
Haye Böhm's avatar
Haye Böhm committed
302 303
		Nothing                             	= Ok Nothing

Haye Böhm's avatar
Haye Böhm committed
304 305 306
getAsyncServiceWriteValue :: !(SDSRemoteService p r w) !TaskId !ConnectionId !IOStates -> MaybeError TaskException (Maybe (SDSNotifyPred p)) | TC p & TC w & TC r
getAsyncServiceWriteValue service taskId connectionId ioStates
# getValue = case service of
307 308
	SDSRemoteService _ (HTTPShareOptions _) = getValueHttp
	SDSRemoteService _ (TCPShareOptions _) = getValueTCP
Haye Böhm's avatar
Haye Böhm committed
309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340
=  case 'DM'.get taskId ioStates of
		Nothing                             = Error (exception "No iostate for this task")
		Just ioState                        = case ioState of
			IOException exc                   = Error (exception exc)
			IOActive connectionMap            = getValue connectionId connectionMap
			IODestroyed connectionMap         = getValue connectionId connectionMap
where
	getValueHttp connectionId connectionMap = case 'DM'.get connectionId connectionMap of
		Just (value :: Either [String] (SDSNotifyPred p^), _) = case value of
			Left _                              = Ok Nothing
			Right pred                     		= Ok (Just pred)
		Just (dyn, _)
			# message = "Dynamic not of the correct service type, got: "
				+++ toString (typeCodeOfDynamic dyn)
				+++ ", required: "
				+++ toString (typeCodeOfDynamic (dynamic service))
			= Error (exception message)
		Nothing                             	= Ok Nothing

	getValueTCP connectionId connectionMap
	= case 'DM'.get connectionId connectionMap of
		Just (value :: Either String (SDSNotifyPred p^), _) = case value of
				Left _                       	= Ok Nothing
				Right pred                     	= Ok (Just pred)
		Just (dyn, _)
			# message = "Dynamic not of the correct service type, got: "
				+++ toString (typeCodeOfDynamic dyn)
				+++ ", required: "
				+++ toString (typeCodeOfDynamic (dynamic service))
			= Error (exception message)
		Nothing                             	= Ok Nothing

341
getAsyncReadValue :: !(sds p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe r) | TC r
342 343
getAsyncReadValue _ taskId connectionId ioStates
=  case 'DM'.get taskId ioStates of
344
		Nothing                             = Error (exception "No iostate for this task")
345
		(Just ioState)                      = case ioState of
346
			(IOException exc)                   = Error (exception exc)
347 348
			(IOActive connectionMap)            = getValue connectionId connectionMap
			(IODestroyed connectionMap)         = getValue connectionId connectionMap
349
where
350
	getValue connectionId connectionMap = case 'DM'.get connectionId connectionMap of
351 352 353 354
		(Just (value :: Either [String] (MaybeError TaskException r^), _)) = case value of
			(Left _)                                = Ok Nothing
			(Right (Ok val))                        = Ok (Just val)
			(Right (Error e))						= Error e
Haye Böhm's avatar
Haye Böhm committed
355
		(Just (dyn, _))							= Error (exception ("Dynamic not of the correct read type, got" +++ toString (typeCodeOfDynamic dyn)))
356 357
		Nothing                             	= Ok Nothing

358
getAsyncWriteValue :: !(sds p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe ()) | TC w
359
getAsyncWriteValue _ taskId connectionId ioStates =  case 'DM'.get taskId ioStates of
360
		Nothing                             = Error (exception "No iostate for this task")
361
		(Just ioState)                      = case ioState of
362
			(IOException exc)                   = Error (exception exc)
363 364
			(IOActive connectionMap)            = getValue connectionId connectionMap
			(IODestroyed connectionMap)         = getValue connectionId connectionMap
365
where
366
	getValue connectionId connectionMap = case 'DM'.get connectionId connectionMap of
367
		(Just (value :: Either [String] (MaybeError TaskException ()), _)) = case value of
368 369 370 371 372 373 374
			(Left _)                                    = Ok Nothing
			(Right (Ok val))                            = Ok (Just val)
			(Right (Error e))							= Error e
		(Just (dyn, _))						= Error (exception ("Dynamic not of the correct write type, got" +++ toString (typeCodeOfDynamic dyn)))
		Nothing                             = Ok Nothing

getAsyncModifyValue :: !(sds p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe (r,w)) | TC w & TC r
375
getAsyncModifyValue _ taskId connectionId ioStates =  case 'DM'.get taskId ioStates of
376
		Nothing                             = Error (exception "No iostate for this task")
377
		(Just ioState)                      = case ioState of
378
			(IOException exc)                   = Error (exception exc)
379 380
			(IOActive connectionMap)            = getValue connectionId connectionMap
			(IODestroyed connectionMap)         = getValue connectionId connectionMap
381
where
382 383
	getValue connectionId connectionMap
	= case 'DM'.get connectionId connectionMap of
384 385 386 387 388
		(Just (value :: Either [String] (MaybeError TaskException (r^, w^)), _)) = case value of
			(Left _)						= Ok Nothing
			(Right (Ok val))				= Ok (Just val)
			(Right (Error e))				= Error e
		(Just (dyn, _))					= Error (exception ("Dynamic not of the correct modify type, got " +++ toString (typeCodeOfDynamic dyn)))
389
		Nothing 						= Ok Nothing
390

Mart Lubbers's avatar
Mart Lubbers committed
391 392 393 394
asyncSDSLoaderUI :: !AsyncAction -> UI
asyncSDSLoaderUI Read = uia UIProgressBar (textAttr "Reading data")
asyncSDSLoaderUI Write = uia UIProgressBar (textAttr "Writing data")
asyncSDSLoaderUI Modify = uia UIProgressBar (textAttr "Modifying data")
395 396 397

readCompletely :: (sds () r w) (TaskValue a) (r Event TaskEvalOpts *IWorld -> *(TaskResult a, *IWorld)) Event TaskEvalOpts !*IWorld
	-> *(TaskResult a, *IWorld) | Readable sds & TC r & TC w
Mart Lubbers's avatar
Mart Lubbers committed
398
readCompletely _ _ _ DestroyEvent _ iworld
399
	= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
400
readCompletely sds tv cont event evalOpts=:{TaskEvalOpts|taskId,lastEval} iworld
401 402 403 404 405
	= case read sds (TaskContext taskId) iworld of
		(Error e, iworld) = (ExceptionResult e, iworld)
		(Ok (ReadingDone r), iworld)
			= cont r event evalOpts iworld
		(Ok (Reading sds), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
406
			= (ValueResult tv (mkTaskEvalInfo lastEval) (mkUIIfReset event (asyncSDSLoaderUI Read)) (Task (readCompletely sds tv cont)), iworld)
407 408 409 410 411

writeCompletely :: w (sds () r w) (TaskValue a) (Event TaskEvalOpts *IWorld -> *(TaskResult a, *IWorld)) Event TaskEvalOpts !*IWorld
	-> *(TaskResult a, *IWorld) | Writeable sds & TC r & TC w
writeCompletely _ _ _ cont DestroyEvent evalOpts iworld
	= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
412
writeCompletely w sds tv cont event evalOpts=:{taskId,lastEval} iworld
413 414 415 416 417
	= case write w sds (TaskContext taskId) iworld of
		(Error e, iworld) = (ExceptionResult e, iworld)
		(Ok (WritingDone), iworld)
			= cont event evalOpts iworld
		(Ok (Writing sds), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
418
			= (ValueResult tv (mkTaskEvalInfo lastEval) (mkUIIfReset event (asyncSDSLoaderUI Write)) (Task (writeCompletely w sds tv cont)), iworld)
419

Mart Lubbers's avatar
Mart Lubbers committed
420
modifyCompletely :: (r -> w) (sds () r w) (TaskValue a) (Event -> UIChange) (w Event TaskEvalOpts *IWorld -> *(TaskResult a, *IWorld)) Event TaskEvalOpts !*IWorld
421
	-> *(TaskResult a, *IWorld) | TC r & TC w & Modifiable sds
Mart Lubbers's avatar
Mart Lubbers committed
422
modifyCompletely _ _ _ _ cont DestroyEvent evalOpts iworld
423
	= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
424
modifyCompletely modfun sds tv ui cont event evalOpts=:{taskId,lastEval} iworld
425 426 427 428 429
	= case modify modfun sds (TaskContext taskId) iworld of
		(Error e, iworld) = (ExceptionResult e, iworld)
		(Ok (ModifyingDone w), iworld)
			= cont w event evalOpts iworld
		(Ok (Modifying sds modfun), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
430
			= (ValueResult tv (mkTaskEvalInfo lastEval) (ui event) (Task (modifyCompletely modfun sds tv ui cont)), iworld)
431 432 433 434 435

readRegisterCompletely :: (sds () r w) (TaskValue a) (Event -> UIChange) (r Event TaskEvalOpts *IWorld -> *(TaskResult a, *IWorld)) Event TaskEvalOpts !*IWorld
	-> *(TaskResult a, *IWorld) | TC r & TC w & Registrable sds
readRegisterCompletely _ _ _ cont DestroyEvent evalOpts iworld
	= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
436
readRegisterCompletely sds tv ui cont event evalOpts=:{taskId,lastEval} iworld
437
	| not (isRefreshForTask event taskId)
Mart Lubbers's avatar
Mart Lubbers committed
438
		= (ValueResult tv (mkTaskEvalInfo lastEval) (ui event) (Task (readRegisterCompletely sds tv ui cont)), iworld)
439 440 441 442 443 444 445
	= case readRegister taskId sds iworld of
		(Error e, iworld) = (ExceptionResult e, iworld)
		(Ok (ReadingDone r), iworld)
			= cont r event evalOpts iworld
		(Ok (Reading sds), iworld)
			= (ValueResult
				tv
Mart Lubbers's avatar
Mart Lubbers committed
446
				(mkTaskEvalInfo lastEval)
447 448 449
				(ui event)
				(Task (readRegisterCompletely sds tv ui cont))
			, iworld)