module OpcXmlDaClient
(
Op,
getStatus,
read,
write,
subscribe,
subscriptionPolledRefresh,
subscriptionCancel,
browse,
getProperties,
Uri,
textUri,
RequestTimeout,
millisecondsRequestTimeout,
Error (..),
module OpcXmlDaClient.Protocol.Types,
module OpcXmlDaClient.XmlSchemaValues.Types,
)
where
import qualified Data.Text as Text
import qualified Network.HTTP.Client as Hc
import OpcXmlDaClient.Base.Prelude hiding (Read, read)
import OpcXmlDaClient.Protocol.Types
import qualified OpcXmlDaClient.Protocol.XmlConstruction as XmlConstruction
import qualified OpcXmlDaClient.Protocol.XmlParsing as XmlParsing
import OpcXmlDaClient.XmlSchemaValues.Types
import qualified XmlParser
type Op i o = Hc.Manager -> RequestTimeout -> Uri -> i -> IO (Either Error o)
getStatus :: Op GetStatus GetStatusResponse
getStatus :: Op GetStatus GetStatusResponse
getStatus = (GetStatus -> ByteString)
-> Element (Either SoapFault GetStatusResponse)
-> Op GetStatus GetStatusResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp GetStatus -> ByteString
XmlConstruction.getStatus Element (Either SoapFault GetStatusResponse)
XmlParsing.getStatusResponse
read :: Op Read ReadResponse
read :: Op Read ReadResponse
read = (Read -> ByteString)
-> Element (Either SoapFault ReadResponse) -> Op Read ReadResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp Read -> ByteString
XmlConstruction.read Element (Either SoapFault ReadResponse)
XmlParsing.readResponse
write :: Op Write WriteResponse
write :: Op Write WriteResponse
write = (Write -> ByteString)
-> Element (Either SoapFault WriteResponse)
-> Op Write WriteResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp Write -> ByteString
XmlConstruction.write Element (Either SoapFault WriteResponse)
XmlParsing.writeResponse
subscribe :: Op Subscribe SubscribeResponse
subscribe :: Op Subscribe SubscribeResponse
subscribe = (Subscribe -> ByteString)
-> Element (Either SoapFault SubscribeResponse)
-> Op Subscribe SubscribeResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp Subscribe -> ByteString
XmlConstruction.subscribe Element (Either SoapFault SubscribeResponse)
XmlParsing.subscribeResponse
subscriptionPolledRefresh :: Op SubscriptionPolledRefresh SubscriptionPolledRefreshResponse
subscriptionPolledRefresh :: Op SubscriptionPolledRefresh SubscriptionPolledRefreshResponse
subscriptionPolledRefresh = (SubscriptionPolledRefresh -> ByteString)
-> Element (Either SoapFault SubscriptionPolledRefreshResponse)
-> Op SubscriptionPolledRefresh SubscriptionPolledRefreshResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp SubscriptionPolledRefresh -> ByteString
XmlConstruction.subscriptionPolledRefresh Element (Either SoapFault SubscriptionPolledRefreshResponse)
XmlParsing.subscriptionPolledRefreshResponse
subscriptionCancel :: Op SubscriptionCancel SubscriptionCancelResponse
subscriptionCancel :: Op SubscriptionCancel SubscriptionCancelResponse
subscriptionCancel = (SubscriptionCancel -> ByteString)
-> Element (Either SoapFault SubscriptionCancelResponse)
-> Op SubscriptionCancel SubscriptionCancelResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp SubscriptionCancel -> ByteString
XmlConstruction.subscriptionCancel Element (Either SoapFault SubscriptionCancelResponse)
XmlParsing.subscriptionCancelResponse
browse :: Op Browse BrowseResponse
browse :: Op Browse BrowseResponse
browse = (Browse -> ByteString)
-> Element (Either SoapFault BrowseResponse)
-> Op Browse BrowseResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp Browse -> ByteString
XmlConstruction.browse Element (Either SoapFault BrowseResponse)
XmlParsing.browseResponse
getProperties :: Op GetProperties GetPropertiesResponse
getProperties :: Op GetProperties GetPropertiesResponse
getProperties = (GetProperties -> ByteString)
-> Element (Either SoapFault GetPropertiesResponse)
-> Op GetProperties GetPropertiesResponse
forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp GetProperties -> ByteString
XmlConstruction.getProperties Element (Either SoapFault GetPropertiesResponse)
XmlParsing.getPropertiesResponse
encDecOp :: (i -> ByteString) -> XmlParser.Element (Either SoapFault o) -> Op i o
encDecOp :: forall i o.
(i -> ByteString) -> Element (Either SoapFault o) -> Op i o
encDecOp i -> ByteString
encode Element (Either SoapFault o)
decode Manager
manager (RequestTimeout Int
timeout) (Uri Request
request) i
input = do
let encodedInput :: ByteString
encodedInput = i -> ByteString
encode i
input
Request
request
{ method :: ByteString
Hc.method = ByteString
"POST",
requestHeaders :: RequestHeaders
Hc.requestHeaders =
[ (HeaderName
"Content-Type", ByteString
"application/soap+xml; charset=utf-8")
],
requestBody :: RequestBody
Hc.requestBody = ByteString -> RequestBody
Hc.RequestBodyBS ByteString
encodedInput,
responseTimeout :: ResponseTimeout
Hc.responseTimeout = Int -> ResponseTimeout
Hc.responseTimeoutMicro (Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
}
Request -> (Request -> IO (Either Error o)) -> IO (Either Error o)
forall a b. a -> (a -> b) -> b
& \Request
request -> do
Either SomeException (Response ByteString)
response <- IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
-> IO (Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Hc.httpLbs Request
request Manager
manager
case Either SomeException (Response ByteString)
response of
Left SomeException
exc
| Just HttpException
exc <- forall e. Exception e => SomeException -> Maybe e
fromException @Hc.HttpException SomeException
exc -> case HttpException
exc of
Hc.HttpExceptionRequest Request
_ HttpExceptionContent
reason -> Either Error o -> IO (Either Error o)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error o -> IO (Either Error o))
-> Either Error o -> IO (Either Error o)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error o
forall a b. a -> Either a b
Left (Error -> Either Error o) -> Error -> Either Error o
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> Error
HttpError HttpExceptionContent
reason
Hc.InvalidUrlException String
uri String
reason -> String -> IO (Either Error o)
forall a. HasCallStack => String -> a
error (String -> IO (Either Error o)) -> String -> IO (Either Error o)
forall a b. (a -> b) -> a -> b
$ String
"Invalid URI: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
uri String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reason
| Just IOException
exc <- forall e. Exception e => SomeException -> Maybe e
fromException @IOException SomeException
exc ->
Either Error o -> IO (Either Error o)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error o -> IO (Either Error o))
-> Either Error o -> IO (Either Error o)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error o
forall a b. a -> Either a b
Left (Error -> Either Error o) -> Error -> Either Error o
forall a b. (a -> b) -> a -> b
$ IOException -> Error
IoError IOException
exc
| Bool
otherwise -> SomeException -> IO (Either Error o)
forall e a. Exception e => e -> IO a
throwIO SomeException
exc
Right Response ByteString
response -> do
Either Error o -> IO (Either Error o)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error o -> IO (Either Error o))
-> Either Error o -> IO (Either Error o)
forall a b. (a -> b) -> a -> b
$ case Element (Either SoapFault o)
-> ByteString -> Either Text (Either SoapFault o)
forall a. Element a -> ByteString -> Either Text a
XmlParser.parseLazyByteString Element (Either SoapFault o)
decode (Response ByteString -> ByteString
forall body. Response body -> body
Hc.responseBody Response ByteString
response) of
Right Either SoapFault o
res -> case Either SoapFault o
res of
Right o
res -> o -> Either Error o
forall a b. b -> Either a b
Right o
res
Left SoapFault
err -> Error -> Either Error o
forall a b. a -> Either a b
Left (Error -> Either Error o) -> Error -> Either Error o
forall a b. (a -> b) -> a -> b
$ SoapFault -> Error
SoapError SoapFault
err
Left Text
err -> Error -> Either Error o
forall a b. a -> Either a b
Left (Error -> Either Error o) -> Error -> Either Error o
forall a b. (a -> b) -> a -> b
$ Text -> Error
ParsingError Text
err
newtype Uri = Uri Hc.Request
textUri :: Text -> Maybe Uri
textUri :: Text -> Maybe Uri
textUri = (Request -> Uri) -> Maybe Request -> Maybe Uri
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Uri
Uri (Maybe Request -> Maybe Uri)
-> (Text -> Maybe Request) -> Text -> Maybe Uri
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
Hc.parseRequest (String -> Maybe Request)
-> (Text -> String) -> Text -> Maybe Request
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack
newtype RequestTimeout = RequestTimeout Int
instance Default RequestTimeout where
def :: RequestTimeout
def = Int -> RequestTimeout
RequestTimeout Int
30000
millisecondsRequestTimeout :: Int -> Maybe RequestTimeout
millisecondsRequestTimeout :: Int -> Maybe RequestTimeout
millisecondsRequestTimeout Int
x =
if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
then RequestTimeout -> Maybe RequestTimeout
forall a. a -> Maybe a
Just (RequestTimeout -> Maybe RequestTimeout)
-> RequestTimeout -> Maybe RequestTimeout
forall a b. (a -> b) -> a -> b
$ Int -> RequestTimeout
RequestTimeout Int
x
else Maybe RequestTimeout
forall a. Maybe a
Nothing
data Error
= HttpError Hc.HttpExceptionContent
| IoError IOException
| ParsingError Text
| SoapError SoapFault
instance Eq Error where
(HttpError HttpExceptionContent
_) == :: Error -> Error -> Bool
== (HttpError HttpExceptionContent
_) = Bool
False
(IoError IOException
a) == (IoError IOException
b) = IOException
a IOException -> IOException -> Bool
forall a. Eq a => a -> a -> Bool
== IOException
b
(ParsingError Text
a) == (ParsingError Text
b) = Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
b
(SoapError SoapFault
a) == (SoapError SoapFault
b) = SoapFault
a SoapFault -> SoapFault -> Bool
forall a. Eq a => a -> a -> Bool
== SoapFault
b
(==) Error
_ Error
_ = Bool
False
instance Show Error where
show :: Error -> String
show = \case
HttpError HttpExceptionContent
a -> String -> String -> String
showString String
"HTTP error: " (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
a
IoError IOException
a -> String -> String -> String
showString String
"IO error: " (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
a
ParsingError Text
a -> String -> String -> String
showString String
"Parsing error: " (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
a
SoapError SoapFault
a ->
String
"SOAP fault response with code: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SoapFaultCode -> String
forall a. Show a => a -> String
show (IsLabel "code" (SoapFault -> SoapFaultCode)
SoapFault -> SoapFaultCode
#code SoapFault
a) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Reason: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (IsLabel "reason" (SoapFault -> Text)
SoapFault -> Text
#reason SoapFault
a)