module OpcXmlDaClient
  ( -- * Operations
    Op,
    getStatus,
    read,
    write,
    subscribe,
    subscriptionPolledRefresh,
    subscriptionCancel,
    browse,
    getProperties,

    -- ** Operation parameter types
    Uri,
    textUri,
    RequestTimeout,
    millisecondsRequestTimeout,

    -- ** Operation errors
    Error (..),

    -- * Value types
    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

-- * Operations

-- |
-- Alias to an HTTP request operation in the scope of
-- HTTP connection manager, timeout for the operation, URI of the server.
--
-- All errors are explicit and are wrapped by the 'Error' type.
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

-- * Helper types

-- |
-- URI of the server.
newtype Uri = Uri Hc.Request

-- |
-- Construct a correct URI by validating a textual value.
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

-- |
-- RequestTimeout of 30 seconds.
instance Default RequestTimeout where
  def :: RequestTimeout
def = Int -> RequestTimeout
RequestTimeout Int
30000

-- |
-- Construct a request timeout value,
-- ensuring that it's in the proper range.
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

-- * Errors

-- |
-- Error during the execution of an operation.
data Error
  = HttpError Hc.HttpExceptionContent
  | IoError IOException
  | ParsingError Text
  | SoapError SoapFault

instance Eq Error where
  (HttpError HttpExceptionContent
_) == :: Error -> Error -> Bool
== (HttpError HttpExceptionContent
_) = Bool
False -- NOTE: HttpEcxceptionContent has not EQ instance
  (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)