Commit 6c130794 authored by Haye Böhm's avatar Haye Böhm

Implement writing to services

parent d48518ba
Pipeline #17242 failed with stage
in 1 minute and 26 seconds
......@@ -3,7 +3,7 @@ module RemoteServiceExamples
import iTasks
import Internet.HTTP
import Data.Either
import Data.Either, Data.Func
:: OpenWeatherRequest =
{ apiKey :: String
......@@ -25,11 +25,13 @@ where
serviceTask = get weatherService >>= viewInformation "Current weather" []
// api.openweathermap.org/data/2.5/weather?q=London,uk
weatherOptions :: OpenWeatherRequest -> WebServiceShareOptions () (Either String OpenWeatherResponse)
weatherOptions :: OpenWeatherRequest -> WebServiceShareOptions () (Either String OpenWeatherResponse) ()
weatherOptions owr = HTTPShareOptions {host = "api.openweathermap.org"
, port = 80
, createRequest = \_. toRequest owr
, fromResponse = \response p. fromResp response}
, createRequest = const $ toRequest owr
, fromResponse = \response p. fromResp response
, writeHandlers = Nothing // Service cannot be written to
}
where
toRequest {OpenWeatherRequest|apiKey, type}
# r = newHTTPRequest
......
......@@ -37,6 +37,8 @@ queueRead :: !(SDSRemoteSource p r w) p !TaskId !Bool !SDSIdentity !*IWorld -> (
*/
queueServiceRequest :: !(SDSRemoteService p r w) p !TaskId !Bool !*IWorld -> (!MaybeError TaskException ConnectionId, !*IWorld) | gText{|*|} p & TC p & TC r
queueServiceWriteRequest :: !(SDSRemoteService p r w) !p !w !TaskId !*IWorld -> (MaybeError TaskException (Maybe ConnectionId), !*IWorld) | TC p & TC w
/**
* Queue that a task on a remote service should refresh itself.
* @param Remote notify requests
......@@ -77,6 +79,8 @@ getAsyncReadValue :: !(sds p r w) !TaskId !ConnectionId IOStates -> MaybeError T
getAsyncServiceValue :: !(SDSRemoteService p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe r) | TC r & TC w & TC p
getAsyncServiceWriteValue :: !(SDSRemoteService p r w) !TaskId !ConnectionId !IOStates -> MaybeError TaskException (Maybe (SDSNotifyPred p)) | TC p & TC w & TC r
/**
* Queries IOStates to see whether a write operation has yielded a result.
* @param the share, required for typing reasons.
......
......@@ -122,8 +122,8 @@ queueServiceRequest service=:(SDSRemoteService (TCPShareOptions {host, port, cre
(Error e, env) = (Error e, env)
(Ok (id, _), env) = (Ok id, env)
where
connectionTask = wrapConnectionTask (handlers service) unitShare
handlers req = {ConnectionHandlers| onConnect = onConnect,
connectionTask = wrapConnectionTask handlers unitShare
handlers = {ConnectionHandlers| onConnect = onConnect,
onData = onData,
onShareChange = onShareChange,
onDisconnect = onDisconnect}
......@@ -145,6 +145,65 @@ where
onShareChange state _ = (Ok state, Nothing, [], False)
onDisconnect state _ = (Ok state, Nothing)
queueServiceWriteRequest :: !(SDSRemoteService p r w) !p !w !TaskId !*IWorld -> (MaybeError TaskException (Maybe ConnectionId), !*IWorld) | TC p & TC w
queueServiceWriteRequest service=:(SDSRemoteService (HTTPShareOptions {host, port, writeHandlers})) p w taskId iworld
| isNothing writeHandlers = (Ok Nothing, iworld) // Writing not supported for this share.
= case addConnection taskId host port connectionTask iworld of
(Error e, env) = (Error e, env)
(Ok (id, _), env) = (Ok (Just id), env)
where
(toWriteRequest, fromWriteResponse) = fromJust writeHandlers
connectionTask = wrapConnectionTask handlers unitShare
handlers = { ConnectionHandlers|onConnect = onConnect
, onData = onData
, onShareChange = onShareChange
, onDisconnect = onDisconnect
}
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)
queueServiceWriteRequest service=:(SDSRemoteService (TCPShareOptions {host, port, writeMessageHandlers})) p w taskId iworld
| isNothing writeMessageHandlers = (Ok Nothing, iworld)
= case addConnection taskId host port connectionTask iworld of
(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,
onDisconnect = onDisconnect}
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)
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 {SDSShareOptions|domain, port}) p taskId register reqSDSId env
# (symbols, env) = case read symbolsShare EmptyContext env of
......@@ -221,6 +280,45 @@ where
= Error (exception message)
Nothing = Ok Nothing
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
SDSRemoteService (HTTPShareOptions _) = getValueHttp
SDSRemoteServiceQueued _ _ (HTTPShareOptions _) = getValueHttp
SDSRemoteService (TCPShareOptions _) = getValueTCP
SDSRemoteServiceQueued _ _ (TCPShareOptions _) = getValueTCP
= 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
getAsyncReadValue :: !(sds p r w) !TaskId !ConnectionId IOStates -> MaybeError TaskException (Maybe r) | TC r
getAsyncReadValue _ taskId connectionId ioStates
= case 'DM'.get taskId ioStates of
......
......@@ -861,7 +861,25 @@ instance Readable SDSRemoteService where
(Ok connectionId, iworld) = (Ok (AsyncRead (SDSRemoteServiceQueued connectionId sds opts)), iworld)
instance Writeable SDSRemoteService where
writeSDS _ _ _ _ iworld = (Error (exception "cannot write to remote services yet"), iworld)
writeSDS sds p EmptyContext value iworld = (Error (exception "cannot write remote service without task id"), iworld)
writeSDS sds=:(SDSRemoteServiceQueued connectionId rsds opts) p (TaskContext taskId) value iworld=:{ioStates}
= case getAsyncServiceWriteValue sds taskId connectionId ioStates of
Error (_, error)
# errorString = "Remote service write queued error<br>Service " +++ toString opts +++ ": " +++ error
= (Error (exception errorString), iworld)
Ok Nothing = (Ok (AsyncWrite sds), iworld)
Ok (Just pred)
# (match,nomatch, iworld) = checkRegistrations (sdsIdentity rsds) pred iworld
= (Ok (WriteResult match sds), iworld)
writeSDS sds=:(SDSRemoteService opts) p (TaskContext taskId) value iworld
= case queueServiceWriteRequest sds p value taskId iworld of
(Error (_, error), iworld)
# errorString = "Remote service write error<br>Service " +++ toString opts +++ ": " +++ error
= (Error $ exception errorString, iworld)
(Ok Nothing, iworld) = (Ok $ WriteResult 'Set'.newSet sds, iworld)
(Ok (Just connectionId), iworld) = (Ok $ AsyncWrite $ SDSRemoteServiceQueued connectionId sds opts, iworld)
instance Modifiable SDSRemoteService where
modifySDS _ _ _ _ iworld = (Error (exception "modifying remote services not possible"), iworld)
......
......@@ -278,13 +278,17 @@ required type w. The reducer has the job to turn this ws into w.
{ host :: String
, port :: Int
, createRequest :: p -> HTTPRequest
, fromResponse :: HTTPResponse p -> MaybeErrorString r}
, fromResponse :: HTTPResponse p -> MaybeErrorString r
, writeHandlers :: Maybe (p w -> HTTPRequest, p HTTPResponse -> MaybeErrorString (SDSNotifyPred p))
}
:: TCPHandlers p r w =
{ host :: String
, port :: Int
, createMessage :: p -> String
, fromTextResponse :: String p Bool -> MaybeErrorString (Maybe r, Maybe String)}
, fromTextResponse :: String p Bool -> MaybeErrorString (Maybe r, Maybe String)
, writeMessageHandlers :: Maybe (p w -> String, p String -> MaybeErrorString (Maybe (SDSNotifyPred p)))
}
:: SDSRemoteService p r w =
/**
......
......@@ -32,6 +32,6 @@ blobStoreShare :: !String !Bool !(Maybe {#Char}) -> SDSSequence String {#Char} {
remoteShare :: (sds p r w) SDSShareOptions -> SDSRemoteSource p r w | RWShared sds
remoteService :: (WebServiceShareOptions p r ()) -> SDSRemoteService p r ()
remoteService :: (WebServiceShareOptions p r w) -> SDSRemoteService p r w
debugShare :: String (sds p r w) -> SDSDebug p r w | RWShared sds
......@@ -110,7 +110,7 @@ where
remoteShare :: (sds p r w) SDSShareOptions -> SDSRemoteSource p r w | RWShared sds
remoteShare sds opts = SDSRemoteSource sds opts
remoteService :: (WebServiceShareOptions p r ()) -> SDSRemoteService p r ()
remoteService :: (WebServiceShareOptions p r w) -> SDSRemoteService p r w
remoteService opts = SDSRemoteService opts
debugShare :: String (sds p r w) -> SDSDebug p r w | RWShared sds
......
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