asakul
/
transaq-connector
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Fix warnings

master
Denis Tereshkin 5 months ago
parent
03188f5fa4
commit
de643d3297
10 changed files with 118 additions and 94 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 5
      src/Commissions.hs
  2. 40
      src/Config.hs
  3. 5
      src/FSM.hs
  4. 19
      src/Main.hs
  5. 8
      src/PaperBroker.hs
  6. 43
      src/TXMLConnector/Internal.hs
  7. 11
      src/TickerInfoServer.hs
  8. 52
      src/Transaq.hs
  9. 23
      src/Transaq/Parsing.hs
  10. 6
      transaq-connector.cabal

5
src/Commissions.hs
Unescape View File

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Commissions ( module Commissions (
CommissionConfig(..) CommissionConfig(..)
@ -7,7 +6,7 @@ module Commissions (
import qualified Data.Text as T import qualified Data.Text as T
import Dhall import Dhall
import GHC.Generics import GHC.Generics ()
data CommissionConfig = CommissionConfig { data CommissionConfig = CommissionConfig {
comPrefix :: T.Text, comPrefix :: T.Text,

40
src/Config.hs
Unescape View File

@ -1,4 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Config module Config
( (
@ -7,9 +9,13 @@ module Config
loadConfig, loadConfig,
) where ) where
import ATrade.Logging (Severity (..))
import Commissions import Commissions
import qualified Data.Text as T import qualified Data.Text as T
import Dhall (FromDhall (autoWith), auto, expected, inputFile) import Dhall (Decoder (..), FromDhall (autoWith), auto,
expected, inputFile, typeError)
import Dhall.Core (Expr (..), FieldSelection (..))
import qualified Dhall.Map
import GHC.Generics import GHC.Generics
data SubscriptionConfig = SubscriptionConfig T.Text T.Text data SubscriptionConfig = SubscriptionConfig T.Text T.Text
@ -18,7 +24,8 @@ data SubscriptionConfig = SubscriptionConfig T.Text T.Text
instance FromDhall SubscriptionConfig instance FromDhall SubscriptionConfig
data TransaqConnectorConfig = TransaqConnectorConfig { data TransaqConnectorConfig = TransaqConnectorConfig {
logLevel :: Int, baseLogLevel :: Severity,
componentsLogLevel :: [(T.Text, Severity)],
quotesourceEndpoint :: T.Text, quotesourceEndpoint :: T.Text,
brokerEndpoint :: T.Text, brokerEndpoint :: T.Text,
brokerNotificationsEndpoint :: T.Text, brokerNotificationsEndpoint :: T.Text,
@ -49,3 +56,28 @@ instance FromDhall TransaqConnectorConfig
loadConfig :: FilePath -> IO TransaqConnectorConfig loadConfig :: FilePath -> IO TransaqConnectorConfig
loadConfig = inputFile auto loadConfig = inputFile auto
instance FromDhall Severity where
autoWith _ = Decoder {..}
where
extract expr@(Field _ FieldSelection{ fieldSelectionLabel }) =
case fieldSelectionLabel of
"Trace" -> pure Trace
"Debug" -> pure Debug
"Info" -> pure Info
"Warning" -> pure Warning
"Error" -> pure Error
_ -> typeError expected expr
extract expr = typeError expected expr
expected = pure
(Union
(Dhall.Map.fromList
[ ("Trace", Nothing)
, ("Debug", Nothing)
, ("Info", Nothing)
, ("Warning", Nothing)
, ("Error", Nothing)
]
)
)

5
src/FSM.hs
Unescape View File

@ -38,10 +38,7 @@ runFsm fsm = whileM $ do
Nothing -> pure (not . isTerminalState $ currentState) Nothing -> pure (not . isTerminalState $ currentState)
Nothing -> pure False Nothing -> pure False
makeFsm :: (MonadIO m1, makeFsm :: (MonadIO m1, Ord a) => a -> [(a, FSMCallback m a)] -> m1 (FSM a m)
MonadIO m,
FSMState a,
Ord a) => a -> [(a, FSMCallback m a)] -> m1 (FSM a m)
makeFsm initialState handlers = do makeFsm initialState handlers = do
currentState <- liftIO $ newTVarIO initialState currentState <- liftIO $ newTVarIO initialState
pure $ FSM currentState (M.fromList handlers) pure $ FSM currentState (M.fromList handlers)

19
src/Main.hs
Unescape View File

@ -28,6 +28,7 @@ import Control.Concurrent.BoundedChan (BoundedChan,
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad (forever, void) import Control.Monad (forever, void)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Version (showVersion) import Data.Version (showVersion)
@ -52,15 +53,14 @@ import qualified TXMLConnector as Connector
import Version (transaqConnectorVersionText, import Version (transaqConnectorVersionText,
transaqConnector_gitrev) transaqConnector_gitrev)
mkLogger :: (MonadIO m) => Handle -> Severity -> LogAction m Message
mkLogger h sev = cfilter (\m -> msgSeverity m >= sev) (fmtMessage >$< (logTextStdout <> logTextHandle h))
parseLoglevel :: Int -> Severity mkLogger :: (MonadIO m) => Severity -> M.Map T.Text Severity -> Handle -> LogAction m Message
parseLoglevel 0 = Error mkLogger sev loglevels h = cfilter checkLoglevel (fmtMessage >$< (logTextStdout <> logTextHandle h))
parseLoglevel 1 = Warning where
parseLoglevel 2 = Info checkLoglevel msg =
parseLoglevel 3 = Debug case M.lookup (msgComponent msg) loglevels of
parseLoglevel _ = Trace Just level -> msgSeverity msg >= level
Nothing -> msgSeverity msg >= sev
forkQssChannel :: forkQssChannel ::
BoundedChan QuoteSourceServerData BoundedChan QuoteSourceServerData
@ -85,9 +85,8 @@ main = do
initEventCounters store initEventCounters store
statsdThread <- forkStatsd (defaultStatsdOptions { host = statsdHost cfg, port = statsdPort cfg, prefix = "transaq_connector"}) store statsdThread <- forkStatsd (defaultStatsdOptions { host = statsdHost cfg, port = statsdPort cfg, prefix = "transaq_connector"}) store
let loglevel = parseLoglevel (logLevel cfg)
withFile "transaq-connector.log" AppendMode $ \logH -> do withFile "transaq-connector.log" AppendMode $ \logH -> do
let logger = mkLogger logH loglevel let logger = mkLogger (baseLogLevel cfg) (M.fromList $ componentsLogLevel cfg) logH
let log = logWith logger let log = logWith logger
log Info "main" $ "Starting transaq-connector-" <> log Info "main" $ "Starting transaq-connector-" <>
transaqConnectorVersionText <> transaqConnectorVersionText <>

8
src/PaperBroker.hs
Unescape View File

@ -8,8 +8,6 @@ module PaperBroker (
) where ) where
import ATrade.Broker.Backend import ATrade.Broker.Backend
import ATrade.Broker.Protocol
import ATrade.Broker.Server
import ATrade.Logging (Message, Severity (..), import ATrade.Logging (Message, Severity (..),
logWith) logWith)
import ATrade.Types import ATrade.Types
@ -18,7 +16,6 @@ import Commissions (CommissionConfig (..))
import Control.Concurrent hiding (readChan, writeChan) import Control.Concurrent hiding (readChan, writeChan)
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Monad import Control.Monad
import Data.Bits
import Data.IORef import Data.IORef
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@ -28,7 +25,6 @@ import qualified Data.Text.Lazy as TL
import Data.Time.Clock import Data.Time.Clock
import Debug.EventCounters (emitEvent) import Debug.EventCounters (emitEvent)
import Language.Haskell.Printf (t) import Language.Haskell.Printf (t)
import System.ZMQ4
import TickerInfoServer import TickerInfoServer
import TickTable (TickTable, lookupTick) import TickTable (TickTable, lookupTick)
@ -56,7 +52,7 @@ hourMin :: Integer -> Integer -> DiffTime
hourMin h m = fromIntegral $ h * 3600 + m * 60 hourMin h m = fromIntegral $ h * 3600 + m * 60
mkPaperBroker :: TickTable -> TickerInfoServerHandle -> BoundedChan Tick -> Price -> [T.Text] -> [CommissionConfig] -> LogAction IO Message -> IO BrokerBackend mkPaperBroker :: TickTable -> TickerInfoServerHandle -> BoundedChan Tick -> Price -> [T.Text] -> [CommissionConfig] -> LogAction IO Message -> IO BrokerBackend
mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do mkPaperBroker tickTableH tisHandle tickChan startCash accounts comms l = do
state <- newIORef PaperBrokerState { state <- newIORef PaperBrokerState {
pbTid = Nothing, pbTid = Nothing,
tickTable = tickTableH, tickTable = tickTableH,
@ -74,7 +70,7 @@ mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do
postMarketCloseTime = hourMin 15 50, postMarketCloseTime = hourMin 15 50,
commissions = comms, commissions = comms,
logger = l, logger = l,
tisH = tisH tisH = tisHandle
} }
tid <- forkIO $ brokerThread tickChan state tickTableH tid <- forkIO $ brokerThread tickChan state tickTableH

43
src/TXMLConnector/Internal.hs
Unescape View File

@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -32,7 +33,7 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar',
import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue, import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue,
readTBQueue, writeTBQueue) readTBQueue, writeTBQueue)
import Control.Exception import Control.Exception
import Control.Monad (forM_, void, when) import Control.Monad (forM_, unless, void, when)
import Control.Monad.Extra (whileM) import Control.Monad.Extra (whileM)
import qualified Data.Bimap as BM import qualified Data.Bimap as BM
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
@ -104,6 +105,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader.Class (MonadReader, asks) import Control.Monad.Reader.Class (MonadReader, asks)
import Data.Int (Int64) import Data.Int (Int64)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Time.Clock (UTCTime, diffUTCTime, import Data.Time.Clock (UTCTime, diffUTCTime,
getCurrentTime) getCurrentTime)
import FSM (FSMCallback (..), import FSM (FSMCallback (..),
@ -141,6 +143,7 @@ data Env =
, brokerState :: BrokerState , brokerState :: BrokerState
, runVar :: TMVar () , runVar :: TMVar ()
, timerVar :: TMVar () , timerVar :: TMVar ()
, processedTrades :: TVar (S.Set Int64)
} }
data MainQueueData = data MainQueueData =
@ -297,19 +300,31 @@ handleTransaqData transaqData = do
trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState) trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState)
maybeCb <- liftIO $ readTVarIO (bsNotificationCallback brState) maybeCb <- liftIO $ readTVarIO (bsNotificationCallback brState)
orderMap <- liftIO $ readTVarIO (bsOrderMap brState) orderMap <- liftIO $ readTVarIO (bsOrderMap brState)
case maybeCb of isAlreadyProcessed <- checkIfTradeIsAlreadyProcessed transaqTrade
Just cb -> case BM.lookupR (ExchangeOrderId (tOrderNo transaqTrade)) trIdMap of unless isAlreadyProcessed $
Just oid -> case M.lookup oid orderMap of case maybeCb of
Just order -> do Just cb -> case BM.lookupR (ExchangeOrderId (tOrderNo transaqTrade)) trIdMap of
tisH <- asks tisHandle Just oid -> case M.lookup oid orderMap of
let tickerId' = tBoard transaqTrade <> "#" <> tSecCode transaqTrade Just order -> do
maybeTickerInfo <- liftIO $ getTickerInfo tickerId' tisH tisH <- asks tisHandle
let notif = BackendTradeNotification (fromTransaqTrade transaqTrade order maybeTickerInfo) let tickerId' = tBoard transaqTrade <> "#" <> tSecCode transaqTrade
log Debug "TXMLConnector.WorkThread" $ "Sending trade notification: " <> (T.pack . show) notif maybeTickerInfo <- liftIO $ getTickerInfo tickerId' tisH
liftIO $ cb notif let notif = BackendTradeNotification (fromTransaqTrade transaqTrade order maybeTickerInfo)
_ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order for trade: " <> (T.pack . show) transaqTrade log Debug "TXMLConnector.WorkThread" $ "Sending trade notification: " <> (T.pack . show) notif
_ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order in ordermap: " <> (T.pack . show) transaqTrade liftIO $ cb notif
Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for trade notification!" addTradeToProcessed transaqTrade
_ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order for trade: " <> (T.pack . show) transaqTrade
_ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order in ordermap: " <> (T.pack . show) transaqTrade
Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for trade notification!"
checkIfTradeIsAlreadyProcessed trade = do
trades <- asks processedTrades
set <- liftIO $ readTVarIO trades
pure $ S.member (tTradeNo trade) set
addTradeToProcessed trade = do
trades <- asks processedTrades
liftIO $ atomically $ modifyTVar' trades (S.insert $ tTradeNo trade)
fromTransaqTrade :: TradeNotification -> Order -> Maybe TickerInfo -> Trade fromTransaqTrade :: TradeNotification -> Order -> Maybe TickerInfo -> Trade

11
src/TickerInfoServer.hs
Unescape View File

@ -14,7 +14,7 @@ module TickerInfoServer
import ATrade.Logging (Message, import ATrade.Logging (Message,
Severity (Debug, Warning), Severity (Debug, Warning),
logWith) logWith)
import ATrade.Types (Tick, TickerId, security) import ATrade.Types (TickerId)
import Colog (LogAction) import Colog (LogAction)
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import Control.Concurrent.STM (TVar, atomically, newTVarIO, import Control.Concurrent.STM (TVar, atomically, newTVarIO,
@ -23,20 +23,19 @@ import Control.Concurrent.STM.TVar (modifyTVar', writeTVar)
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad.Extra (whileM) import Control.Monad.Extra (whileM)
import Data.Aeson (FromJSON (parseJSON), import Data.Aeson (FromJSON (parseJSON),
ToJSON (toJSON), decode, ToJSON (toJSON), eitherDecode,
eitherDecode, encode, object, encode, object, withObject)
withObject)
import Data.Aeson.Types ((.!=), (.:), (.:?), (.=)) import Data.Aeson.Types ((.!=), (.:), (.:?), (.=))
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (replace) import Data.Text.Encoding.Error (replace)
import Prelude hiding (log) import Prelude hiding (log)
import SlaveThread (fork) import SlaveThread (fork)
import System.ZMQ4 (Context, Router (Router), bind, import System.ZMQ4 (Context, Router (Router), bind,
connect, receiveMulti, sendMulti, receiveMulti, sendMulti,
withSocket) withSocket)
data TickerInfo = data TickerInfo =

52
src/Transaq.hs
Unescape View File

@ -1,6 +1,5 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
@ -76,36 +75,27 @@ module Transaq
import Barbies import Barbies
import Barbies.Bare import Barbies.Bare
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Error.Util (hush) import Control.Error.Util (hush)
import Control.Monad (void, when) import Control.Monad (void)
import Control.Monad.State (State (..), gets, modify) import Data.Attoparsec.Text (Parser, char, decimal, many', parseOnly,
import Control.Monad.State.Class (MonadState (..)) skipSpace)
import Data.Attoparsec.Text (Parser, char, decimal, many', import Data.Decimal (DecimalRaw (..))
maybeResult, parse, parseOnly, import Data.Functor.Identity (Identity (..))
skipSpace) import Data.Int (Int64)
import qualified Data.ByteString as BS import Data.Maybe (catMaybes, fromMaybe, mapMaybe,
import Data.ByteString.Char8 (readInteger) maybeToList)
import Data.Decimal (DecimalRaw (..)) import qualified Data.Text as T
import Data.Functor.Identity (Identity (..)) import Data.Time (fromGregorian)
import Data.Int (Int64) import Data.Time.Clock (UTCTime (UTCTime))
import Data.Maybe (catMaybes, fromMaybe, mapMaybe,
maybeToList)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time (fromGregorian)
import Data.Time.Clock (UTCTime (UTCTime))
import GHC.Generics import GHC.Generics
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Text.XML.Light (Attr (..), CData (cdData), import Text.XML.Light (Attr (..), CData (cdData),
Element (elName), Node (..), Element (elName), Node (..), QName (..),
QName (..), elChildren, findAttr, elChildren, findAttr, findChild,
findChild, onlyText, strContent, onlyText, strContent, unode)
unode) import Text.XML.Light.Output (showElement)
import Text.XML.Light.Output (showElement) import Text.XML.Light.Types (Element (elContent), blank_name)
import Text.XML.Light.Types (Element (elContent), blank_name)
import Xeno.SAX (Process (..))
data Language = LanguageRu | LanguageEn data Language = LanguageRu | LanguageEn
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -483,7 +473,7 @@ instance TransaqResponseC Element (ResponseCandlesB Bare f) where
} :: CandleB Bare f) } :: CandleB Bare f)
instance TransaqResponseC T.Text (ResponseCandlesB Bare f) where instance TransaqResponseC T.Text (ResponseCandlesB Bare f) where
fromXml txt = undefined fromXml _ = undefined
data ConnectionState = data ConnectionState =
Connected Connected

23
src/Transaq/Parsing.hs
Unescape View File

@ -1,12 +1,10 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -57,9 +55,8 @@ import GHC.Generics (Generic)
import Text.Megaparsec (MonadParsec (takeWhileP), import Text.Megaparsec (MonadParsec (takeWhileP),
Parsec (..), ParsecT, anySingle, Parsec (..), ParsecT, anySingle,
customFailure, lookAhead, oneOf, customFailure, lookAhead, oneOf,
parse, runParserT, satisfy, single, optional, parse, runParserT, satisfy,
try, unexpected, (<|>)) single, try, unexpected, (<|>))
import Text.Megaparsec (optional)
import qualified Text.Megaparsec.Error as ME import qualified Text.Megaparsec.Error as ME
import Text.Megaparsec.Stream (Stream (..)) import Text.Megaparsec.Stream (Stream (..))
import Text.Read (readMaybe) import Text.Read (readMaybe)
@ -444,7 +441,7 @@ parseTransaqResponses :: BS.ByteString -> [TransaqResponse]
parseTransaqResponses bs = parseTransaqResponses bs =
let stream = filter (not . isWhitespaceText) . reverse $ execState (unParsingContext $ process defaultProcess bs) [] in let stream = filter (not . isWhitespaceText) . reverse $ execState (unParsingContext $ process defaultProcess bs) [] in
case runST $ runParserT (many txmlParserWrapper) "" stream of case runST $ runParserT (many txmlParserWrapper) "" stream of
Left err -> [] Left _ -> []
Right result -> catMaybes result Right result -> catMaybes result
where where
txmlParserWrapper = (Just <$> txmlParser) <|> (skipTag >> pure Nothing) txmlParserWrapper = (Just <$> txmlParser) <|> (skipTag >> pure Nothing)
@ -495,15 +492,15 @@ txmlParser = do
parseResult refResult = do parseResult refResult = do
attr <- takeWhileP Nothing isAttr attr <- takeWhileP Nothing isAttr
mapM_ (parseResultAttr refResult) attr mapM_ (parseResultAttr refResult) attr
void . single $ (XmlOpenEnd "result") void . single $ XmlOpenEnd "result"
t <- anySingle t <- anySingle
case t of case t of
XmlOpen "message" -> do XmlOpen "message" -> do
_ <- takeWhileP Nothing isAttr _ <- takeWhileP Nothing isAttr
void . single $ (XmlOpenEnd "message") void . single $ XmlOpenEnd "message"
(XmlText txt) <- satisfy isText (XmlText txt) <- satisfy isText
void . single $ (XmlClose "message") void . single $ XmlClose "message"
void . single $ (XmlClose "result") void . single $ XmlClose "result"
return . TransaqResponseResult $ ResponseFailure txt return . TransaqResponseResult $ ResponseFailure txt
XmlClose "result" -> do XmlClose "result" -> do
maybeRes <- lift $ readSTRef refResult maybeRes <- lift $ readSTRef refResult
@ -515,9 +512,9 @@ txmlParser = do
parseResultAttr refResult (XmlAttr "success" "true") = lift $ writeSTRef refResult (Just $ ResponseSuccess Nothing) parseResultAttr refResult (XmlAttr "success" "true") = lift $ writeSTRef refResult (Just $ ResponseSuccess Nothing)
parseResultAttr refResult (XmlAttr "success" "false") = lift $ writeSTRef refResult (Just $ ResponseFailure "") parseResultAttr refResult (XmlAttr "success" "false") = lift $ writeSTRef refResult (Just $ ResponseFailure "")
parseResultAttr refResult attr@(XmlAttr "transactionid" trIdStr) = do parseResultAttr refResult attr@(XmlAttr "transactionid" trIdStr) = do
case (readMaybe (T.unpack trIdStr)) :: Maybe Int64 of case readMaybe (T.unpack trIdStr) :: Maybe Int64 of
t@(Just trId) -> lift $ writeSTRef refResult (Just $ ResponseSuccess t) t@(Just _) -> lift $ writeSTRef refResult (Just $ ResponseSuccess t)
Nothing -> unexpected $ ME.Tokens $ NE.singleton attr Nothing -> unexpected $ ME.Tokens $ NE.singleton attr
parseResultAttr _ _ = return () parseResultAttr _ _ = return ()
parseClient :: STRef s ClientDataPartial -> ParsecT String [XmlStreamEvent] (ST s) TransaqResponse parseClient :: STRef s ClientDataPartial -> ParsecT String [XmlStreamEvent] (ST s) TransaqResponse

6
transaq-connector.cabal
Unescape View File

@ -39,7 +39,7 @@ executable transaq-connector
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, dhall , dhall
, eventcounters , eventcounters
, libatrade == 0.16.0.0 , libatrade == 0.17.0.0
, text , text
, transformers , transformers
, co-log , co-log
@ -79,7 +79,7 @@ executable transaq-connector
-Wmissing-home-modules -Wmissing-home-modules
-Wpartial-fields -Wpartial-fields
-Wredundant-constraints -Wredundant-constraints
-threaded -rtsopts -with-rtsopts=-N -threaded -rtsopts
if os(windows) if os(windows)
extra-lib-dirs: lib extra-lib-dirs: lib
extra-libraries: txmlconnector64 extra-libraries: txmlconnector64
@ -162,7 +162,7 @@ benchmark parsing-benchmark
, criterion , criterion
, dhall , dhall
, eventcounters , eventcounters
, libatrade == 0.15.0.0 , libatrade == 0.17.0.0
, text , text
, transformers , transformers
, co-log , co-log

Write Preview
Loading…
Cancel
Save