opc-xml-da-client (empty) → 0.1
raw patch · 24 files changed
+2975/−0 lines, 24 filesdep +QuickCheckdep +accdep +attoparsec
Dependencies added: QuickCheck, acc, attoparsec, attoparsec-data, base, base64, binary, bytestring, caerbannog, containers, data-default, domain, domain-optics, hashable, hashable-time, http-client, opc-xml-da-client, quickcheck-instances, rerebase, scientific, tasty, tasty-hunit, tasty-quickcheck, text, text-builder, time, transformers, unordered-containers, vector, vector-instances, xml-conduit, xml-parser
Files
- LICENSE +22/−0
- base/OpcXmlDaClient/Base/HashMap.hs +28/−0
- base/OpcXmlDaClient/Base/MVector.hs +14/−0
- base/OpcXmlDaClient/Base/Prelude.hs +102/−0
- base/OpcXmlDaClient/Base/Vector.hs +55/−0
- library-test/Main.hs +189/−0
- library/OpcXmlDaClient.hs +150/−0
- opc-xml-da-client.cabal +213/−0
- protocol-test/Main.hs +81/−0
- protocol-test/Pcap.hs +129/−0
- protocol/OpcXmlDaClient/Protocol/Namespaces.hs +25/−0
- protocol/OpcXmlDaClient/Protocol/Types.hs +28/−0
- protocol/OpcXmlDaClient/Protocol/XmlConstruction.hs +529/−0
- protocol/OpcXmlDaClient/Protocol/XmlParsing.hs +565/−0
- protocol/types.domain.yaml +442/−0
- quickcheck-util/OpcXmlDaClient/QuickCheckUtil/Gens.hs +88/−0
- xml-builder/OpcXmlDaClient/XmlBuilder.hs +124/−0
- xml-builder/OpcXmlDaClient/XmlBuilder/Identified.hs +32/−0
- xml-schema-values-test/Main.hs +24/−0
- xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Attoparsec.hs +54/−0
- xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Rendering.hs +27/−0
- xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Types.hs +30/−0
- xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Util/TimeMath.hs +9/−0
- xml-schema-values/types.domain.yaml +15/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2021, Urban Mobility Labs Ltd.++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ base/OpcXmlDaClient/Base/HashMap.hs view
@@ -0,0 +1,28 @@+-- |+-- Utilities for HashMap.+module OpcXmlDaClient.Base.HashMap where++import qualified Data.HashMap.Strict as HashMap+import OpcXmlDaClient.Base.Prelude++-- |+-- Build a hash map from keys to autoincremented ids using a projection function from int.+--+-- The ids are generated by incrementing a counter starting from 0.+autoincrementedFoldable :: (Foldable f, Hashable k, Eq k) => f k -> (Int -> v) -> HashMap.HashMap k v+autoincrementedFoldable foldable projValue =+ foldr+ ( \k next !map !counter ->+ HashMap.alterF+ ( maybe+ (succ counter, Just (projValue counter))+ (\value -> (counter, Just value))+ )+ k+ map+ & \(newCounter, newMap) -> next newMap newCounter+ )+ (\map _ -> map)+ foldable+ HashMap.empty+ 0
+ base/OpcXmlDaClient/Base/MVector.hs view
@@ -0,0 +1,14 @@+module OpcXmlDaClient.Base.MVector where++import Data.Vector.Generic.Mutable+import OpcXmlDaClient.Base.Prelude++{-# INLINE writeListInReverseOrderStartingFrom #-}+writeListInReverseOrderStartingFrom :: MVector v a => v s a -> Int -> [a] -> ST s ()+writeListInReverseOrderStartingFrom v =+ let loop !index list = case list of+ h : t -> do+ unsafeWrite v index h+ loop (pred index) t+ _ -> return ()+ in loop
+ base/OpcXmlDaClient/Base/Prelude.hs view
@@ -0,0 +1,102 @@+module OpcXmlDaClient.Base.Prelude+ ( module Exports,+ showText,+ )+where++import Control.Applicative as Exports hiding (WrappedArrow (..))+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (callCC, shift)+import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), ask, mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT)+import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT)+import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter)+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Default as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Compose as Exports+import Data.Functor.Identity as Exports+import Data.HashMap.Strict as Exports (HashMap)+import Data.Hashable as Exports (Hashable (hash, hashWithSalt))+import Data.Hashable.Generic as Exports (genericHashWithSalt)+import Data.Hashable.Lifted as Exports (liftHashWithSalt)+import Data.Hashable.Time ()+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Map.Strict as Exports (Map)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.Scientific as Exports (Scientific)+import Data.Semigroup as Exports hiding (First (..), Last (..))+import Data.String as Exports+import Data.Text as Exports (Text)+import Data.Time as Exports (CalendarDiffTime (..), Day (..), DiffTime, LocalTime, TimeOfDay (..), TimeZone, UTCTime)+import Data.Time.Clock.System as Exports (SystemTime (..))+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Vector as Exports (Vector)+import Data.Vector.Instances ()+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import GHC.OverloadedLabels as Exports+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))++{-# INLINE showText #-}+{-# SPECIALIZE showText :: Text -> Text #-}+{-# SPECIALIZE showText :: String -> Text #-}+showText :: Show a => a -> Text+showText = fromString . show
+ base/OpcXmlDaClient/Base/Vector.hs view
@@ -0,0 +1,55 @@+-- |+-- General utilities for immutable vectors.+module OpcXmlDaClient.Base.Vector where++import Data.Vector.Generic+import qualified Data.Vector.Generic.Mutable as M+import qualified OpcXmlDaClient.Base.MVector as M+import OpcXmlDaClient.Base.Prelude hiding (Vector)++-- |+-- >>> fromReverseListN 3 [1,2,3] :: Data.Vector.Vector Int+-- [3,2,1]+{-# INLINE fromReverseListN #-}+fromReverseListN :: Vector v a => Int -> [a] -> v a+fromReverseListN size list =+ initialized size $ \mv -> M.writeListInReverseOrderStartingFrom mv (pred size) list++{-# INLINE initialized #-}+initialized :: Vector v a => Int -> (forall s. Mutable v s a -> ST s ()) -> v a+initialized size initialize = runST $ do+ mv <- M.unsafeNew size+ initialize mv+ unsafeFreeze mv++-- |+-- Efficiently build a vector with the @many@ pattern.+many :: (MonadPlus m, Vector v a) => m a -> m (v a)+many produce =+ manyWithIndex (const produce)++manyWithIndex :: (MonadPlus m, Vector v a) => (Int -> m a) -> m (v a)+manyWithIndex produce =+ build [] 0+ where+ build list !size =+ step <|> finish+ where+ step =+ produce size >>= \a -> build (a : list) (succ size)+ finish =+ pure (fromReverseListN size list)++manyWithIndexTerminating :: (MonadPlus m, Vector v a) => (Int -> m (Either e a)) -> m (Either e (v a))+manyWithIndexTerminating produce =+ build [] 0+ where+ build list !size =+ step <|> finish+ where+ step =+ produce size >>= \case+ Right a -> build (a : list) (succ size)+ Left a -> return (Left a)+ finish =+ pure (Right (fromReverseListN size list))
+ library-test/Main.hs view
@@ -0,0 +1,189 @@+module Main where++import Data.Default+import qualified Data.Vector as V+import qualified Network.HTTP.Client as Hc+import qualified OpcXmlDaClient as Opc+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Prelude++defBrowse :: Opc.Browse+defBrowse =+ Opc.Browse+ V.empty+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ 10+ Opc.AllBrowseFilter+ Nothing+ Nothing+ True+ True+ True++getItemNames :: Hc.Manager -> IO (V.Vector Text)+getItemNames manager = do+ Opc.browse manager def uri defBrowse >>= \case+ Left e -> error $ show e+ Right r -> pure $ fmap (fromMaybe "" . #itemName) $ V.filter #isItem $ #elements r++uri :: Opc.Uri+uri =+ fromJust . Opc.textUri $+ "http://info.advosol.com/XMLDADemo/XML_Sim/OpcXmlDaServer.asmx"++makeReadItem :: Text -> Opc.ReadRequestItem+makeReadItem n = Opc.ReadRequestItem Nothing Nothing (Just n) Nothing Nothing++makeItemValue :: Text -> Opc.ItemValue+makeItemValue n =+ Opc.ItemValue+ { Opc._diagnosticInfo = Nothing,+ Opc._value = Nothing,+ Opc._quality = Nothing,+ Opc._valueTypeQualifier = Nothing,+ Opc._itemPath = Nothing,+ Opc._itemName = Just n,+ Opc._clientItemHandle = Nothing,+ Opc._timestamp = Nothing,+ Opc._resultId = Nothing+ }++defRequestOptions :: Opc.RequestOptions+defRequestOptions =+ Opc.RequestOptions+ True+ True+ True+ True+ True+ Nothing+ Nothing+ Nothing++serverSubHandleRef :: IORef Text+serverSubHandleRef = unsafePerformIO $ newIORef ""+{-# NOINLINE serverSubHandleRef #-}++main = do+ let manager = unsafePerformIO $ Hc.newManager Hc.defaultManagerSettings+ op _op = _op manager def uri+ itemNames <- getItemNames manager+ defaultMain $+ testGroup "Mocking server interactions" $+ [ testCase "GetStatus" $ do+ _res <- op Opc.getStatus $ Opc.GetStatus Nothing Nothing+ assertBool (show _res) $ isRight _res,+ testCase "Browse" $ do+ _res <- op Opc.browse defBrowse+ assertBool (show _res) $ isRight _res,+ testCase "Read" $ do+ _res <-+ op Opc.read $+ Opc.Read+ { -- "options" is required+ Opc._options = Just defRequestOptions,+ Opc._itemList =+ Just $+ Opc.ReadRequestItemList+ (fmap makeReadItem itemNames)+ Nothing+ Nothing+ Nothing+ }+ assertBool (show _res) $ isRight _res,+ testCase "Write" $ do+ _res <-+ op Opc.write $+ Opc.Write+ { -- "options" is required+ Opc._options = Just defRequestOptions,+ Opc._itemList =+ Just $+ Opc.WriteRequestItemList+ { Opc._items = fmap makeItemValue itemNames,+ Opc._itemPath = Nothing+ },+ Opc._returnValuesOnReply = False+ }+ assertBool (show _res) $ isRight _res,+ testCase "Subscribe" $ do+ _res <-+ op Opc.subscribe $+ Opc.Subscribe+ { Opc._options = Just defRequestOptions,+ Opc._returnValuesOnReply = False,+ Opc._itemList =+ Just $+ Opc.SubscribeRequestItemList+ { Opc._itemPath = Nothing,+ Opc._reqType = Nothing,+ Opc._deadband = Nothing,+ Opc._requestedSamplingRate = Nothing,+ Opc._enableBuffering = Nothing,+ Opc._items =+ V.fromList+ [ Opc.SubscribeRequestItem+ { Opc._itemPath = Nothing,+ Opc._reqType = Nothing,+ Opc._itemName = listToMaybe $ V.toList itemNames,+ Opc._clientItemHandle = Nothing,+ Opc._deadband = Nothing,+ Opc._requestedSamplingRate = Nothing,+ Opc._enableBuffering = Nothing+ }+ ]+ },+ Opc._subscriptionPingRate = Nothing+ }+ case _res of+ Left err -> assertBool (show err) False+ Right Opc.SubscribeResponse {..} -> case _serverSubHandle of+ Nothing -> error "SubHandle not found"+ Just sh -> writeIORef serverSubHandleRef sh,+ testCase "Subscription polled refresh" $ do+ sh <- readIORef serverSubHandleRef+ _res <-+ op Opc.subscriptionPolledRefresh $+ Opc.SubscriptionPolledRefresh+ { Opc._options = Just defRequestOptions,+ Opc._serverSubHandles = V.fromList [sh],+ Opc._holdTime = Nothing,+ Opc._waitTime = 1,+ Opc._returnAllItems = False+ }+ assertBool (show _res) $ isRight _res,+ testCase "Subscription cancel" $ do+ sh <- readIORef serverSubHandleRef+ _res <-+ op Opc.subscriptionCancel $+ Opc.SubscriptionCancel+ { Opc._serverSubHandle = Just sh,+ Opc._clientRequestHandle = Nothing+ }+ assertBool (show _res) $ isRight _res,+ testCase "Get properties" $ do+ _res <-+ op Opc.getProperties $+ Opc.GetProperties+ { Opc._itemIds =+ itemNames <&> \n ->+ Opc.ItemIdentifier+ { Opc._itemPath = Nothing,+ Opc._itemName = Just n+ },+ Opc._propertyNames = V.empty,+ Opc._localeId = Nothing,+ Opc._clientRequestHandle = Nothing,+ Opc._itemPath = Nothing,+ Opc._returnAllProperties = False,+ Opc._returnPropertyValues = False,+ Opc._returnErrorText = False+ }+ assertBool (show _res) $ isRight _res+ ]
+ library/OpcXmlDaClient.hs view
@@ -0,0 +1,150 @@+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 = encDecOp XmlConstruction.getStatus XmlParsing.getStatusResponse++read :: Op Read ReadResponse+read = encDecOp XmlConstruction.read XmlParsing.readResponse++write :: Op Write WriteResponse+write = encDecOp XmlConstruction.write XmlParsing.writeResponse++subscribe :: Op Subscribe SubscribeResponse+subscribe = encDecOp XmlConstruction.subscribe XmlParsing.subscribeResponse++subscriptionPolledRefresh :: Op SubscriptionPolledRefresh SubscriptionPolledRefreshResponse+subscriptionPolledRefresh = encDecOp XmlConstruction.subscriptionPolledRefresh XmlParsing.subscriptionPolledRefreshResponse++subscriptionCancel :: Op SubscriptionCancel SubscriptionCancelResponse+subscriptionCancel = encDecOp XmlConstruction.subscriptionCancel XmlParsing.subscriptionCancelResponse++browse :: Op Browse BrowseResponse+browse = encDecOp XmlConstruction.browse XmlParsing.browseResponse++getProperties :: Op GetProperties GetPropertiesResponse+getProperties = encDecOp XmlConstruction.getProperties XmlParsing.getPropertiesResponse++encDecOp :: (i -> ByteString) -> XmlParser.Element (Either SoapFault o) -> Op i o+encDecOp encode decode manager (RequestTimeout timeout) (Uri request) input = do+ let encodedInput = encode input+ request+ { Hc.method = "POST",+ Hc.requestHeaders =+ [ ("Content-Type", "application/soap+xml; charset=utf-8")+ ],+ Hc.requestBody = Hc.RequestBodyBS encodedInput,+ Hc.responseTimeout = Hc.responseTimeoutMicro (timeout * 1000)+ }+ & \request -> do+ response <- try $ Hc.httpLbs request manager+ case response of+ Left exc+ | Just exc <- fromException @Hc.HttpException exc -> case exc of+ Hc.HttpExceptionRequest _ reason -> return $ Left $ HttpError reason+ Hc.InvalidUrlException uri reason -> error $ "Invalid URI: " <> uri <> ". " <> reason+ | Just exc <- fromException @IOException exc ->+ return $ Left $ IoError exc+ | otherwise -> throwIO exc+ Right response -> do+ return $ case XmlParser.parseLazyByteString decode (Hc.responseBody response) of+ Right res -> case res of+ Right res -> Right res+ Left err -> Left $ SoapError err+ Left err -> Left $ ParsingError 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 = fmap Uri . Hc.parseRequest . Text.unpack++newtype RequestTimeout = RequestTimeout Int++-- |+-- RequestTimeout of 30 seconds.+instance Default RequestTimeout where+ def = RequestTimeout 30000++-- |+-- Construct a request timeout value,+-- ensuring that it's in the proper range.+millisecondsRequestTimeout :: Int -> Maybe RequestTimeout+millisecondsRequestTimeout x =+ if x >= 0+ then Just $ RequestTimeout x+ else 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 _) == (HttpError _) = False -- NOTE: HttpEcxceptionContent has not EQ instance+ (IoError a) == (IoError b) = a == b+ (ParsingError a) == (ParsingError b) = a == b+ (SoapError a) == (SoapError b) = a == b+ (==) _ _ = False++instance Show Error where+ show = \case+ HttpError a -> showString "HTTP error: " $ show a+ IoError a -> showString "IO error: " $ show a+ ParsingError a -> showString "Parsing error: " $ Text.unpack a+ SoapError a ->+ "SOAP fault response with code: " <> show (#code a) <> ". "+ <> "Reason: "+ <> Text.unpack (#reason a)
+ opc-xml-da-client.cabal view
@@ -0,0 +1,213 @@+cabal-version: 3.0+name: opc-xml-da-client+version: 0.1+synopsis: OPC XML-DA Client+description:+ An implementation of OPC XML-DA protocol for client applications. The specification for the protocol can be found [here](http://www.diit.unict.it/users/scava/dispense/II/OPCDataAccessXMLSpecification.pdf).+homepage: https://github.com/mlabs-haskell/opc-xml-da-client+category: Network+maintainer: Nikita Volkov, Yan Shkurinsky+copyright: 2021, Urban Mobility Labs Ltd.+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ protocol/*.domain.yaml+ xml-schema-values/*.domain.yaml++source-repository head+ type: git+ location: git://github.com/mlabs-haskell/opc-xml-da-client.git++library+ hs-source-dirs: library+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient+ build-depends:+ base >=4.14 && <5,+ bytestring >=0.10 && <0.12,+ containers ^>=0.6.2.1,+ http-client >=0.7.8 && <0.8,+ opc-xml-da-client-base,+ opc-xml-da-client-protocol,+ opc-xml-da-client-xml-schema-values,+ scientific ^>=0.3.6.2,+ text >=1 && <2,+ transformers ^>=0.5,+ vector ^>=0.12,+ xml-conduit ^>=1.9.1.1,+ xml-parser ^>=0.1.0.1,++test-suite library-test+ type: exitcode-stdio-1.0+ hs-source-dirs: library-test+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ build-depends:+ data-default,+ http-client,+ QuickCheck >=2.8.1 && <3,+ quickcheck-instances >=0.3.11 && <0.4,+ opc-xml-da-client,+ rerebase >=1.13.0.1 && <2,+ tasty >=0.12 && <2,+ tasty-hunit >=0.9 && <0.11,+ tasty-quickcheck >=0.9 && <0.11,++library opc-xml-da-client-protocol+ hs-source-dirs: protocol+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient.Protocol.Types+ OpcXmlDaClient.Protocol.XmlConstruction+ OpcXmlDaClient.Protocol.XmlParsing+ other-modules:+ OpcXmlDaClient.Protocol.Namespaces+ build-depends:+ attoparsec >=0.13.2.5 && <0.15,+ attoparsec-data ^>=1.0.5.2,+ base >=4.14 && <5,+ base64 ^>=0.4.2.3,+ bytestring >=0.10 && <0.12,+ containers ^>=0.6.2.1,+ domain ^>=0.1.1,+ domain-optics ^>=0.1.0.1,+ opc-xml-da-client-base,+ opc-xml-da-client-xml-builder,+ opc-xml-da-client-xml-schema-values,+ scientific ^>=0.3.6.2,+ text >=1 && <2,+ text-builder >=0.6.6.2 && <0.7,+ time >=1.9.3 && <2,+ vector ^>=0.12,+ xml-conduit ^>=1.9.1.1,+ xml-parser ^>=0.1,++test-suite protocol-test+ type: exitcode-stdio-1.0+ hs-source-dirs: protocol-test+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ main-is: Main.hs+ other-modules: Pcap+ build-depends:+ QuickCheck >=2.8.1 && <3,+ quickcheck-instances >=0.3.11 && <0.4,+ opc-xml-da-client-protocol,+ opc-xml-da-client,+ rerebase >=1.13.0.1 && <2,+ tasty >=0.12 && <2,+ tasty-hunit >=0.9 && <0.11,+ tasty-quickcheck >=0.9 && <0.11,+ xml-conduit,+ xml-parser,+ http-client,+ binary,+ caerbannog,++library opc-xml-da-client-xml-builder+ hs-source-dirs: xml-builder+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient.XmlBuilder+ other-modules:+ OpcXmlDaClient.XmlBuilder.Identified+ build-depends:+ acc >=0.1.3 && <0.2,+ base >=4.14 && <5,+ bytestring >=0.10 && <0.12,+ containers ^>=0.6.2.1,+ opc-xml-da-client-base,+ scientific ^>=0.3.6.2,+ text >=1 && <2,+ unordered-containers ^>=0.2.14,+ xml-conduit ^>=1.9.1.1,++library opc-xml-da-client-xml-schema-values+ hs-source-dirs: xml-schema-values+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient.XmlSchemaValues.Attoparsec+ OpcXmlDaClient.XmlSchemaValues.Rendering+ OpcXmlDaClient.XmlSchemaValues.Types+ other-modules:+ OpcXmlDaClient.XmlSchemaValues.Util.TimeMath+ build-depends:+ attoparsec >=0.13.2.5 && <0.15,+ attoparsec-data ^>=1.0.5.2,+ base >=4.14 && <5,+ base64 ^>=0.4.2.3,+ bytestring >=0.10 && <0.12,+ domain ^>=0.1.1,+ domain-optics ^>=0.1.0.1,+ opc-xml-da-client-base,+ scientific ^>=0.3.6.2,+ text >=1 && <2,+ text-builder >=0.6.6.2 && <0.7,+ time >=1.9.3 && <2,++test-suite xml-schema-values-test+ type: exitcode-stdio-1.0+ hs-source-dirs: xml-schema-values-test+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ build-depends:+ attoparsec >=0.13.2.5 && <0.15,+ QuickCheck >=2.8.1 && <3,+ quickcheck-instances >=0.3.11 && <0.4,+ opc-xml-da-client-quickcheck-util,+ opc-xml-da-client-xml-schema-values,+ rerebase >=1.13.0.1 && <2,+ tasty >=0.12 && <2,+ tasty-hunit >=0.9 && <0.11,+ tasty-quickcheck >=0.9 && <0.11,+ text-builder >=0.6.6.2 && <0.7,++library opc-xml-da-client-base+ hs-source-dirs: base+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient.Base.HashMap+ OpcXmlDaClient.Base.MVector+ OpcXmlDaClient.Base.Prelude+ OpcXmlDaClient.Base.Vector+ build-depends:+ base >=4.14 && <5,+ bytestring >=0.10 && <0.12,+ data-default ^>=0.7.1.1,+ containers ^>=0.6.2.1,+ hashable ^>=1.3,+ hashable-time >=0.2 && <0.4,+ scientific ^>=0.3.6.2,+ text >=1 && <2,+ time >=1.9.3 && <2,+ transformers ^>=0.5,+ unordered-containers ^>=0.2.14,+ vector ^>=0.12,+ vector-instances ^>=3.4,++library opc-xml-da-client-quickcheck-util+ hs-source-dirs: quickcheck-util+ default-extensions: ApplicativeDo, BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveLift, DeriveTraversable, DerivingVia, DuplicateRecordFields, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, HexFloatLiterals, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NoImplicitPrelude, NoMonomorphismRestriction, NumericUnderscores, OverloadedLabels, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns+ default-language: Haskell2010+ ghc-options: -funbox-strict-fields+ exposed-modules:+ OpcXmlDaClient.QuickCheckUtil.Gens+ build-depends:+ QuickCheck >=2.8.1 && <3,+ rerebase >=1.13.0.1 && <2,
+ protocol-test/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedLists #-}++module Main where++import qualified Data.Vector as Vector+import OpcXmlDaClient.Protocol.Types+import qualified OpcXmlDaClient.Protocol.XmlParsing as XmlParsing+import qualified Pcap+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import qualified XmlParser as Xp+import Prelude++main :: IO ()+main = do+ pcapTests <- Pcap.makePcapTests+ defaultMain $+ testGroup "" $+ [ pcapTests,+ testGroup "Subscribe Response" $+ let parsingResult =+ unsafePerformIO $+ Xp.parseFile XmlParsing.subscribeResponse "samples/680.response.xml"+ in [ testCase "Top level properties" $ do+ assertEqual+ ""+ (Right (Right (Just "Handle1")))+ ((fmap . fmap) #serverSubHandle parsingResult),+ testCase "DateTime" $ do+ assertEqual+ ""+ (Right (Right (Just (read "2019-09-23 16:01:50.576+00:00"))))+ ((fmap . fmap) (fmap #rcvTime . #subscribeResult) parsingResult),+ testCase "Item value at offset 0" $ do+ assertEqual+ ""+ (Right (Right (Just (FloatValue 4.5))))+ ((fmap . fmap) (join . fmap #value . fmap #itemValue . join . fmap (Vector.!? 0) . fmap #items . #rItemList) parsingResult),+ testCase "Item value at offset 1" $ do+ assertEqual+ ""+ (Right (Right (Just (IntValue 1234))))+ ((fmap . fmap) (join . fmap #value . fmap #itemValue . join . fmap (Vector.!? 1) . fmap #items . #rItemList) parsingResult),+ testCase "Item value at offset 2" $ do+ assertEqual+ ""+ (Right (Right (Just (ArrayOfUnsignedShortValue [0, 0, 3, 11, 0, 0]))))+ ((fmap . fmap) (join . fmap #value . fmap #itemValue . join . fmap (Vector.!? 2) . fmap #items . #rItemList) parsingResult)+ ],+ testGroup "Fault Response" $+ let parsingResult =+ unsafePerformIO $+ Xp.parseFile XmlParsing.subscribeResponse "samples/fault.response.xml"+ in [ testCase "" $ do+ assertEqual+ ""+ (Right (Left (SoapFault (#std SenderStdSoapFaultCode) "Server was unable to read request. ---> There is an error in XML document (4, 32). ---> The string 'dateTime' is not a valid AllXsd value.")))+ parsingResult+ ],+ testGroup "Fault on old SOAP Response" $+ let parsingResult =+ unsafePerformIO $+ Xp.parseFile XmlParsing.subscribeResponse "samples/fault-on-old-soap.response.xml"+ in [ testCase "" $ do+ assertEqual+ ""+ (Right (Left (SoapFault (#std SenderStdSoapFaultCode) "XML syntax error")))+ parsingResult+ ],+ testGroup "Fault on old SOAP Response 2" $+ let parsingResult =+ unsafePerformIO $+ Xp.parseFile XmlParsing.subscribeResponse "samples/fault-on-old-soap-2.response.xml"+ in [ testCase "" $ do+ assertEqual+ ""+ (Right (Left (SoapFault (#custom (UnnamespacedQName "E_NOSUBSCRIPTION")) "E_NOSUBSCRIPTION")))+ parsingResult+ ]+ ]
+ protocol-test/Pcap.hs view
@@ -0,0 +1,129 @@+module Pcap where++import Data.Binary.Bits.Get (block, runBitGet, word8)+import Data.Binary.Get (getWord32le, runGet)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Lazy as BL+import OpcXmlDaClient (Error (..))+import OpcXmlDaClient.Protocol.Types+import qualified OpcXmlDaClient.Protocol.XmlParsing as XmlParsing+import Test.Tasty+import Test.Tasty.HUnit+import qualified XmlParser as Xp+import Prelude++data XmlResponseParser+ = forall a.+ XmlResponseParser+ ( Xp.Element (Either SoapFault a),+ Xp.Element (Either SoapFault a) -> ByteString -> Maybe Error+ )++-- * Make tests++makePcapTests :: IO TestTree+makePcapTests =+ lookupEnv "PCAP_TEST_FILE_PATH" >>= \case+ Nothing -> pure $ testCase "No .pcap file" $ assertBool "" True+ Just path -> do+ content <- B.readFile path <&> pcapToEther+ let (resps, _reqs) =+ separate $+ regroup $+ B.split (c2w '\n') $+ mconcat $ addEmptyLine . unwrapTCP . unwrapIP . unwrapEther <$> content+ pure $+ testGroup "PCAP tests" $+ (zip [1 ..] resps) <&> \(n, resp) ->+ testCase ("Response #" <> show @Int n) $+ assertEqual "Parse corrent" Nothing $ tryToParse resp++-- * Response parsing++tryToParse :: ByteString -> Maybe (ByteString, [Error])+tryToParse str = ((str,) <$>) $ sequence $ responseParsers <&> \(XmlResponseParser (parser, check')) -> check' parser str+ where+ responseParsers =+ [ xml (XmlParsing.getStatusResponse, checkError),+ xml (XmlParsing.readResponse, checkError),+ xml (XmlParsing.writeResponse, checkError),+ xml (XmlParsing.subscribeResponse, checkError),+ xml (XmlParsing.subscriptionPolledRefreshResponse, checkError),+ xml (XmlParsing.subscriptionCancelResponse, checkError),+ xml (XmlParsing.browseResponse, checkError),+ xml (XmlParsing.getPropertiesResponse, checkError)+ ]+ xml = XmlResponseParser+ checkError decode s =+ Xp.parseByteString decode s & either+ do Just . ParsingError+ do const Nothing++-- |+-- This function concatinates strings which don't have empty strings between them+regroup :: [ByteString] -> [ByteString]+regroup str =+ let (x, y) =+ foldr+ ( \s (k, ks) ->+ if B.length s <= 2+ then ("", ks <> [k | k /= ""])+ else (k <> s, ks)+ )+ ("", [])+ str+ in x : y++-- |+-- This function sorts strings to requests and responses+separate :: [ByteString] -> ([ByteString], [ByteString])+separate = foldr f ([], [])+ where+ f = \x (a, b) ->+ if+ | x `startWith` prefResp -> ((B8.drop (B8.length prefResp) x) : a, b)+ | x `startWith` prefReq -> (a, x : b)+ | otherwise -> (a, b)+ prefResp = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ prefReq = "<SOAP-ENV:Envelope"+ startWith a pref = B8.take (B8.length pref) a == pref++-- * .pcap parsing++pcapToEther :: ByteString -> [ByteString]+pcapToEther b' = go (B.drop 24 b') []+ where+ go b v = case B.length b of+ 0 -> v+ _ ->+ let l = fromIntegral $ runGet getWord32le (BL.fromStrict $ B.drop 8 b)+ (payload, tail') = B.splitAt l (B.drop 16 b)+ in go tail' (v <> [payload])++unwrapEther :: ByteString -> ByteString+unwrapEther = B.reverse . B.dropWhile isPaddingByte . B.reverse . B.drop etherHeaderLength+ where+ etherHeaderLength = 14+ isPaddingByte = (== 0)++unwrapIP :: ByteString -> ByteString+unwrapIP b =+ let (_, headerLength32) =+ flip runGet (BL.fromStrict b) $+ runBitGet $ block $ (,) <$> word8 4 <*> word8 4+ in B.drop ((fromIntegral headerLength32) * 4) b++unwrapTCP :: ByteString -> ByteString+unwrapTCP b =+ let headerLength32 = flip runGet (BL.drop 12 $ BL.fromStrict b) $ runBitGet $ block $ word8 4+ in B.drop ((fromIntegral headerLength32) * 4) b++-- * Helpers++addEmptyLine :: ByteString -> ByteString+addEmptyLine x =+ if B8.take 4 x `elem` (["HTTP", "POST"] :: [ByteString])+ then "\n\n" <> x+ else x
+ protocol/OpcXmlDaClient/Protocol/Namespaces.hs view
@@ -0,0 +1,25 @@+module OpcXmlDaClient.Protocol.Namespaces where++import OpcXmlDaClient.Base.Prelude++-- |+-- Namespace for SOAP v1.2.+soapEnv :: Text =+ "http://www.w3.org/2003/05/soap-envelope"++-- |+-- Namespace for SOAP v <1.2+soapEnv2 :: Text =+ "http://schemas.xmlsoap.org/soap/envelope/"++soapEnc :: Text =+ "http://schemas.xmlsoap.org/soap/encoding/"++xsi :: Text =+ "http://www.w3.org/2001/XMLSchema-instance"++xsd :: Text =+ "http://www.w3.org/2001/XMLSchema"++opc :: Text =+ "http://opcfoundation.org/webservices/XMLDA/1.0/"
+ protocol/OpcXmlDaClient/Protocol/Types.hs view
@@ -0,0 +1,28 @@+module OpcXmlDaClient.Protocol.Types where++import Data.Time.Clock+import qualified Data.Vector.Unboxed as Uv+import qualified Domain+import qualified DomainOptics+import OpcXmlDaClient.Base.Prelude hiding (Read)+import OpcXmlDaClient.XmlSchemaValues.Types+import qualified Text.XML as Xml++Domain.declare+ (Just (True, False))+ ( mconcat+ [ Domain.enumDeriver,+ Domain.boundedDeriver,+ Domain.showDeriver,+ Domain.eqDeriver,+ Domain.ordDeriver,+ Domain.genericDeriver,+ Domain.dataDeriver,+ Domain.typeableDeriver,+ Domain.hasFieldDeriver,+ Domain.constructorIsLabelDeriver,+ Domain.accessorIsLabelDeriver,+ DomainOptics.labelOpticDeriver+ ]+ )+ =<< Domain.loadSchema "protocol/types.domain.yaml"
+ protocol/OpcXmlDaClient/Protocol/XmlConstruction.hs view
@@ -0,0 +1,529 @@+module OpcXmlDaClient.Protocol.XmlConstruction+ ( subscribe,+ getStatus,+ write,+ read,+ subscriptionPolledRefresh,+ subscriptionCancel,+ browse,+ getProperties,+ )+where++import qualified Data.ByteString.Base64 as Base64+import qualified Data.Vector.Generic as Gv+import OpcXmlDaClient.Base.Prelude hiding (Read, read)+import qualified OpcXmlDaClient.Protocol.Namespaces as Ns+import OpcXmlDaClient.Protocol.Types+import qualified OpcXmlDaClient.XmlBuilder as X+import qualified OpcXmlDaClient.XmlSchemaValues.Rendering as XmlSchemaValuesRendering+import OpcXmlDaClient.XmlSchemaValues.Types+import qualified Text.Builder as Tb++-- * Documents++subscribe :: Subscribe -> ByteString+subscribe = inSoapEnvelope . subscribeElement "Subscribe"++getStatus :: GetStatus -> ByteString+getStatus = inSoapEnvelope . getStatusElement "GetStatus"++write :: Write -> ByteString+write = inSoapEnvelope . writeElement "Write"++read :: Read -> ByteString+read = inSoapEnvelope . readElement "Read"++subscriptionPolledRefresh :: SubscriptionPolledRefresh -> ByteString+subscriptionPolledRefresh = inSoapEnvelope . subscriptionPolledRefreshElement "SubscriptionPolledRefresh"++subscriptionCancel :: SubscriptionCancel -> ByteString+subscriptionCancel = inSoapEnvelope . subscriptionCancelElement "SubscriptionCancel"++browse :: Browse -> ByteString+browse = inSoapEnvelope . browseElement "Browse"++getProperties :: GetProperties -> ByteString+getProperties = inSoapEnvelope . getPropertiesElement "GetProperties"++-- |+-- Wraps the element in the following snippet.+--+-- > <SOAP-ENV:Envelope+-- > xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/"+-- > xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"+-- > xmlns:xsd="http://www.w3.org/2001/XMLSchema"+-- > xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">+-- > <SOAP-ENV:Header/>+-- > <SOAP-ENV:Body xmlns:opc="http://opcfoundation.org/webservices/XMLDA/1.0/">+-- > ...+-- > </SOAP-ENV:Body>+-- > </SOAP-ENV:Envelope>+inSoapEnvelope :: X.Element -> ByteString+inSoapEnvelope element =+ X.elementXml+ ( X.element+ (soapEnvQName "Envelope")+ []+ [ X.elementNode+ ( X.element+ (soapEnvQName "Header")+ []+ []+ ),+ X.elementNode+ ( X.element+ (soapEnvQName "Body")+ []+ [X.elementNode element]+ )+ ]+ )++-- * Elements++-- Some OPC Servers don't like XML elements of the form+-- <foo attr="bar"/>+-- but prefer the the form+-- <foo attr="bar"></foo>+-- When passing an empty Node list to X.element,+-- the former is generated.+-- An empty Node coaxes xml-conduit to use the latter form.+noContent :: [X.Node]+noContent = [((X.contentNode . X.textContent) "")]++subscribeElement :: Text -> Subscribe -> X.Element+subscribeElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ Just ("ReturnValuesOnReply", booleanContent (#returnValuesOnReply x)),+ ("SubcriptionPingRate",) . intContent <$> #subscriptionPingRate x+ ]+ )+ ( catMaybes+ [ fmap (X.elementNode . requestOptionsElement "Options") (#options x),+ fmap (X.elementNode . subscribeRequestItemListElement "ItemList") (#itemList x)+ ]+ )++requestOptionsElement :: Text -> RequestOptions -> X.Element+requestOptionsElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ if #returnErrorText x then Just ("ReturnErrorText", "true") else Nothing,+ if #returnDiagnosticInfo x then Just ("ReturnDiagnosticInfo", "true") else Nothing,+ if #returnItemTime x then Just ("ReturnItemTime", "true") else Nothing,+ if #returnItemPath x then Just ("ReturnItemPath", "true") else Nothing,+ if #returnItemName x then Just ("ReturnItemName", "true") else Nothing,+ fmap (("RequestDeadline",) . dateTimeContent) (#requestDeadline x),+ fmap (("ClientRequestHandle",) . X.textContent) (#clientRequestHandle x),+ fmap (("LocaleID",) . X.textContent) (#localeId x)+ ]+ )+ noContent++subscribeRequestItemListElement :: Text -> SubscribeRequestItemList -> X.Element+subscribeRequestItemListElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ fmap (("ItemPath",) . X.textContent) (#itemPath x),+ fmap (("ReqType",) . qNameContent) (#reqType x),+ fmap (("Deadband",) . floatContent) (#deadband x),+ fmap (("RequestedSamplingRate",) . intContent) (#requestedSamplingRate x),+ fmap (("EnableBuffering",) . booleanContent) (#enableBuffering x)+ ]+ )+ (fmap (X.elementNode . subscribeRequestItemElement "Items") (toList (#items x)))++subscribeRequestItemElement :: Text -> SubscribeRequestItem -> X.Element+subscribeRequestItemElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ fmap (("ItemPath",) . X.textContent) (#itemPath x),+ fmap (("ReqType",) . qNameContent) (#reqType x),+ fmap (("ItemName",) . X.textContent) (#itemName x),+ fmap (("ClientItemHandle",) . X.textContent) (#clientItemHandle x),+ fmap (("Deadband",) . floatContent) (#deadband x),+ fmap (("RequestedSamplingRate",) . intContent) (#requestedSamplingRate x),+ fmap (("EnableBuffering",) . booleanContent) (#enableBuffering x)+ ]+ )+ noContent++getStatusElement :: Text -> GetStatus -> X.Element+getStatusElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("LocaleID",) . X.textContent <$> #localeId x,+ ("ClientRequestHandle",) . X.textContent <$> #clientRequestHandle x+ ]+ )+ noContent++itemValueElement :: Text -> ItemValue -> X.Element+itemValueElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("ValueTypeQualifier",) . qNameContent <$> #valueTypeQualifier x,+ ("ItemPath",) . X.textContent <$> #itemPath x,+ ("ItemName",) . X.textContent <$> #itemName x,+ ("ClientItemHandle",) . X.textContent <$> #clientItemHandle x,+ ("Timestamp",) . dateTimeContent <$> #timestamp x,+ ("ResultID",) . qNameContent <$> #resultId x+ ]+ )+ ( catMaybes+ [ X.elementNode . diagnosticInfoElement "DiagnosticInfo" <$> #diagnosticInfo x,+ X.elementNode . valueElement "Value" <$> #value x,+ X.elementNode . opcQualityElement "Quality" <$> #quality x+ ]+ )++valueElement :: Text -> Value -> X.Element+valueElement elementName x =+ case x of+ StringValue x -> primitive "string" $ stringContent x+ BooleanValue x -> primitive "boolean" $ booleanContent x+ FloatValue x -> primitive "float" $ floatContent x+ DoubleValue x -> primitive "double" $ doubleContent x+ DecimalValue x -> primitive "decimal" $ decimalContent x+ LongValue x -> primitive "long" $ longContent x+ IntValue x -> primitive "int" $ intContent x+ ShortValue x -> primitive "short" $ shortContent x+ ByteValue x -> primitive "byte" $ byteContent x+ UnsignedLongValue x -> primitive "unsignedLong" $ unsignedLongContent x+ UnsignedIntValue x -> primitive "unsignedInt" $ unsignedIntContent x+ UnsignedShortValue x -> primitive "unsignedShort" $ unsignedShortContent x+ UnsignedByteValue x -> primitive "unsignedByte" $ unsignedByteContent x+ Base64BinaryValue x -> primitive "base64Binary" $ base64BinaryContent x+ DateTimeValue x -> primitive "dateTime" $ dateTimeContent x+ TimeValue x -> primitive "time" $ timeContent x+ DateValue x -> primitive "date" $ dateContent x+ DurationValue x -> primitive "duration" $ durationContent x+ QNameValue x -> primitive "QName" $ qNameContent x+ ArrayOfByteValue x -> primitiveArray "ArrayOfByte" "byte" byteContent x+ ArrayOfShortValue x -> primitiveArray "ArrayOfShort" "short" shortContent x+ ArrayOfUnsignedShortValue x -> primitiveArray "ArrayOfUnsignedShort" "unsignedShort" unsignedShortContent x+ ArrayOfIntValue x -> primitiveArray "ArrayOfInt" "int" intContent x+ ArrayOfUnsignedIntValue x -> primitiveArray "ArrayOfUnsignedInt" "unsignedInt" unsignedIntContent x+ ArrayOfLongValue x -> primitiveArray "ArrayOfLong" "long" longContent x+ ArrayOfUnsignedLongValue x -> primitiveArray "ArrayOfUnsignedLong" "unsignedLong" unsignedLongContent x+ ArrayOfFloatValue x -> primitiveArray "ArrayOfFloat" "float" floatContent x+ ArrayOfDecimalValue x -> primitiveArray "ArrayOfDecimal" "decimal" decimalContent x+ ArrayOfDoubleValue x -> primitiveArray "ArrayOfDouble" "double" doubleContent x+ ArrayOfBooleanValue x -> primitiveArray "ArrayOfBoolean" "boolean" booleanContent x+ ArrayOfStringValue x -> primitiveArray "ArrayOfString" "string" stringContent x+ ArrayOfDateTimeValue x -> primitiveArray "ArrayOfDateTime" "dateTime" dateTimeContent x+ ArrayOfAnyTypeValue x ->+ element (X.namespacedQName Ns.opc "ArrayOfAnyType") $ fmap item $ toList x+ where+ item = \case+ Just x ->+ X.elementNode $ valueElement "anyType" x+ Nothing ->+ X.elementNode $ X.element (opcQName "anyType") [(xsiQName "isNil", "true")] []+ OpcQualityValue x ->+ X.element+ (opcQName elementName)+ ((xsiQName "type", X.qNameContent "OPCQuality") : opcQualityAttributes x)+ []+ NonStandardValue (ValueNonStandard a b) -> element (qNameQName a) (fmap X.astNode b)+ where+ element typeQName =+ X.element (opcQName elementName) [(xsiQName "type", X.qNameContent typeQName)]+ primitive typeName content =+ element (X.namespacedQName Ns.xsd typeName) [X.contentNode content]+ primitiveArray :: Gv.Vector v a => Text -> Text -> (a -> X.Content) -> v a -> X.Element+ primitiveArray arrayTypeName itemTagName itemContentRenderer array =+ element (X.namespacedQName Ns.opc arrayTypeName) $ fmap item $ Gv.toList array+ where+ item x =+ X.elementNode $ X.element (opcQName itemTagName) [] [X.contentNode (itemContentRenderer x)]++diagnosticInfoElement :: Text -> Text -> X.Element+diagnosticInfoElement elementName x =+ X.element (opcQName elementName) [] [X.contentNode (X.textContent x)]++opcQualityElement :: Text -> OpcQuality -> X.Element+opcQualityElement elementName x =+ X.element (opcQName elementName) (opcQualityAttributes x) []++writeRequestItemListElement :: Text -> WriteRequestItemList -> X.Element+writeRequestItemListElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [("ItemPath",) . X.textContent <$> #itemPath x]+ )+ (X.elementNode . itemValueElement "Items" <$> toList (#items x))++writeElement :: Text -> Write -> X.Element+writeElement elementName x =+ X.element+ (opcQName elementName)+ [("ReturnValuesOnReply", booleanContent (#returnValuesOnReply x))]+ ( catMaybes+ [ X.elementNode . writeRequestItemListElement "ItemList" <$> #itemList x,+ X.elementNode . requestOptionsElement "Options" <$> #options x+ ]+ )++readRequestItemElement :: Text -> ReadRequestItem -> X.Element+readRequestItemElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("ItemPath",) . X.textContent <$> #itemPath x,+ ("ReqType",) . qNameContent <$> #reqType x,+ ("ItemName",) . X.textContent <$> #itemName x,+ ("ClientItemHandle",) . X.textContent <$> #clientItemHandle x,+ ("MaxAge",) . intContent <$> #maxAge x+ ]+ )+ noContent++readRequestItemListElement :: Text -> ReadRequestItemList -> X.Element+readRequestItemListElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("ItemPath",) . X.textContent <$> #itemPath x,+ ("ReqType",) . qNameContent <$> #reqType x,+ ("MaxAge",) . intContent <$> #maxAge x+ ]+ )+ (X.elementNode . readRequestItemElement "Items" <$> toList (#items x))++readElement :: Text -> Read -> X.Element+readElement elementName x =+ X.element+ (opcQName elementName)+ []+ ( catMaybes+ [ X.elementNode . requestOptionsElement "Options" <$> #options x,+ X.elementNode . readRequestItemListElement "ItemList" <$> #itemList x+ ]+ )++subscriptionPolledRefreshElement :: Text -> SubscriptionPolledRefresh -> X.Element+subscriptionPolledRefreshElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("HoldTime",) . dateTimeContent <$> #holdTime x,+ pure ("WaitTime", intContent (#waitTime x)),+ pure ("ReturnAllItems", booleanContent (#returnAllItems x))+ ]+ )+ ( catMaybes [X.elementNode . requestOptionsElement "Options" <$> #options x]+ <> fmap (X.elementNode . serverSubHandlesElement "ServerSubHandles") (toList (#serverSubHandles x))+ )++serverSubHandlesElement :: Text -> Text -> X.Element+serverSubHandlesElement elementName x =+ X.element (opcQName elementName) [] [X.contentNode (X.textContent x)]++subscriptionCancelElement :: Text -> SubscriptionCancel -> X.Element+subscriptionCancelElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("ClientRequestHandle",) . X.textContent <$> #clientRequestHandle x,+ ("ServerSubHandle",) . X.textContent <$> #serverSubHandle x+ ]+ )+ noContent++browseElement :: Text -> Browse -> X.Element+browseElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("LocaleID",) . X.textContent <$> #localeId x,+ ("ClientRequestHandle",) . X.textContent <$> #clientRequestHandle x,+ ("ItemPath",) . X.textContent <$> #itemPath x,+ ("ItemName",) . X.textContent <$> #itemName x,+ ("ContinuationPoint",) . X.textContent <$> #continuationPoint x,+ pure ("MaxElementsReturned", intContent (#maxElementsReturned x)),+ pure ("BrowseFilter", browseFilterContent (#browseFilter x)),+ ("ElementNameFilter",) . X.textContent <$> #elementNameFilter x,+ ("VendorFilter",) . X.textContent <$> #vendorFilter x,+ pure ("ReturnAllProperties", booleanContent (#returnAllProperties x)),+ pure ("ReturnAllPropertyValues", booleanContent (#returnAllPropertyValues x)),+ pure ("ReturnErrorText", booleanContent (#returnErrorText x))+ ]+ )+ (X.elementNode . propertyNameElement "PropertyNames" <$> toList (#propertyNames x))++propertyNameElement :: Text -> QName -> X.Element+propertyNameElement elementName x =+ X.element+ (opcQName elementName)+ []+ [X.contentNode (qNameContent x)]++getPropertiesElement :: Text -> GetProperties -> X.Element+getPropertiesElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("LocaleID",) . X.textContent <$> #localeId x,+ ("ClientRequestHandle",) . X.textContent <$> #clientRequestHandle x,+ ("ItemPath",) . X.textContent <$> #itemPath x,+ Just ("ReturnAllProperties", booleanContent (#returnAllProperties x)),+ Just ("ReturnPropertyValues", booleanContent (#returnPropertyValues x)),+ Just ("ReturnErrorText", booleanContent (#returnErrorText x))+ ]+ )+ ( mconcat+ [ X.elementNode . propertyNameElement "PropertyNames" <$> toList (#propertyNames x),+ X.elementNode . itemIdentifierElement "ItemIDs" <$> toList (#itemIds x)+ ]+ )++itemIdentifierElement :: Text -> ItemIdentifier -> X.Element+itemIdentifierElement elementName x =+ X.element+ (opcQName elementName)+ ( catMaybes+ [ ("ItemPath",) . X.textContent <$> #itemPath x,+ ("ItemName",) . X.textContent <$> #itemName x+ ]+ )+ noContent++-- * Attributes++opcQualityAttributes :: OpcQuality -> [(X.QName, X.Content)]+opcQualityAttributes x =+ [ ("QualityField", qualityBitsContent (#qualityField x)),+ ("LimitField", limitBitsContent (#limitField x)),+ ("VendorField", shownContent (#vendorField x))+ ]++-- * Content++shownContent :: Show a => a -> X.Content+shownContent = X.textContent . fromString . show++stringContent :: Text -> X.Content+stringContent = X.textContent++booleanContent :: Bool -> X.Content+booleanContent = X.textContent . bool "false" "true"++floatContent :: Float -> X.Content+floatContent = shownContent++doubleContent :: Double -> X.Content+doubleContent = shownContent++decimalContent :: Scientific -> X.Content+decimalContent = shownContent++longContent :: Int64 -> X.Content+longContent = shownContent++intContent :: Int32 -> X.Content+intContent = shownContent++shortContent :: Int16 -> X.Content+shortContent = shownContent++byteContent :: Int8 -> X.Content+byteContent = shownContent++unsignedLongContent :: Word64 -> X.Content+unsignedLongContent = shownContent++unsignedIntContent :: Word32 -> X.Content+unsignedIntContent = shownContent++unsignedShortContent :: Word16 -> X.Content+unsignedShortContent = shownContent++unsignedByteContent :: Word8 -> X.Content+unsignedByteContent = shownContent++base64BinaryContent :: ByteString -> X.Content+base64BinaryContent = X.textContent . Base64.encodeBase64++dateTimeContent :: UTCTime -> X.Content+dateTimeContent = X.textContent . Tb.run . XmlSchemaValuesRendering.dateTime++timeContent :: Time -> X.Content+timeContent = X.textContent . Tb.run . XmlSchemaValuesRendering.time++dateContent :: Date -> X.Content+dateContent = X.textContent . Tb.run . XmlSchemaValuesRendering.date++durationContent :: Duration -> X.Content+durationContent = X.textContent . Tb.run . XmlSchemaValuesRendering.duration++qNameContent :: QName -> X.Content+qNameContent = X.qNameContent . qNameQName++browseFilterContent :: BrowseFilter -> X.Content+browseFilterContent = \case+ AllBrowseFilter -> "all"+ BranchBrowseFilter -> "branch"+ ItemBrowseFilter -> "item"++qualityBitsContent :: QualityBits -> X.Content+qualityBitsContent = \case+ BadQualityBits -> "bad"+ BadConfigurationErrorQualityBits -> "badConfigurationError"+ BadNotConnectedQualityBits -> "badNotConnected"+ BadDeviceFailureQualityBits -> "badDeviceFailure"+ BadSensorFailureQualityBits -> "badSensorFailure"+ BadLastKnownValueQualityBits -> "badLastKnownValue"+ BadCommFailureQualityBits -> "badCommFailure"+ BadOutOfServiceQualityBits -> "badOutOfService"+ BadWaitingForInitialDataQualityBits -> "badWaitingForInitialData"+ UncertainQualityBits -> "uncertain"+ UncertainLastUsableValueQualityBits -> "uncertainLastUsableValue"+ UncertainSensorNotAccurateQualityBits -> "uncertainSensorNotAccurate"+ UncertainEUExceededQualityBits -> "uncertainEUExceeded"+ UncertainSubNormalQualityBits -> "uncertainSubNormal"+ GoodQualityBits -> "good"+ GoodLocalOverrideQualityBits -> "goodLocalOverride"++limitBitsContent :: LimitBits -> X.Content+limitBitsContent = \case+ NoneLimitBits -> "none"+ LowLimitBits -> "low"+ HighLimitBits -> "high"+ ConstantLimitBits -> "constant"++-- * Names++soapEncQName :: Text -> X.QName+soapEncQName =+ X.namespacedQName Ns.soapEnc++soapEnvQName :: Text -> X.QName+soapEnvQName =+ X.namespacedQName Ns.soapEnv++xsdQName :: Text -> X.QName+xsdQName =+ X.namespacedQName Ns.xsd++xsiQName :: Text -> X.QName+xsiQName =+ X.namespacedQName Ns.xsi++opcQName :: Text -> X.QName+opcQName =+ X.namespacedQName Ns.opc++qNameQName :: QName -> X.QName+qNameQName = \case+ NamespacedQName ns name -> X.namespacedQName ns name+ UnnamespacedQName name -> X.unnamespacedQName name
+ protocol/OpcXmlDaClient/Protocol/XmlParsing.hs view
@@ -0,0 +1,565 @@+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+ <> "."
+ protocol/types.domain.yaml view
@@ -0,0 +1,442 @@+# XML-DA base types++GetStatus:+ product:+ localeId: Maybe Text+ clientRequestHandle: Maybe Text++GetStatusResponse:+ product:+ result: Maybe ReplyBase+ status: Maybe ServerStatus++ReplyBase:+ product:+ rcvTime: UTCTime+ replyTime: UTCTime+ clientRequestHandle: Maybe Text+ revisedLocaleId: Maybe Text+ serverState: ServerState++ServerState:+ enum:+ - running+ - failed+ - noConfig+ - suspended+ - test+ - commFault++ServerStatus:+ product:+ statusInfo: Maybe Text+ vendorInfo: Maybe Text+ supportedLocaleIds: Vector Text+ supportedInterfaceVersions: Vector Text+ startTime: UTCTime+ productVersion: Maybe Text++Read:+ product:+ options: Maybe RequestOptions+ itemList: Maybe ReadRequestItemList++RequestOptions:+ product:+ returnErrorText: Bool+ returnDiagnosticInfo: Bool+ returnItemTime: Bool+ returnItemPath: Bool+ returnItemName: Bool+ requestDeadline: Maybe UTCTime+ clientRequestHandle: Maybe Text+ localeId: Maybe Text++ReadRequestItemList:+ product:+ items: Vector ReadRequestItem+ itemPath: Maybe Text+ reqType: Maybe QName+ maxAge: Maybe Int32++ReadRequestItem:+ product:+ itemPath: Maybe Text+ reqType: Maybe QName+ itemName: Maybe Text+ clientItemHandle: Maybe Text+ maxAge: Maybe Int32++ReadResponse:+ product:+ readResult: Maybe ReplyBase+ rItemList: Maybe ReplyItemList+ errors: Vector OpcError++ReplyItemList:+ product:+ items: Vector ItemValue+ reserved: Maybe Text++ItemValue:+ product:+ diagnosticInfo: Maybe Text+ value: Maybe Value+ quality: Maybe OpcQuality+ valueTypeQualifier: Maybe QName+ itemPath: Maybe Text+ itemName: Maybe Text+ clientItemHandle: Maybe Text+ timestamp: Maybe UTCTime+ resultId: Maybe QName++OpcQuality:+ product:+ qualityField: QualityBits+ limitField: LimitBits+ vendorField: Word8++QualityBits:+ enum:+ - bad+ - badConfigurationError+ - badNotConnected+ - badDeviceFailure+ - badSensorFailure+ - badLastKnownValue+ - badCommFailure+ - badOutOfService+ - badWaitingForInitialData+ - uncertain+ - uncertainLastUsableValue+ - uncertainSensorNotAccurate+ - uncertainEUExceeded+ - uncertainSubNormal+ - good+ - goodLocalOverride++LimitBits:+ enum:+ - none+ - low+ - high+ - constant++OpcError:+ product:+ text: Maybe Text+ id: QName++Write:+ product:+ options: Maybe RequestOptions+ itemList: Maybe WriteRequestItemList+ returnValuesOnReply: Bool++WriteRequestItemList:+ product:+ items: Vector ItemValue+ itemPath: Maybe Text++WriteResponse:+ product:+ writeResult: Maybe ReplyBase+ rItemList: Maybe ReplyItemList+ errors: Vector OpcError++Subscribe:+ product:+ options: Maybe RequestOptions+ itemList: Maybe SubscribeRequestItemList+ returnValuesOnReply: Bool+ subscriptionPingRate: Maybe Int32++SubscribeRequestItemList:+ product:+ items: Vector SubscribeRequestItem+ itemPath: Maybe Text+ reqType: Maybe QName+ deadband: Maybe Float+ requestedSamplingRate: Maybe Int32+ enableBuffering: Maybe Bool++SubscribeRequestItem:+ product:+ itemPath: Maybe Text+ reqType: Maybe QName+ itemName: Maybe Text+ clientItemHandle: Maybe Text+ deadband: Maybe Float+ requestedSamplingRate: Maybe Int32+ enableBuffering: Maybe Bool++SubscribeReplyItemList:+ product:+ items: Vector SubscribeItemValue+ revisedSamplingRate: Maybe Int32++SubscribeItemValue:+ product:+ # We're avoiding a Maybe here, since the spec says that it has minOccurs set to 0+ # only to satisfy the needs of some codegen tools.+ # See Section 3.5.2 of the spec.+ itemValue: ItemValue+ revisedSamplingRate: Maybe Int++SubscribeResponse:+ product:+ subscribeResult: Maybe ReplyBase+ rItemList: Maybe SubscribeReplyItemList+ errors: Vector OpcError+ serverSubHandle: Maybe Text++SubscriptionPolledRefresh:+ product:+ options: Maybe RequestOptions+ serverSubHandles: Vector Text+ holdTime: Maybe UTCTime+ waitTime: Int32+ returnAllItems: Bool++SubscribePolledRefreshReplyItemList:+ product:+ items: Vector ItemValue+ subscriptionHandle: Maybe Text++SubscriptionPolledRefreshResponse:+ product:+ subscriptionPolledRefreshResult: Maybe ReplyBase+ invalidServerSubHandles: Vector Text+ rItemList: Vector SubscribePolledRefreshReplyItemList+ errors: Vector OpcError+ dataBufferOverflow: Bool++SubscriptionCancel:+ product:+ serverSubHandle: Maybe Text+ clientRequestHandle: Maybe Text++SubscriptionCancelResponse:+ product:+ clientRequestHandle: Maybe Text++Browse:+ product:+ propertyNames: Vector QName+ localeId: Maybe Text+ clientRequestHandle: Maybe Text+ itemPath: Maybe Text+ itemName: Maybe Text+ continuationPoint: Maybe Text+ maxElementsReturned: Int32+ browseFilter: BrowseFilter+ elementNameFilter: Maybe Text+ vendorFilter: Maybe Text+ returnAllProperties: Bool+ returnAllPropertyValues: Bool+ returnErrorText: Bool++BrowseFilter:+ enum:+ - all+ - branch+ - item++BrowseElement:+ product:+ properties: Vector ItemProperty+ name: Maybe Text+ itemPath: Maybe Text+ itemName: Maybe Text+ isItem: Bool+ hasChildren: Bool++ItemProperty:+ product:+ value: Maybe Value+ name: QName+ description: Maybe Text+ itemPath: Maybe Text+ itemName: Maybe Text+ resultId: Maybe QName++BrowseResponse:+ product:+ browseResult: Maybe ReplyBase+ elements: Vector BrowseElement+ errors: Vector OpcError+ continuationPoint: Maybe Text+ moreElements: Bool++GetProperties:+ product:+ itemIds: Vector ItemIdentifier+ propertyNames: Vector QName+ localeId: Maybe Text+ clientRequestHandle: Maybe Text+ itemPath: Maybe Text+ returnAllProperties: Bool+ returnPropertyValues: Bool+ returnErrorText: Bool++ItemIdentifier:+ product:+ itemPath: Maybe Text+ itemName: Maybe Text++PropertyReplyList:+ product:+ properties: Vector ItemProperty+ itemPath: Maybe Text+ itemName: Maybe Text+ resultId: Maybe QName++GetPropertiesResponse:+ product:+ getPropertiesResult: Maybe ReplyBase+ propertyLists: Vector PropertyReplyList+ errors: Vector OpcError++# Standard OPC result code as per the definition in the 3.1.9 section of the spec.+ResultCode:+ enum:+ ## Success+ # The value written was accepted but the output was clamped.+ # S_CLAMP+ - clamp+ # Not every detected change has been returned since the server's buffer reached its limit and had to purge out the oldest data.+ # S_DATAQUEUEOVERFLOW+ - dataQueueOverflow+ # The server does not support the requested rate but will use the closest available rate.+ # S_UNSUPPORTEDRATE+ - unsupportedRate+ ## Failure+ # The server denies access (read and/or write) to the specified item. This error is typically caused by Web Service security (e.g. globally disabled write capabilities).+ # E_ACCESS_DENIED+ - accessDenied+ # The server is currenly processing another polled refresh for one or more of the subscriptions.+ # E_BUSY+ - busy+ # Unspecified error.+ # E_FAIL+ - fail+ # The continuation point is not valid.+ # E_INVALIDCONTINUATIONPOINT+ - invalidContinuationPoint+ # The filter string is not valid.+ # E_INVALIDFILTER+ - invalidFilter+ # The hold time is too long (determined by server).+ # E_INVALIDHOLDTIME+ - invalidHoldTime+ # The item name does not conform the server’s syntax.+ # E_INVALIDITEMNAME+ - invalidItemName+ # The item path does not conform the server’s syntax.+ # E_INVALIDITEMPATH+ - invalidItemPath+ # The property id is not valid for the item.+ # E_INVALIDPID+ - invalidPid+ # An invalid set of subscription handles was passed to the request.+ # E_NOSUBSCRIPTION+ - noSubscription+ # The server does not support writing to the quality and/or timestamp.+ # E_NOTSUPPORTED+ - notSupported+ # Ran out of memory.+ # E_OUTOFMEMORY+ - outOfMemory+ # The value was out of range.+ # E_RANGE+ - range+ # The value is read only and may not be written to.+ # E_READONLY+ - readOnly+ # The operation could not complete due to an abnormal server state.+ # E_SERVERSTATE+ - serverState+ # The operation took too long to complete (determined by server).+ # E_TIMEDOUT+ - timedOut+ # The item name is no longer available in the server address space.+ # E_UNKNOWNITEMNAME+ - unknownItemName+ # The item path is no longer available in the server address space.+ # E_UNKNOWNITEMPATH+ - unknownItemPath+ # The value is write-only and may not be read from or returned as part of a write response.+ # E_WRITEONLY+ - writeOnly++QName:+ sum:+ namespaced:+ - Text+ - Text+ unnamespaced: Text++Value:+ sum:+ string: Text+ boolean: Bool+ float: Float+ double: Double+ decimal: Scientific+ long: Int64+ int: Int32+ short: Int16+ byte: Int8+ unsignedLong: Word64+ unsignedInt: Word32+ unsignedShort: Word16+ unsignedByte: Word8+ base64Binary: ByteString+ dateTime: UTCTime+ time: Time+ date: Date+ duration: Duration+ qName: QName+ arrayOfByte: Uv.Vector Int8+ arrayOfShort: Uv.Vector Int16+ arrayOfUnsignedShort: Uv.Vector Word16+ arrayOfInt: Uv.Vector Int32+ arrayOfUnsignedInt: Uv.Vector Word32+ arrayOfLong: Uv.Vector Int64+ arrayOfUnsignedLong: Uv.Vector Word64+ arrayOfFloat: Uv.Vector Float+ arrayOfDecimal: Vector Scientific+ arrayOfDouble: Uv.Vector Double+ arrayOfBoolean: Uv.Vector Bool+ arrayOfString: Vector Text+ arrayOfDateTime: Vector UTCTime+ arrayOfAnyType: Vector (Maybe Value)+ opcQuality: OpcQuality+ nonStandard:+ product:+ type: QName+ xml: "[Xml.Node]"++SoapFault:+ product:+ code: SoapFaultCode+ reason: Text++SoapFaultCode:+ sum:+ std: StdSoapFaultCode+ custom: QName++# https://www.w3.org/TR/soap12-part1/#faultcodes+StdSoapFaultCode:+ enum:+ # The faulting node found an invalid element information item instead of the expected Envelope element information item. The namespace, local name or both did not match the Envelope element information item required by this recommendation (see 2.8 SOAP Versioning Model and 5.4.7 VersionMismatch Faults)+ - versionMismatch+ # An immediate child element information item of the SOAP Header element information item targeted at the faulting node that was not understood by the faulting node contained a SOAP mustUnderstand attribute information item with a value of "true" (see 5.2.3 SOAP mustUnderstand Attribute and 5.4.8 SOAP mustUnderstand Faults)+ - mustUnderstand+ # A SOAP header block or SOAP body child element information item targeted at the faulting SOAP node is scoped (see 5.1.1 SOAP encodingStyle Attribute) with a data encoding that the faulting node does not support.+ - dataEncodingUnknown+ # The message was incorrectly formed or did not contain the appropriate information in order to succeed. For example, the message could lack the proper authentication or payment information. It is generally an indication that the message is not to be resent without change (see also 5.4 SOAP Fault for a description of the SOAP fault detail sub-element).+ - sender+ # The message could not be processed for reasons attributable to the processing of the message rather than to the contents of the message itself. For example, processing could include communicating with an upstream SOAP node, which did not respond. The message could succeed if resent at a later point in time (see also 5.4 SOAP Fault for a description of the SOAP fault detail sub-element).+ - receiver
+ quickcheck-util/OpcXmlDaClient/QuickCheckUtil/Gens.hs view
@@ -0,0 +1,88 @@+module OpcXmlDaClient.QuickCheckUtil.Gens where++import qualified Data.Text as Text+import qualified Data.Time.Calendar.OrdinalDate as Time+import qualified Data.Time.LocalTime as Time+import Test.QuickCheck+import Prelude hiding (choose, optional)++-- * General++maybeOf :: Gen a -> Gen (Maybe a)+maybeOf gen =+ oneof [pure Nothing, Just <$> gen]++onceIn :: Int -> Gen Bool+onceIn n =+ (== 1) <$> chooseInt (1, n)++-- * Time++year :: Gen Integer+year = choose (-9999, 9999)++dayOfCommonYear :: Gen Int+dayOfCommonYear = choose (1, 365)++dayOfLeapYear :: Gen Int+dayOfLeapYear = choose (1, 366)++-- |+-- The arbitrary instance generates scarce values.+day :: Gen Day+day = do+ _year <- year+ _dayOfYear <- if Time.isLeapYear _year then dayOfLeapYear else dayOfCommonYear+ return $ Time.fromOrdinalDate _year _dayOfYear++-- |+-- The arbitrary instance generates broken values.+-- This is an alternative to it.+timeZone :: Gen TimeZone+timeZone =+ Time.hoursToTimeZone <$> choose (-24, 24)++utcTimeInRange :: UTCTime -> UTCTime -> Gen UTCTime+utcTimeInRange min max =+ systemToUTCTime . flip MkSystemTime 0 <$> choose (minSec, maxSec)+ where+ MkSystemTime minSec _ = utcToSystemTime min+ MkSystemTime maxSec _ = utcToSystemTime max++recentTime :: Gen UTCTime+recentTime =+ utcTimeInRange (read "2020-01-01 00:00:00Z") (unsafePerformIO (getCurrentTime))++-- * Text++text :: Gen Text+text =+ do+ firstSentence <- sentence+ otherSentences <- listOf $ do+ doParagraph <- onceIn 5+ let prefix = if doParagraph then "\n" else " "+ (prefix <>) <$> sentence+ return (mconcat (firstSentence : otherSentences))++sentence :: Gen Text+sentence =+ do+ firstWord <- Text.toTitle <$> word+ extraWordsAmount <- chooseInt (0, 20)+ extraWords <- replicateM extraWordsAmount $ do+ prefix <- do+ prependPunctuation <- (== 0) <$> chooseInt (0, 9)+ if prependPunctuation+ then elements [", ", ": ", " - "]+ else pure " "+ theWord <- do+ titleCase <- (== 0) <$> chooseInt (0, 9)+ (if titleCase then Text.toTitle else id) <$> word+ return (prefix <> theWord)+ return (firstWord <> mconcat extraWords)++word :: Gen Text+word =+ elements+ ["foo", "bar", "qux", "quux", "quuz", "corge", "grault", "garply", "waldo", "fred", "plugh", "xyzzy", "thud"]
+ xml-builder/OpcXmlDaClient/XmlBuilder.hs view
@@ -0,0 +1,124 @@+-- |+-- A utility library providing automatic namespacing,+-- which is required in handling of custom value types by the OPC protocol.+module OpcXmlDaClient.XmlBuilder+ ( -- * ByteString+ elementXml,++ -- * Element+ Element,+ element,++ -- * Node+ Node,+ elementNode,+ contentNode,+ astNode,++ -- * Content+ Content,+ textContent,+ qNameContent,++ -- * QName+ QName,+ namespacedQName,+ unnamespacedQName,+ )+where++import qualified Data.ByteString.Lazy as Lbs+import qualified Data.Map.Strict as Map+import OpcXmlDaClient.Base.Prelude+import qualified OpcXmlDaClient.XmlBuilder.Identified as Identified+import qualified Text.XML as Xml++-- *++elementXml :: Element -> ByteString+elementXml (Element namespacedElement) =+ case runNamespaced namespacedElement of+ (element, namespaces) ->+ let document = Xml.Document (Xml.Prologue [] Nothing []) element []+ renderingSettings = def {Xml.rsNamespaces = fmap swap namespaces}+ in Lbs.toStrict (Xml.renderLBS renderingSettings document)++-- *++newtype Element = Element (Namespaced Xml.Element)++element :: QName -> [(QName, Content)] -> [Node] -> Element+element (QName qName) attrList nodeList =+ Element $+ Xml.Element+ <$> qName+ <*> fmap Map.fromList (traverse attr attrList)+ <*> traverse runNode nodeList+ where+ attr (QName name, Content content) =+ (,) <$> name <*> content++-- *++newtype Node = Node {runNode :: Namespaced Xml.Node}++elementNode :: Element -> Node+elementNode (Element a) = Node (fmap Xml.NodeElement a)++contentNode :: Content -> Node+contentNode (Content a) = Node (fmap Xml.NodeContent a)++astNode :: Xml.Node -> Node+astNode = Node . pure++-- *++newtype Content = Content (Namespaced Text)++instance IsString Content where+ fromString = textContent . fromString++textContent :: Text -> Content+textContent text =+ Content (pure text)++qNameContent :: QName -> Content+qNameContent (QName qName) =+ Content (fmap renderName qName)+ where+ renderName (Xml.Name name _ prefix) =+ maybe name (\prefix -> prefix <> ":" <> name) prefix++-- *++newtype QName = QName (Namespaced Xml.Name)++instance IsString QName where+ fromString = unnamespacedQName . fromString++-- |+-- Namespaced QName.+namespacedQName ::+ -- | Namespace URI.+ Text ->+ -- | Name.+ Text ->+ QName+namespacedQName uri name =+ QName (Identified.identifying uri (\prefix -> Xml.Name name (Just uri) (Just prefix)))++-- |+-- Unnamespaced QName.+unnamespacedQName :: Text -> QName+unnamespacedQName name =+ QName (pure (Xml.Name name Nothing Nothing))++-- *++type Namespaced = Identified.Identified Text Text++runNamespaced :: Namespaced a -> (a, [(Text, Text)])+runNamespaced identified =+ Identified.run identified alias+ where+ alias x = "ns" <> fromString (show (succ x))
+ xml-builder/OpcXmlDaClient/XmlBuilder/Identified.hs view
@@ -0,0 +1,32 @@+module OpcXmlDaClient.XmlBuilder.Identified where++import qualified Acc+import qualified Data.HashMap.Strict as HashMap+import qualified OpcXmlDaClient.Base.HashMap as HashMap+import OpcXmlDaClient.Base.Prelude++-- |+-- Abstraction over incremental indexed value generation.+--+-- Useful for such things as generating aliases.+data Identified k v r+ = Identified (Acc.Acc k) ((k -> v) -> r)++deriving instance Functor (Identified k v)++instance Applicative (Identified k v) where+ pure x = Identified mempty (const x)+ Identified keysL buildL <*> Identified keysR buildR =+ Identified (keysL <> keysR) (\map -> buildL map (buildR map))++run :: (Hashable k, Eq k) => Identified k v a -> (Int -> v) -> (a, [(k, v)])+run (Identified uriAcc build) proj =+ HashMap.autoincrementedFoldable uriAcc proj+ & \map -> (build (\k -> HashMap.lookupDefault (error "Bug") k map), HashMap.toList map)++-- |+-- Register a key if it hasn't been registered already,+-- and build a result in the scope of the incremental value associated with the key.+identifying :: k -> (v -> a) -> Identified k v a+identifying uri byAlias =+ Identified (pure uri) (\map -> byAlias (map uri))
+ xml-schema-values-test/Main.hs view
@@ -0,0 +1,24 @@+module Main where++import qualified Data.Attoparsec.Text as At+import qualified OpcXmlDaClient.QuickCheckUtil.Gens as Gens+import qualified OpcXmlDaClient.XmlSchemaValues.Attoparsec as Attoparsec+import qualified OpcXmlDaClient.XmlSchemaValues.Rendering as Rendering+import OpcXmlDaClient.XmlSchemaValues.Types+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.QuickCheck+import qualified Text.Builder as Tb+import Prelude hiding (choose)++main =+ defaultMain $+ testGroup+ ""+ [ testProperty "Rendered date parses into the same value" $ do+ _date <- Date <$> Gens.day <*> Gens.maybeOf Gens.timeZone+ let _rendering = Tb.run $ Rendering.date _date+ _parsingResult = At.parseOnly Attoparsec.date _rendering+ in return $ Right _date === _parsingResult+ ]
+ xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Attoparsec.hs view
@@ -0,0 +1,54 @@+module OpcXmlDaClient.XmlSchemaValues.Attoparsec+ ( dateTime,+ time,+ date,+ duration,+ )+where++import qualified Attoparsec.Data as Ad+import Data.Attoparsec.Text+import qualified Data.Text as Text+import qualified Data.Time.Format.ISO8601 as Iso8601+import OpcXmlDaClient.Base.Prelude+import OpcXmlDaClient.XmlSchemaValues.Types+import qualified OpcXmlDaClient.XmlSchemaValues.Util.TimeMath as TimeMath++-- |+-- XML Schema dateTime.+--+-- https://www.w3.org/TR/xmlschema-2/#dateTime+dateTime :: Parser UTCTime+dateTime = Ad.utcTimeInISO8601++-- |+-- XML Schema time.+--+-- https://www.w3.org/TR/xmlschema-2/#time+time :: Parser Time+time = do+ _timeOfDay <- Ad.timeOfDayInISO8601+ _timeZone <- optional Ad.timeZoneInISO8601+ return $ Time _timeOfDay _timeZone++-- |+-- XML Schema date.+--+-- https://www.w3.org/TR/xmlschema-2/#date+date :: Parser Date+date = do+ _applyNeg <- fmap TimeMath.negateDay <$ char '-' <|> pure id+ _day <- _applyNeg Ad.dayInISO8601+ _timeZone <- optional Ad.timeZoneInISO8601+ return $ Date _day _timeZone++-- |+-- XML Schema duration.+--+-- https://www.w3.org/TR/xmlschema-2/#duration+duration :: Parser Duration+duration = do+ _pos <- False <$ char '-' <|> pure True+ _textRemainder <- takeText+ _diff <- Iso8601.iso8601ParseM $ Text.unpack _textRemainder+ return $ Duration _pos _diff
+ xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Rendering.hs view
@@ -0,0 +1,27 @@+module OpcXmlDaClient.XmlSchemaValues.Rendering+ ( dateTime,+ time,+ date,+ duration,+ )+where++import qualified Data.Time.Format.ISO8601 as Iso8601+import OpcXmlDaClient.Base.Prelude+import OpcXmlDaClient.XmlSchemaValues.Types+import Text.Builder++dateTime :: UTCTime -> Builder+dateTime = iso8601Show++time :: Time -> Builder+time (Time a b) = iso8601Show a <> foldMap iso8601Show b++date :: Date -> Builder+date (Date a b) = iso8601Show a <> foldMap iso8601Show b++duration :: Duration -> Builder+duration (Duration a b) = bool (mappend "-") id a $ iso8601Show b++iso8601Show :: Iso8601.ISO8601 a => a -> Builder+iso8601Show = fromString . Iso8601.iso8601Show
+ xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Types.hs view
@@ -0,0 +1,30 @@+module OpcXmlDaClient.XmlSchemaValues.Types where++import qualified Domain+import qualified DomainOptics+import OpcXmlDaClient.Base.Prelude++Domain.declare+ (Just (True, False))+ ( mconcat+ [ Domain.enumDeriver,+ Domain.boundedDeriver,+ Domain.showDeriver,+ Domain.eqDeriver,+ Domain.genericDeriver,+ Domain.dataDeriver,+ Domain.typeableDeriver,+ Domain.hasFieldDeriver,+ Domain.constructorIsLabelDeriver,+ Domain.accessorIsLabelDeriver,+ DomainOptics.labelOpticDeriver+ ]+ )+ =<< Domain.loadSchema "xml-schema-values/types.domain.yaml"++deriving instance Ord Date++deriving instance Ord Time++instance Ord Duration where+ compare = on compare (\(Duration a (CalendarDiffTime b c)) -> (a, b, c))
+ xml-schema-values/OpcXmlDaClient/XmlSchemaValues/Util/TimeMath.hs view
@@ -0,0 +1,9 @@+module OpcXmlDaClient.XmlSchemaValues.Util.TimeMath where++import Data.Time.Calendar.OrdinalDate+import OpcXmlDaClient.Base.Prelude++negateDay :: Day -> Day+negateDay x =+ case toOrdinalDate x of+ (year, dayOfYear) -> fromOrdinalDate (negate year) dayOfYear
+ xml-schema-values/types.domain.yaml view
@@ -0,0 +1,15 @@++Date:+ product:+ day: Day+ timeZone: Maybe TimeZone++Time:+ product:+ timeOfDay: TimeOfDay+ timeZone: Maybe TimeZone++Duration:+ product:+ positive: Bool+ diff: CalendarDiffTime