opc-xml-da-client-0.1: protocol/OpcXmlDaClient/Protocol/XmlParsing.hs
module OpcXmlDaClient.Protocol.XmlParsing where
import qualified Attoparsec.Data as AttoparsecData
import qualified Data.Attoparsec.Text as Atto
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TextEncoding
import OpcXmlDaClient.Base.Prelude hiding (Read)
import qualified OpcXmlDaClient.Base.Vector as VectorUtil
import qualified OpcXmlDaClient.Protocol.Namespaces as Ns
import OpcXmlDaClient.Protocol.Types
import qualified OpcXmlDaClient.XmlSchemaValues.Attoparsec as XmlSchemaValuesAttoparsec
import OpcXmlDaClient.XmlSchemaValues.Types
import qualified Text.XML as Xml
import XmlParser
-- * Responses
opcResponse :: Text -> Element a -> Element (Either SoapFault a)
opcResponse opcElementName opcElementParser = do
elementNameIsOneOf [(Just Ns.soapEnv2, "Envelope"), (Just Ns.soapEnv, "Envelope")]
childrenByName $ bySoapEnvName "Body" $ childrenByName body
where
body =
Left <$> soapFault <|> Right <$> opcContent
where
soapFault = bySoapEnvName "Fault" $ childrenByName $ soapV1P2 <|> soapV1P1
where
soapV1P2 = do
_code <- bySoapEnvName "Code" $
childrenByName $
bySoapEnvName "Value" $
children $
contentNode $
do
qName <- adaptedQNameContent
case qName of
NamespacedQName ns name ->
if ns == Ns.soapEnv
then fmap StdSoapFaultCode $ case name of
"VersionMismatch" -> return $ #versionMismatch
"MustUnderstand" -> return $ #mustUnderstand
"DataEncodingUnknown" -> return $ #dataEncodingUnknown
"Sender" -> return $ #sender
"Receiver" -> return $ #receiver
_ -> fail ("Unexpected code: " <> show name)
else return $ #custom $ NamespacedQName ns name
_ -> return $ #custom $ qName
-- FIXME: We take the first reason here,
-- but the result really can be a map indexed by language
_reason <- orEmpty $ bySoapEnvName "Reason" $ childrenByName $ orEmpty $ bySoapEnvName "Text" $ children $ contentNode $ textContent
return $ SoapFault _code _reason
soapV1P1 = do
_code <- byName Nothing "faultcode" $
children $
contentNode $
do
qName <- adaptedQNameContent
case qName of
NamespacedQName ns name ->
if ns == Ns.soapEnv2
then fmap StdSoapFaultCode $ case name of
"VersionMismatch" -> return $ #versionMismatch
"MustUnderstand" -> return $ #mustUnderstand
"Client" -> return $ #sender
"Server" -> return $ #receiver
_ -> fail ("Unexpected code: " <> show name)
else return $ #custom $ NamespacedQName ns name
_ -> return $ #custom $ qName
-- FIXME: We take the first reason here,
-- but the result really can be a map indexed by language
_reason <- orEmpty $ byName Nothing "faultstring" $ children $ contentNode $ fmap Text.strip $ textContent
return $ SoapFault _code _reason
orEmpty _p = _p <|> pure mempty
opcContent =
byName (Just Ns.opc) opcElementName opcElementParser
getStatusResponse :: Element (Either SoapFault GetStatusResponse)
getStatusResponse =
opcResponse "GetStatusResponse" $
childrenByName $ do
_getStatusResult <- optional $ byName (Just Ns.opc) "GetStatusResult" $ replyBase
_status <- optional $ byName (Just Ns.opc) "Status" $ serverStatus
return $ GetStatusResponse _getStatusResult _status
readResponse :: Element (Either SoapFault ReadResponse)
readResponse =
opcResponse "ReadResponse" $
childrenByName $ do
_readResult <- optional $ byName (Just Ns.opc) "ReadResult" $ replyBase
_rItemList <- optional $ byName (Just Ns.opc) "RItemList" $ replyItemList
_errors <- VectorUtil.many $ byName (Just Ns.opc) "Errors" $ opcError
return $ ReadResponse _readResult _rItemList _errors
writeResponse :: Element (Either SoapFault WriteResponse)
writeResponse =
opcResponse "WriteResponse" $
childrenByName $ do
_writeResult <- optional $ byName (Just Ns.opc) "WriteResult" $ replyBase
_rItemList <- optional $ byName (Just Ns.opc) "RItemList" $ replyItemList
_errors <- VectorUtil.many $ byName (Just Ns.opc) "Errors" $ opcError
return $ WriteResponse _writeResult _rItemList _errors
subscribeResponse :: Element (Either SoapFault SubscribeResponse)
subscribeResponse =
opcResponse "SubscribeResponse" $
join $
attributesByName $ do
_subHandle <- optional $ byName Nothing "ServerSubHandle" $ textContent
return $
childrenByName $ do
_subscribeResult <- optional $ byName (Just Ns.opc) "SubscribeResult" $ replyBase
_rItemList <- optional $ byName (Just Ns.opc) "RItemList" $ subscribeReplyItemList
_errors <- VectorUtil.many $ byName (Just Ns.opc) "OPCError" $ opcError
return $ SubscribeResponse _subscribeResult _rItemList _errors _subHandle
subscriptionPolledRefreshResponse :: Element (Either SoapFault SubscriptionPolledRefreshResponse)
subscriptionPolledRefreshResponse =
opcResponse "SubscriptionPolledRefreshResponse" $
join $
childrenByName $ do
_subscriptionPolledRefreshResult <- optional $ byName (Just Ns.opc) "SubscriptionPolledRefreshResult" $ replyBase
_invalidServerSubHandles <- VectorUtil.many $ byName (Just Ns.opc) "InvalidServerSubHandles" $ children $ contentNode $ textContent
_rItemList <- VectorUtil.many $ byName (Just Ns.opc) "RItemList" $ subscribePolledRefreshReplyItemList
_errors <- VectorUtil.many $ byName (Just Ns.opc) "OPCError" $ opcError
return $
attributesByName $ do
_dataBufferOverflow <- byName Nothing "DataBufferOverflow" booleanContent <|> pure False
return $ SubscriptionPolledRefreshResponse _subscriptionPolledRefreshResult _invalidServerSubHandles _rItemList _errors _dataBufferOverflow
subscriptionCancelResponse :: Element (Either SoapFault SubscriptionCancelResponse)
subscriptionCancelResponse =
opcResponse "SubscriptionCancelResponse" $
childrenByName $ do
_clientRequestHandle <- optional $ byName (Just Ns.opc) "ClientRequestHandle" $ children $ contentNode $ textContent
return $ SubscriptionCancelResponse _clientRequestHandle
browseResponse :: Element (Either SoapFault BrowseResponse)
browseResponse =
opcResponse "BrowseResponse" $
join $
childrenByName $ do
_browseResult <- optional $ byName (Just Ns.opc) "BrowseResult" $ replyBase
_elements <- VectorUtil.many $ byName (Just Ns.opc) "Elements" $ browseElement
_errors <- VectorUtil.many $ byName (Just Ns.opc) "Errors" $ opcError
return $
attributesByName $ do
_continuationPoint <- optional $ byName Nothing "ContinuationPoint" $ textContent
_moreElements <- byName Nothing "MoreElements" booleanContent <|> pure False
return $ BrowseResponse _browseResult _elements _errors _continuationPoint _moreElements
getPropertiesResponse :: Element (Either SoapFault GetPropertiesResponse)
getPropertiesResponse =
opcResponse "GetPropertiesResponse" $
childrenByName $ do
_getPropertiesResult <- optional $ byName (Just Ns.opc) "GetPropertiesResult" $ replyBase
_propertiesList <- VectorUtil.many $ byName (Just Ns.opc) "PropertyLists" $ propertyReplyList
_errors <- VectorUtil.many $ byName (Just Ns.opc) "Errors" $ opcError
return $ GetPropertiesResponse _getPropertiesResult _propertiesList _errors
-- * Details
replyBase :: Element ReplyBase
replyBase =
attributesByName $ do
_rcvTime <- byName Nothing "RcvTime" dateTimeContent
_replyTime <- byName Nothing "ReplyTime" dateTimeContent
_clientRequestHandle <- optional $ byName Nothing "ClientRequestHandle" textContent
_revisedLocaleID <- optional $ byName Nothing "RevisedLocaleID" textContent
_serverState <- byName Nothing "ServerState" serverStateContent
return $ ReplyBase _rcvTime _replyTime _clientRequestHandle _revisedLocaleID _serverState
subscribeReplyItemList :: Element SubscribeReplyItemList
subscribeReplyItemList =
join $
attributesByName $ do
_revisedSamplingRate <- optional $ byName Nothing "RevisedSamplingRate" $ attoparsedContent Atto.decimal
return $ do
_items <- childrenByName $ VectorUtil.many $ byName (Just Ns.opc) "Items" $ subscribeItemValue
return (SubscribeReplyItemList _items _revisedSamplingRate)
subscribeItemValue :: Element SubscribeItemValue
subscribeItemValue =
join $
attributesByName $ do
_revisedSamplingRate <- optional $ byName Nothing "RevisedSamplingRate" $ attoparsedContent Atto.decimal
return $ do
_itemValue <- childrenByName $ byName (Just Ns.opc) "ItemValue" $ itemValue
return (SubscribeItemValue _itemValue _revisedSamplingRate)
opcError :: Element OpcError
opcError =
join $
attributesByName $ do
_id <- byName Nothing "ID" $ adaptedQNameContent
return $
childrenByName $ do
_text <- optional $ byName (Just Ns.opc) "Text" $ children $ contentNode $ textContent
return $ OpcError _text _id
itemValue :: Element ItemValue
itemValue =
join $
attributesByName $ do
_valueTypeQualifier <- optional $ byName Nothing "ValueTypeQualifier" $ adaptedQNameContent
_itemPath <- optional $ byName Nothing "ItemPath" $ textContent
_itemName <- optional $ byName Nothing "ItemName" $ textContent
_clientItemHandle <- optional $ byName Nothing "ClientItemHandle" $ textContent
_timestamp <- optional $ byName Nothing "Timestamp" $ dateTimeContent
_resultId <- optional $ byName Nothing "ResultID" $ adaptedQNameContent
return $ do
childrenByName $ do
_diagnosticInfo <- optional $ byName (Just Ns.opc) "DiagnosticInfo" $ children $ contentNode $ textContent
_value <- optional $ byName (Just Ns.opc) "Value" $ value
_opcQuality <- optional $ byName (Just Ns.opc) "Quality" $ opcQuality
return (ItemValue _diagnosticInfo _value _opcQuality _valueTypeQualifier _itemPath _itemName _clientItemHandle _timestamp _resultId)
value :: Element Value
value = do
join $
attributesByName $
byName (Just Ns.xsi) "type" $ do
(_typeNs, _typeName) <- qNameContent
case _typeNs of
Just _typeNs ->
if _typeNs == Ns.xsd
then case _typeName of
"string" -> primitive #string stringContent
"boolean" -> primitive #boolean booleanContent
"float" -> primitive #float floatContent
"double" -> primitive #double doubleContent
"decimal" -> primitive #decimal decimalContent
"long" -> primitive #long longContent
"int" -> primitive #int intContent
"short" -> primitive #short shortContent
"byte" -> primitive #byte byteContent
"unsignedLong" -> primitive #unsignedLong unsignedLongContent
"unsignedInt" -> primitive #unsignedInt unsignedIntContent
"unsignedShort" -> primitive #unsignedShort unsignedShortContent
"unsignedByte" -> primitive #unsignedByte unsignedByteContent
"base64Binary" -> primitive #base64Binary base64BinaryContent
"dateTime" -> primitive #dateTime dateTimeContent
"time" -> primitive #time timeContent
"date" -> primitive #date dateContent
"duration" -> primitive #duration durationContent
"QName" -> primitive #qName adaptedQNameContent
_ -> fail $ "Unexpected XSD type: " <> show _typeName
else
if _typeNs == Ns.opc
then case _typeName of
"ArrayOfByte" -> arrayOfPrimitive "byte" #arrayOfByte byteContent
"ArrayOfShort" -> arrayOfPrimitive "short" #arrayOfShort shortContent
"ArrayOfUnsignedShort" -> arrayOfPrimitive "unsignedShort" #arrayOfUnsignedShort unsignedShortContent
"ArrayOfInt" -> arrayOfPrimitive "int" #arrayOfInt intContent
"ArrayOfUnsignedInt" -> arrayOfPrimitive "unsignedInt" #arrayOfUnsignedInt unsignedIntContent
"ArrayOfLong" -> arrayOfPrimitive "long" #arrayOfLong longContent
"ArrayOfUnsignedLong" -> arrayOfPrimitive "unsignedLong" #arrayOfUnsignedLong unsignedLongContent
"ArrayOfFloat" -> arrayOfPrimitive "float" #arrayOfFloat floatContent
"ArrayOfDecimal" -> arrayOfPrimitive "decimal" #arrayOfDecimal decimalContent
"ArrayOfDouble" -> arrayOfPrimitive "double" #arrayOfDouble doubleContent
"ArrayOfBoolean" -> arrayOfPrimitive "boolean" #arrayOfBoolean booleanContent
"ArrayOfString" -> arrayOfPrimitive "string" #arrayOfString stringContent
"ArrayOfDateTime" -> arrayOfPrimitive "dateTime" #arrayOfDateTime dateTimeContent
"ArrayOfAnyType" ->
return $
fmap #arrayOfAnyType $
childrenByName $
VectorUtil.many $
byName (Just Ns.opc) "anyType" $ do
_isNil <- attributesByName isNil
if _isNil
then return Nothing
else fmap Just $ value
"OPCQuality" -> return $ fmap #opcQuality $ opcQuality
_ -> fail $ "Unexpected OPC type: " <> show _typeName
else nonStandard (NamespacedQName _typeNs _typeName)
Nothing -> nonStandard (UnnamespacedQName _typeName)
where
primitive constructor contentParser =
return $ fmap constructor $ children $ contentNode contentParser
arrayOfPrimitive elementName constructor contentParser =
return $ fmap constructor $ childrenByName $ VectorUtil.many $ byName (Just Ns.opc) elementName $ children $ contentNode contentParser
nonStandard _type =
return $
fmap (#nonStandard . ValueNonStandard _type) $ do
Xml.Element _ _ _children <- astElement
return _children
opcQuality :: Element OpcQuality
opcQuality =
attributesByName $ do
_qualityField <- byName Nothing "QualityField" qualityBitsContent <|> pure #good
_limitField <- byName Nothing "LimitField" limitBitsContent <|> pure #none
_vendorField <- byName Nothing "VendorField" unsignedByteContent <|> pure 0
return (OpcQuality _qualityField _limitField _vendorField)
serverStatus :: Element ServerStatus
serverStatus =
join $
childrenByName $ do
_statusInfo <- optional $ byName (Just Ns.opc) "StatusInfo" $ children $ contentNode $ textContent
_vendorInfo <- optional $ byName (Just Ns.opc) "VendorInfo" $ children $ contentNode $ textContent
_supportedLocaleIds <- VectorUtil.many $ byName (Just Ns.opc) "SupportedLocaleIDs" $ children $ contentNode $ textContent
_supportedInterfaceVersions <- VectorUtil.many $ byName (Just Ns.opc) "SupportedInterfaceVersions" $ children $ contentNode $ textContent
return $
attributesByName $ do
_startTime <- byName Nothing "StartTime" $ dateTimeContent
_productVersion <- optional $ byName Nothing "ProductVersion" $ textContent
return $ ServerStatus _statusInfo _vendorInfo _supportedLocaleIds _supportedInterfaceVersions _startTime _productVersion
replyItemList :: Element ReplyItemList
replyItemList =
join $
childrenByName $ do
_items <- VectorUtil.many $ byName (Just Ns.opc) "Items" $ itemValue
return $
attributesByName $ do
_reserved <- optional $ byName Nothing "Reserved" $ textContent
return $ ReplyItemList _items _reserved
subscribePolledRefreshReplyItemList :: Element SubscribePolledRefreshReplyItemList
subscribePolledRefreshReplyItemList =
join $
childrenByName $ do
_items <- VectorUtil.many $ byName (Just Ns.opc) "Items" $ itemValue
return $
attributesByName $ do
_subscriptionHandle <- optional $ byName Nothing "SubscriptionHandle" $ textContent
return $ SubscribePolledRefreshReplyItemList _items _subscriptionHandle
browseElement :: Element BrowseElement
browseElement =
join $
childrenByName $ do
_properties <- VectorUtil.many $ byName (Just Ns.opc) "Properties" $ itemProperty
return $
attributesByName $ do
_name <- optional $ byName Nothing "Name" textContent
_itemPath <- optional $ byName Nothing "ItemPath" textContent
_itemName <- optional $ byName Nothing "ItemName" textContent
_isItem <- byName Nothing "IsItem" booleanContent
_hasChildren <- byName Nothing "HasChildren" booleanContent
return $ BrowseElement _properties _name _itemPath _itemName _isItem _hasChildren
itemProperty :: Element ItemProperty
itemProperty =
join $
childrenByName $ do
_value <- optional $ byName (Just Ns.opc) "Value" $ value
return $
attributesByName $ do
_name <- byName Nothing "Name" adaptedQNameContent
_description <- optional $ byName Nothing "Description" textContent
_itemPath <- optional $ byName Nothing "ItemPath" textContent
_itemName <- optional $ byName Nothing "ItemName" textContent
_resultId <- optional $ byName Nothing "ResultID" adaptedQNameContent
return $ ItemProperty _value _name _description _itemPath _itemName _resultId
propertyReplyList :: Element PropertyReplyList
propertyReplyList = do
join $
childrenByName $ do
_properties <- VectorUtil.many $ byName (Just Ns.opc) "Properties" $ itemProperty
return $
attributesByName $ do
_itemPath <- optional $ byName Nothing "ItemPath" $ textContent
_itemName <- optional $ byName Nothing "ItemName" $ textContent
_resultId <- optional $ byName Nothing "ResultID" $ adaptedQNameContent
return $ PropertyReplyList _properties _itemPath _itemName _resultId
-- * Content
qualityBitsContent :: Content QualityBits
qualityBitsContent =
enumContent
[ ("bad", #bad),
("badConfigurationError", #badConfigurationError),
("badNotConnected", #badNotConnected),
("badDeviceFailure", #badDeviceFailure),
("badSensorFailure", #badSensorFailure),
("badLastKnownValue", #badLastKnownValue),
("badCommFailure", #badCommFailure),
("badOutOfService", #badOutOfService),
("badWaitingForInitialData", #badWaitingForInitialData),
("uncertain", #uncertain),
("uncertainLastUsableValue", #uncertainLastUsableValue),
("uncertainSensorNotAccurate", #uncertainSensorNotAccurate),
("uncertainEUExceeded", #uncertainEUExceeded),
("uncertainSubNormal", #uncertainSubNormal),
("good", #good),
("goodLocalOverride", #goodLocalOverride)
]
limitBitsContent :: Content LimitBits
limitBitsContent =
enumContent
[ ("none", #none),
("low", #low),
("high", #high),
("constant", #constant)
]
serverStateContent :: Content ServerState
serverStateContent =
enumContent
[ ("running", #running),
("failed", #failed),
("noConfig", #noConfig),
("suspended", #suspended),
("test", #test),
("commFault", #commFault)
]
-- |
-- A sequence of UNICODE characters.
stringContent :: Content Text
stringContent = textContent
-- |
-- A binary logic value (true or false).
booleanContent :: Content Bool
booleanContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- An IEEE single-precision 32-bit floating point value.
floatContent :: Content Float
floatContent = attoparsedContent $ fmap realToFrac $ AttoparsecData.lenientParser @Double
-- |
-- An IEEE double-precision 64-bit floating point value.
doubleContent :: Content Double
doubleContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A fixed-point decimal value with arbitrary precision.
-- Application development environments impose practical limitations on the precision supported by this type. XML-DA compliant applications must support at least the range supported by the VT_CY type.
decimalContent :: Content Scientific
decimalContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 64-bit signed integer value.
longContent :: Content Int64
longContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 32-bit signed integer value.
intContent :: Content Int32
intContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 16-bit signed integer value.
shortContent :: Content Int16
shortContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- An 8-bit signed integer value.
-- Note this differs from the definition of ‘byte’ used in most programming laguages.
byteContent :: Content Int8
byteContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 64-bit unsigned integer value.
unsignedLongContent :: Content Word64
unsignedLongContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 32-bit unsigned integer value.
unsignedIntContent :: Content Word32
unsignedIntContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A 16-bit unsigned integer value.
unsignedShortContent :: Content Word16
unsignedShortContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- An 8-bit unsigned integer value.
unsignedByteContent :: Content Word8
unsignedByteContent = attoparsedContent $ AttoparsecData.lenientParser
-- |
-- A sequence of 8-bit values represented in XML with Base-64 Encoding.
base64BinaryContent :: Content ByteString
base64BinaryContent = refinedContent $ Base64.decodeBase64 . TextEncoding.encodeUtf8
-- |
-- A specific instance in time.
dateTimeContent :: Content UTCTime
dateTimeContent = attoparsedContent XmlSchemaValuesAttoparsec.dateTime
-- |
-- An instant of time that recurs every day.
timeContent :: Content Time
timeContent = attoparsedContent XmlSchemaValuesAttoparsec.time
-- |
-- A Gregorian calendar date.
dateContent :: Content Date
dateContent = attoparsedContent XmlSchemaValuesAttoparsec.date
-- |
-- A duration of time as specified by Gregorian year, month, day, hour, minute, and second components.
durationContent :: Content Duration
durationContent = attoparsedContent XmlSchemaValuesAttoparsec.duration
-- |
-- An XML qualified name comprising of a name and a namespace.
-- The name must be a valid XML element name and the namespace must be a valid URI.
-- QNames are equal only if the name and the namespace are equal.
adaptedQNameContent :: Content QName
adaptedQNameContent =
qNameContent <&> \(ns, name) -> case ns of
Just ns -> NamespacedQName ns name
Nothing -> UnnamespacedQName name
-- * Attributes
isNil :: ByName Content Bool
isNil =
byName (Just Ns.xsi) "nil" booleanContent <|> pure False
xsiType :: ByName Content QName
xsiType =
byName (Just Ns.xsi) "type" adaptedQNameContent
-- * Value parsers
-- |
-- Parse array of any type by passing in a parser for elements
-- in the context of a QName of the element type.
arrayOfAnyType :: (QName -> ByName Element element) -> ByName Element (Vector (Maybe element))
arrayOfAnyType elementParser =
VectorUtil.many $
byName (Just Ns.opc) "anyType" $
join $
attributesByName $ do
_isNil <- isNil
if _isNil
then return (return Nothing)
else do
_type <- xsiType
return $ childrenByName $ fmap Just $ elementParser _type
-- * Helpers
-- |
-- A workaround for the fact that OPC uses a non-standard URI for the SOAP ENV
-- namespace.
bySoapEnvName :: Text -> parser a -> ByName parser a
bySoapEnvName _name _parser =
byName (Just Ns.soapEnv2) _name _parser
<|> byName (Just Ns.soapEnv) _name _parser
elementNameIsOneOf :: [(Maybe Text, Text)] -> Element ()
elementNameIsOneOf _names =
elementName $ \_actualNs _actualName ->
if elem (_actualNs, _actualName) _names
then Right ()
else
Left $
fromString $
"Unexpected element name: " <> show (_actualNs, _actualName) <> ". "
<> "Expecting one of the following: "
<> show _names
<> "."