From adfd804382640a1f70d4cdae42e5652d5afc29c6 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Tue, 4 Jun 2024 14:43:35 +0900 Subject: [PATCH 01/10] Add initial cqg-cms-api-client library --- cqg-cms-api-client/CHANGELOG.md | 11 ++++++ cqg-cms-api-client/LICENSE | 1 + cqg-cms-api-client/README.md | 1 + cqg-cms-api-client/Setup.hs | 2 + cqg-cms-api-client/cqg-cms-api-client.cabal | 33 +++++++++++++++++ cqg-cms-api-client/package.yaml | 41 +++++++++++++++++++++ cqg-cms-api-client/src/Lib.hs | 4 ++ stack.yaml | 1 + 8 files changed, 94 insertions(+) create mode 100644 cqg-cms-api-client/CHANGELOG.md create mode 100644 cqg-cms-api-client/LICENSE create mode 100644 cqg-cms-api-client/README.md create mode 100644 cqg-cms-api-client/Setup.hs create mode 100644 cqg-cms-api-client/cqg-cms-api-client.cabal create mode 100644 cqg-cms-api-client/package.yaml create mode 100644 cqg-cms-api-client/src/Lib.hs diff --git a/cqg-cms-api-client/CHANGELOG.md b/cqg-cms-api-client/CHANGELOG.md new file mode 100644 index 0000000..0f69729 --- /dev/null +++ b/cqg-cms-api-client/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `cqg-cms-api-client` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/cqg-cms-api-client/LICENSE b/cqg-cms-api-client/LICENSE new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/cqg-cms-api-client/LICENSE @@ -0,0 +1 @@ + diff --git a/cqg-cms-api-client/README.md b/cqg-cms-api-client/README.md new file mode 100644 index 0000000..20b78e8 --- /dev/null +++ b/cqg-cms-api-client/README.md @@ -0,0 +1 @@ +# cqg-cms-api-client diff --git a/cqg-cms-api-client/Setup.hs b/cqg-cms-api-client/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/cqg-cms-api-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cqg-cms-api-client/cqg-cms-api-client.cabal b/cqg-cms-api-client/cqg-cms-api-client.cabal new file mode 100644 index 0000000..ac1a4ad --- /dev/null +++ b/cqg-cms-api-client/cqg-cms-api-client.cabal @@ -0,0 +1,33 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: cqg-cms-api-client +version: 0.1.0.0 +synopsis: CQG CMS API websocket client +description: Please see the README on GitHub at +category: Web +author: Bitnomial +maintainer: Bitnomial +copyright: 2024 Bitnomial, Inc +license: AllRightsReserved +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +library + exposed-modules: + Lib + other-modules: + Paths_cqg_cms_api_client + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unused-do-bind -Wunused-packages -funbox-strict-fields -fwrite-ide-info + build-depends: + base >=4.7 && <5 + , cqg-cms-api-proto + default-language: Haskell2010 diff --git a/cqg-cms-api-client/package.yaml b/cqg-cms-api-client/package.yaml new file mode 100644 index 0000000..a6bf123 --- /dev/null +++ b/cqg-cms-api-client/package.yaml @@ -0,0 +1,41 @@ +name: "cqg-cms-api-client" +version: "0.1.0.0" +maintainer: "Bitnomial " +license: "AllRightsReserved" +author: "Bitnomial" +copyright: "2024 Bitnomial, Inc" + +extra-source-files: + - README.md + - CHANGELOG.md + - proto/**/*.proto + +synopsis: "CQG CMS API websocket client" +category: "Web" + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: "Please see the README on GitHub at " + +dependencies: + - base >= 4.7 && < 5 + - cqg-cms-api-proto + +ghc-options: + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wmissing-export-lists + - -Wmissing-home-modules + - -Wpartial-fields + - -Wredundant-constraints + - -Wno-unused-do-bind + - -Wunused-packages + - -funbox-strict-fields + - -fwrite-ide-info + +library: + source-dirs: src diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs new file mode 100644 index 0000000..40223c4 --- /dev/null +++ b/cqg-cms-api-client/src/Lib.hs @@ -0,0 +1,4 @@ + +module Lib () where + +import Proto.CMS.Cmsapi1 () diff --git a/stack.yaml b/stack.yaml index 0119dfa..447f4e4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,6 +15,7 @@ ghc-options: "$everything": -haddock packages: + - cqg-cms-api-client - cqg-cms-api-proto extra-deps: [] From c8a8d7dd57d8844b6fef1c098287966cd95102c8 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Wed, 5 Jun 2024 14:35:23 +0900 Subject: [PATCH 02/10] Add fourmolu.yaml file --- fourmolu.yaml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 fourmolu.yaml diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..f43fae7 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,24 @@ +indentation: 4 +comma-style: leading # for lists, tuples etc. - can also be 'trailing' +record-brace-space: false # rec {x = 1} vs. rec{x = 1} +indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword +import-export-style: diff-friendly # choices: leading, trailing, diff-friendly +respectful: true # don't be too opinionated about newlines etc. +haddock-style: single-line # '--' vs. '{-' +newlines-between-decls: 2 +single-constraint-parens: never # defaults to 'always', could also be 'auto' (ignore), and 'never' +single-deriving-parens: never # choices: auto, always, never +column-limit: 120 # limit columns to 120 characters, as per our style guide +let-style: inline # choices: auto, inline, newline, mixed +fixities: + - infixr 0 $, $! + - infixl 1 >>, >>=, & + - infixr 1 =<< + - infixl 3 , @?= + - infixl 4 <*>, <*, *>, <**>, <$ + - infixr 4 ?~ + - infixr 5 ++ + - infixr 5 :| + - infixr 6 <> + - infixl 8 .:, .:?, .=, .=? + - infixr 9 . From 6e5f2331bdce43371cfe620ef2001412f9b74cda Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Wed, 5 Jun 2024 15:44:31 +0900 Subject: [PATCH 03/10] Add hie.yaml --- hie.yaml | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..d6e4632 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,11 @@ +--- +cradle: + stack: + - component: "cqg-cms-api-client:exe:cqg-cms-example" + path: "./cqg-cms-api-client/app/cqg-cms-example" + + - component: "cqg-cms-api-client:lib" + path: "./cqg-cms-api-client/src" + + - component: "cqg-cms-api-proto:lib" + path: "./cqg-cms-api-proto/src" From d2ac16ff312b07a3e692012bd44d0bea4a5cd7cd Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Wed, 5 Jun 2024 15:44:44 +0900 Subject: [PATCH 04/10] wip --- .../app/cqg-cms-example/Main.hs | 48 +++++++++++++++ cqg-cms-api-client/cqg-cms-api-client.cabal | 17 ++++++ cqg-cms-api-client/package.yaml | 58 +++++++++++-------- 3 files changed, 100 insertions(+), 23 deletions(-) create mode 100644 cqg-cms-api-client/app/cqg-cms-example/Main.hs diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs new file mode 100644 index 0000000..c47a435 --- /dev/null +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -0,0 +1,48 @@ + +module Main where + +import Lib + +import Wuss + + +-- | Get a 'String' environment variable. +getEnv :: + -- | Environment variable to lookup + String -> + -- | Default value to use if the environment variable is not set. + String -> + IO String +getEnv envVar defVal = fromMaybe defVal <$> lookupEnv envVar + + +-- | Similar to 'getEnv', but read in a value with 'read'. +-- +-- Throws an exception if the environment variable is set, but the value can't be 'read'. +getFromEnv :: + Read a => + -- | Environment variable to lookup + String -> + -- | Default value to use if the environment variable is not set. + a -> + IO a +getFromEnv envVar defVal = do + maybeRes <- lookupEnv envVar + case maybeRes of + Nothing -> pure defVal + Just strRes -> do + case readMay strRes of + Nothing -> + error $ "Can't read environment variable " <> envVar <> " value: " <> strRes + Just res -> pure res + + +main :: IO () +main = do + hostname <- getEnv "CQG_WEBSOCKETS_HOSTNAME" "democmsapi.cqg.com" + port <- getFromEnv "CQG_WEBSOCKETS_PORT" 443 + path <- getEnv "CQG_WEBSOCKETS_PATH" "/" + runSecureClient hostname port path app + +app :: IO () +app = undefined diff --git a/cqg-cms-api-client/cqg-cms-api-client.cabal b/cqg-cms-api-client/cqg-cms-api-client.cabal index ac1a4ad..a0b2e57 100644 --- a/cqg-cms-api-client/cqg-cms-api-client.cabal +++ b/cqg-cms-api-client/cqg-cms-api-client.cabal @@ -30,4 +30,21 @@ library build-depends: base >=4.7 && <5 , cqg-cms-api-proto + , websockets + , wuss + default-language: Haskell2010 + +executable cqg-cms-example + main-is: Main.hs + other-modules: + Paths_cqg_cms_api_client + hs-source-dirs: + app/cqg-cms-example + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unused-do-bind -Wunused-packages -funbox-strict-fields -fwrite-ide-info -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , cqg-cms-api-client + , cqg-cms-api-proto + , websockets + , wuss default-language: Haskell2010 diff --git a/cqg-cms-api-client/package.yaml b/cqg-cms-api-client/package.yaml index a6bf123..ddfa9e8 100644 --- a/cqg-cms-api-client/package.yaml +++ b/cqg-cms-api-client/package.yaml @@ -1,41 +1,53 @@ -name: "cqg-cms-api-client" -version: "0.1.0.0" -maintainer: "Bitnomial " -license: "AllRightsReserved" -author: "Bitnomial" -copyright: "2024 Bitnomial, Inc" +name: "cqg-cms-api-client" +version: "0.1.0.0" +maintainer: "Bitnomial " +license: "AllRightsReserved" +author: "Bitnomial" +copyright: "2024 Bitnomial, Inc" extra-source-files: - README.md - CHANGELOG.md - - proto/**/*.proto -synopsis: "CQG CMS API websocket client" -category: "Web" +synopsis: "CQG CMS API websocket client" +category: "Web" # To avoid duplicated efforts in documentation and dealing with the # complications of embedding Haddock markup inside cabal files, it is # common to point users to the README.md file. -description: "Please see the README on GitHub at " +description: "Please see the README on GitHub at " dependencies: - base >= 4.7 && < 5 - cqg-cms-api-proto + - websockets + - wuss ghc-options: - - -Wall - - -Wcompat - - -Widentities - - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - - -Wmissing-export-lists - - -Wmissing-home-modules - - -Wpartial-fields - - -Wredundant-constraints - - -Wno-unused-do-bind - - -Wunused-packages - - -funbox-strict-fields - - -fwrite-ide-info + - "-Wall" + - "-Wcompat" + - "-Widentities" + - "-Wincomplete-record-updates" + - "-Wincomplete-uni-patterns" + - "-Wmissing-export-lists" + - "-Wmissing-home-modules" + - "-Wpartial-fields" + - "-Wredundant-constraints" + - "-Wno-unused-do-bind" + - "-Wunused-packages" + - "-funbox-strict-fields" + - "-fwrite-ide-info" library: source-dirs: src + +executables: + cqg-cms-example: + main: "Main.hs" + source-dirs: "app/cqg-cms-example" + ghc-options: + - "-threaded" + - "-rtsopts" + - "-with-rtsopts=-N" + dependencies: + - cqg-cms-api-client From 8f3bd0346bdb8ad340c4d945032b4f85ff7c2344 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Wed, 5 Jun 2024 17:17:06 +0900 Subject: [PATCH 05/10] wip --- cqg-cms-api-client/app/cqg-cms-example/Main.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index c47a435..067e06a 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -1,9 +1,12 @@ -module Main where +module Main (main) where -import Lib - -import Wuss +import Data.Maybe (fromMaybe) +import Lib () +import Network.WebSockets (Connection) +import System.Environment (lookupEnv) +import Text.Read (readMaybe) +import Wuss (runSecureClient) -- | Get a 'String' environment variable. @@ -31,7 +34,7 @@ getFromEnv envVar defVal = do case maybeRes of Nothing -> pure defVal Just strRes -> do - case readMay strRes of + case readMaybe strRes of Nothing -> error $ "Can't read environment variable " <> envVar <> " value: " <> strRes Just res -> pure res @@ -44,5 +47,5 @@ main = do path <- getEnv "CQG_WEBSOCKETS_PATH" "/" runSecureClient hostname port path app -app :: IO () +app :: Connection -> IO () app = undefined From 76ad098d07039069c1a25990e31ef5ea0138200f Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Thu, 6 Jun 2024 21:21:55 +0900 Subject: [PATCH 06/10] wip --- .../app/cqg-cms-example/Main.hs | 45 +++++++++++++------ cqg-cms-api-client/cqg-cms-api-client.cabal | 10 +++-- cqg-cms-api-client/package.yaml | 17 ++++--- cqg-cms-api-client/src/Lib.hs | 29 +++++++++++- 4 files changed, 77 insertions(+), 24 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index 067e06a..5c224d9 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -2,34 +2,36 @@ module Main (main) where import Data.Maybe (fromMaybe) -import Lib () +import Data.String (IsString, fromString) +import Data.Text (Text) +import Lib import Network.WebSockets (Connection) -import System.Environment (lookupEnv) +import System.Environment (getEnv, lookupEnv) import Text.Read (readMaybe) import Wuss (runSecureClient) -- | Get a 'String' environment variable. -getEnv :: +getEnvDef :: -- | Environment variable to lookup String -> -- | Default value to use if the environment variable is not set. String -> IO String -getEnv envVar defVal = fromMaybe defVal <$> lookupEnv envVar +getEnvDef envVar defVal = fromMaybe defVal <$> lookupEnv envVar --- | Similar to 'getEnv', but read in a value with 'read'. +-- | Similar to 'getEnvDef', but read in a value with 'read'. -- -- Throws an exception if the environment variable is set, but the value can't be 'read'. -getFromEnv :: +readEnvDef :: Read a => -- | Environment variable to lookup String -> -- | Default value to use if the environment variable is not set. a -> IO a -getFromEnv envVar defVal = do +readEnvDef envVar defVal = do maybeRes <- lookupEnv envVar case maybeRes of Nothing -> pure defVal @@ -40,12 +42,29 @@ getFromEnv envVar defVal = do Just res -> pure res +getEnvStr :: IsString s => String -> IO s +getEnvStr envVar = fromString <$> getEnv envVar + + main :: IO () main = do - hostname <- getEnv "CQG_WEBSOCKETS_HOSTNAME" "democmsapi.cqg.com" - port <- getFromEnv "CQG_WEBSOCKETS_PORT" 443 - path <- getEnv "CQG_WEBSOCKETS_PATH" "/" - runSecureClient hostname port path app + cqgHostname <- getEnvDef "CQG_WEBSOCKETS_HOSTNAME" "democmsapi.cqg.com" + cqgPort <- readEnvDef "CQG_WEBSOCKETS_PORT" 443 + cqgPath <- getEnvDef "CQG_WEBSOCKETS_PATH" "/" + cqgUsername <- getEnvStr "CQG_USERNAME" + cqgPassword <- getEnvStr "CQG_PASSWORD" + cqgClientAppId <- getEnvStr "CQG_CLIENT_APP_ID" + runSecureClient cqgHostname cqgPort cqgPath (app cqgUsername cqgPassword cqgClientAppId) -app :: Connection -> IO () -app = undefined +app :: + -- | CQG Username + Text -> + -- | CQG Password + Text -> + -- | CQG Client App ID + Text -> + Connection -> + IO () +app cqgUsername cqgPassword cqgClientAppId conn = do + logon cqgUsername cqgPassword cqgClientAppId conn + diff --git a/cqg-cms-api-client/cqg-cms-api-client.cabal b/cqg-cms-api-client/cqg-cms-api-client.cabal index a0b2e57..70b5b74 100644 --- a/cqg-cms-api-client/cqg-cms-api-client.cabal +++ b/cqg-cms-api-client/cqg-cms-api-client.cabal @@ -28,10 +28,12 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unused-do-bind -Wunused-packages -funbox-strict-fields -fwrite-ide-info build-depends: - base >=4.7 && <5 + base , cqg-cms-api-proto + , microlens + , proto-lens + , text , websockets - , wuss default-language: Haskell2010 executable cqg-cms-example @@ -42,9 +44,9 @@ executable cqg-cms-example app/cqg-cms-example ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unused-do-bind -Wunused-packages -funbox-strict-fields -fwrite-ide-info -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + base , cqg-cms-api-client - , cqg-cms-api-proto + , text , websockets , wuss default-language: Haskell2010 diff --git a/cqg-cms-api-client/package.yaml b/cqg-cms-api-client/package.yaml index ddfa9e8..ffcf728 100644 --- a/cqg-cms-api-client/package.yaml +++ b/cqg-cms-api-client/package.yaml @@ -17,12 +17,6 @@ category: "Web" # common to point users to the README.md file. description: "Please see the README on GitHub at " -dependencies: - - base >= 4.7 && < 5 - - cqg-cms-api-proto - - websockets - - wuss - ghc-options: - "-Wall" - "-Wcompat" @@ -40,6 +34,13 @@ ghc-options: library: source-dirs: src + dependencies: + - base + - cqg-cms-api-proto + - microlens + - proto-lens + - text + - websockets executables: cqg-cms-example: @@ -50,4 +51,8 @@ executables: - "-rtsopts" - "-with-rtsopts=-N" dependencies: + - base - cqg-cms-api-client + - text + - websockets + - wuss diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs index 40223c4..5f9e98e 100644 --- a/cqg-cms-api-client/src/Lib.hs +++ b/cqg-cms-api-client/src/Lib.hs @@ -1,4 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} -module Lib () where +module Lib (logon) where +import Data.Function ((&)) +import Data.ProtoLens (defMessage) +import Data.ProtoLens.Field (field) +import Data.Text (Text) +import Lens.Micro ((.~)) +import Network.WebSockets (Connection) import Proto.CMS.Cmsapi1 () +import Proto.CMS.Common1 (Logon) + +logon :: + -- | CQG Username + Text -> + -- | CQG Password + Text -> + -- | CQG Client App ID + Text -> + Connection -> + IO () +logon cqgUsername cqgPassword cqgClientAppId conn = do + print logonMsg + where + logonMsg = + defMessage @Logon & + field @"userName" .~ cqgUsername & + field @"password" .~ cqgPassword & + field @"clientAppId" .~ cqgClientAppId From 96ae9a965c05b41fb6a9fa1791539844524ec338 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Thu, 6 Jun 2024 22:04:44 +0900 Subject: [PATCH 07/10] get logon working --- .../app/cqg-cms-example/Main.hs | 1 - cqg-cms-api-client/src/Lib.hs | 26 ++++++++++++++++--- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index 5c224d9..a7a064f 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -67,4 +67,3 @@ app :: IO () app cqgUsername cqgPassword cqgClientAppId conn = do logon cqgUsername cqgPassword cqgClientAppId conn - diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs index 5f9e98e..c2b7257 100644 --- a/cqg-cms-api-client/src/Lib.hs +++ b/cqg-cms-api-client/src/Lib.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} module Lib (logon) where import Data.Function ((&)) -import Data.ProtoLens (defMessage) +import Data.ProtoLens (defMessage, encodeMessage, decodeMessage) import Data.ProtoLens.Field (field) import Data.Text (Text) import Lens.Micro ((.~)) -import Network.WebSockets (Connection) -import Proto.CMS.Cmsapi1 () +import Network.WebSockets (Connection, sendBinaryData, receiveData) +import Proto.CMS.Cmsapi1 (ServerMessage, ClientMessage, ProtocolVersion (..)) import Proto.CMS.Common1 (Logon) logon :: @@ -23,9 +24,26 @@ logon :: IO () logon cqgUsername cqgPassword cqgClientAppId conn = do print logonMsg + sendBinaryData conn rawClientMsg + rawResp <- receiveData conn + print (decodeMessage rawResp :: Either String ServerMessage) where + clientMsg = defMessage @ClientMessage & field @"logon" .~ logonMsg + + rawClientMsg = encodeMessage clientMsg + logonMsg = defMessage @Logon & field @"userName" .~ cqgUsername & field @"password" .~ cqgPassword & - field @"clientAppId" .~ cqgClientAppId + field @"clientAppId" .~ cqgClientAppId & + field @"protocolVersionMajor" .~ fromIntegral (fromEnum PROTOCOL_VERSION_MAJOR) & + field @"protocolVersionMinor" .~ fromIntegral (fromEnum PROTOCOL_VERSION_MINOR) + + -- handleRawResp :: Message -> IO () + -- handleRawResp = \case + -- ControlMessage ctrlMsg -> print ctrlMsg + -- DataMessage _ _ _ dmsg -> + -- let dmsg = + -- case dmsg of + From dc7e9eb5c07576a03b13fc42929861bef7caff9e Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Fri, 7 Jun 2024 15:54:49 +0900 Subject: [PATCH 08/10] error handling for logon --- .../app/cqg-cms-example/Main.hs | 3 +- cqg-cms-api-client/src/Lib.hs | 32 +++++++++++++++---- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index a7a064f..3197605 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -66,4 +66,5 @@ app :: Connection -> IO () app cqgUsername cqgPassword cqgClientAppId conn = do - logon cqgUsername cqgPassword cqgClientAppId conn + x <- logon cqgUsername cqgPassword cqgClientAppId conn + print x diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs index c2b7257..33896c8 100644 --- a/cqg-cms-api-client/src/Lib.hs +++ b/cqg-cms-api-client/src/Lib.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE LambdaCase #-} module Lib (logon) where @@ -8,10 +7,19 @@ import Data.Function ((&)) import Data.ProtoLens (defMessage, encodeMessage, decodeMessage) import Data.ProtoLens.Field (field) import Data.Text (Text) -import Lens.Micro ((.~)) +import Lens.Micro ((.~), (^?), (^.)) import Network.WebSockets (Connection, sendBinaryData, receiveData) import Proto.CMS.Cmsapi1 (ServerMessage, ClientMessage, ProtocolVersion (..)) -import Proto.CMS.Common1 (Logon) +import Proto.CMS.Common1 (Logon, OperationStatus (SUCCESS)) + + +data CMSError = UnexpectedResponseType | OperationStatusFailure | ResponseNotDecodable String + deriving Show + + +fromProtoEnum :: (Enum m, Num n) => m -> n +fromProtoEnum protoEnumVal = fromIntegral $ fromEnum protoEnumVal + logon :: -- | CQG Username @@ -21,12 +29,22 @@ logon :: -- | CQG Client App ID Text -> Connection -> - IO () + IO (Either CMSError ()) logon cqgUsername cqgPassword cqgClientAppId conn = do print logonMsg sendBinaryData conn rawClientMsg rawResp <- receiveData conn - print (decodeMessage rawResp :: Either String ServerMessage) + let eitherServerMsg = decodeMessage rawResp :: Either String ServerMessage + print eitherServerMsg + case eitherServerMsg of + Left err -> pure . Left $ ResponseNotDecodable err + Right serverMsg -> + case serverMsg ^? field @"maybe'logonResult" . traverse of + Nothing -> pure $ Left UnexpectedResponseType + Just logonRes -> + if (logonRes ^. field @"operationStatus") /= fromProtoEnum SUCCESS + then pure $ Left OperationStatusFailure + else pure $ Right () where clientMsg = defMessage @ClientMessage & field @"logon" .~ logonMsg @@ -37,8 +55,8 @@ logon cqgUsername cqgPassword cqgClientAppId conn = do field @"userName" .~ cqgUsername & field @"password" .~ cqgPassword & field @"clientAppId" .~ cqgClientAppId & - field @"protocolVersionMajor" .~ fromIntegral (fromEnum PROTOCOL_VERSION_MAJOR) & - field @"protocolVersionMinor" .~ fromIntegral (fromEnum PROTOCOL_VERSION_MINOR) + field @"protocolVersionMajor" .~ fromProtoEnum PROTOCOL_VERSION_MAJOR & + field @"protocolVersionMinor" .~ fromProtoEnum PROTOCOL_VERSION_MINOR -- handleRawResp :: Message -> IO () -- handleRawResp = \case From ab41169e3471c01d8c980d75ac21a7c1a3a4b085 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Fri, 7 Jun 2024 20:08:45 +0900 Subject: [PATCH 09/10] Implement get balances --- .../app/cqg-cms-example/Main.hs | 8 +- cqg-cms-api-client/src/Lib.hs | 98 ++++++++++++++----- 2 files changed, 79 insertions(+), 27 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index 3197605..132fa62 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -4,7 +4,7 @@ module Main (main) where import Data.Maybe (fromMaybe) import Data.String (IsString, fromString) import Data.Text (Text) -import Lib +import Lib (logon, getBalancesForAccount) import Network.WebSockets (Connection) import System.Environment (getEnv, lookupEnv) import Text.Read (readMaybe) @@ -66,5 +66,7 @@ app :: Connection -> IO () app cqgUsername cqgPassword cqgClientAppId conn = do - x <- logon cqgUsername cqgPassword cqgClientAppId conn - print x + eitherLogonRes <- logon cqgUsername cqgPassword cqgClientAppId conn + print eitherLogonRes + eitherBalances <- getBalancesForAccount {- TODO: how to find this value -} 17028979 conn + print eitherBalances diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs index 33896c8..96e502c 100644 --- a/cqg-cms-api-client/src/Lib.hs +++ b/cqg-cms-api-client/src/Lib.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -module Lib (logon) where +module Lib (logon, getBalancesForAccount) where import Data.Function ((&)) import Data.ProtoLens (defMessage, encodeMessage, decodeMessage) @@ -11,9 +11,10 @@ import Lens.Micro ((.~), (^?), (^.)) import Network.WebSockets (Connection, sendBinaryData, receiveData) import Proto.CMS.Cmsapi1 (ServerMessage, ClientMessage, ProtocolVersion (..)) import Proto.CMS.Common1 (Logon, OperationStatus (SUCCESS)) +import Proto.CMS.Traderouting1 (TradeRoutingRequest, AccountScopeRequest, BalanceRecordsRequest, BalanceRecord) -data CMSError = UnexpectedResponseType | OperationStatusFailure | ResponseNotDecodable String +data CMSError = UnexpectedResponseType | UnexpectedNumOfResponses | OperationStatusFailure | ResponseNotDecodable String deriving Show @@ -31,11 +32,11 @@ logon :: Connection -> IO (Either CMSError ()) logon cqgUsername cqgPassword cqgClientAppId conn = do - print logonMsg + -- print logonMsg sendBinaryData conn rawClientMsg rawResp <- receiveData conn let eitherServerMsg = decodeMessage rawResp :: Either String ServerMessage - print eitherServerMsg + -- print eitherServerMsg case eitherServerMsg of Left err -> pure . Left $ ResponseNotDecodable err Right serverMsg -> @@ -45,23 +46,72 @@ logon cqgUsername cqgPassword cqgClientAppId conn = do if (logonRes ^. field @"operationStatus") /= fromProtoEnum SUCCESS then pure $ Left OperationStatusFailure else pure $ Right () - where - clientMsg = defMessage @ClientMessage & field @"logon" .~ logonMsg - - rawClientMsg = encodeMessage clientMsg - - logonMsg = - defMessage @Logon & - field @"userName" .~ cqgUsername & - field @"password" .~ cqgPassword & - field @"clientAppId" .~ cqgClientAppId & - field @"protocolVersionMajor" .~ fromProtoEnum PROTOCOL_VERSION_MAJOR & - field @"protocolVersionMinor" .~ fromProtoEnum PROTOCOL_VERSION_MINOR - - -- handleRawResp :: Message -> IO () - -- handleRawResp = \case - -- ControlMessage ctrlMsg -> print ctrlMsg - -- DataMessage _ _ _ dmsg -> - -- let dmsg = - -- case dmsg of - + where + clientMsg = defMessage @ClientMessage & field @"logon" .~ logonMsg + + rawClientMsg = encodeMessage clientMsg + + logonMsg = + defMessage @Logon & + field @"userName" .~ cqgUsername & + field @"password" .~ cqgPassword & + field @"clientAppId" .~ cqgClientAppId & + field @"protocolVersionMajor" .~ fromProtoEnum PROTOCOL_VERSION_MAJOR & + field @"protocolVersionMinor" .~ fromProtoEnum PROTOCOL_VERSION_MINOR + + +data Balance = Balance + { balanceId :: Int + , balanceCurrency :: Text + , balanceEndCashBalance :: Double + } + deriving Show + +getBalancesForAccount :: + -- | CQG Account ID + Int -> + Connection -> + IO (Either CMSError [Balance]) +getBalancesForAccount cqgAccountId conn = do + print clientMsg + sendBinaryData conn rawClientMsg + rawResp <- receiveData conn + let eitherServerMsg = decodeMessage rawResp :: Either String ServerMessage + print eitherServerMsg + case eitherServerMsg of + Left err -> pure . Left $ ResponseNotDecodable err + Right serverMsg -> + case serverMsg ^. field @"tradeRoutingResult" of + [] -> pure $ Left UnexpectedNumOfResponses + _ : _ : _ -> pure $ Left UnexpectedNumOfResponses + [tradingRouteRes] -> do + if (tradingRouteRes ^. field @"operationStatus") /= fromProtoEnum SUCCESS + then pure $ Left OperationStatusFailure + else do + let balanceRecords = tradingRouteRes ^. field @"accountScopeResult" . field @"balanceRecordsResult" . field @"balanceRecord" + pure . Right $ fmap toBalance balanceRecords + where + clientMsg = defMessage @ClientMessage & field @"tradeRoutingRequest" .~ [tradeRoutingRequestMsg] + + rawClientMsg = encodeMessage clientMsg + + tradeRoutingRequestMsg = + defMessage @TradeRoutingRequest & + field @"id" .~ 1234 {- TODO -} & + field @"accountScopeRequest" .~ accountScopeRequestMsg + + accountScopeRequestMsg = + defMessage @AccountScopeRequest & + field @"balanceRecordsRequest" .~ balanceRecordsRequestMsg + + balanceRecordsRequestMsg = + defMessage @BalanceRecordsRequest & + field @"accountId" .~ fromIntegral cqgAccountId + + toBalance :: BalanceRecord -> Balance + toBalance br = + Balance + { balanceId = fromIntegral $ br ^. field @"balanceRecordId" + , balanceCurrency = br ^. field @"currency" + , balanceEndCashBalance = br ^. field @"endCashBalance" + } From 69e5f3cb24e7a9f4c86165e0ae20adbb44454003 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Fri, 7 Jun 2024 20:34:21 +0900 Subject: [PATCH 10/10] Implement updating balances --- .../app/cqg-cms-example/Main.hs | 22 +++++- cqg-cms-api-client/src/Lib.hs | 67 +++++++++++++++++-- 2 files changed, 79 insertions(+), 10 deletions(-) diff --git a/cqg-cms-api-client/app/cqg-cms-example/Main.hs b/cqg-cms-api-client/app/cqg-cms-example/Main.hs index 132fa62..76638d1 100644 --- a/cqg-cms-api-client/app/cqg-cms-example/Main.hs +++ b/cqg-cms-api-client/app/cqg-cms-example/Main.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE NamedFieldPuns #-} module Main (main) where import Data.Maybe (fromMaybe) import Data.String (IsString, fromString) import Data.Text (Text) -import Lib (logon, getBalancesForAccount) +import Lib (Balance (..), logon, getBalancesForAccount, updateBalance) import Network.WebSockets (Connection) import System.Environment (getEnv, lookupEnv) import Text.Read (readMaybe) @@ -66,7 +67,22 @@ app :: Connection -> IO () app cqgUsername cqgPassword cqgClientAppId conn = do + putStrLn "DO logon" eitherLogonRes <- logon cqgUsername cqgPassword cqgClientAppId conn print eitherLogonRes - eitherBalances <- getBalancesForAccount {- TODO: how to find this value -} 17028979 conn - print eitherBalances + case eitherLogonRes of + Left err -> error $ "Error when logging on: " <> show err + Right () -> do + putStrLn "\nDO get balances" + let accountId = 17028979 {- TODO: how to find this value -} + eitherBalances <- getBalancesForAccount accountId conn + print eitherBalances + case eitherBalances of + Left err -> error $ "Error when getting balances: " <> show err + Right [] -> error "No balances returned! Expecting exactly one balance to be returned!" + Right (_ : _ : _) -> error "Multiple balances returned! Expecting exactly one balance to be returned!" + Right [Balance{balanceId}] -> do + putStrLn "\nDO update balance" + let newBalance = 1999 + eitherUpdateBalance <- updateBalance balanceId newBalance conn + print eitherUpdateBalance diff --git a/cqg-cms-api-client/src/Lib.hs b/cqg-cms-api-client/src/Lib.hs index 96e502c..6052ba4 100644 --- a/cqg-cms-api-client/src/Lib.hs +++ b/cqg-cms-api-client/src/Lib.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -module Lib (logon, getBalancesForAccount) where +module Lib (logon, getBalancesForAccount, updateBalance, Balance(..)) where import Data.Function ((&)) import Data.ProtoLens (defMessage, encodeMessage, decodeMessage) @@ -11,10 +11,10 @@ import Lens.Micro ((.~), (^?), (^.)) import Network.WebSockets (Connection, sendBinaryData, receiveData) import Proto.CMS.Cmsapi1 (ServerMessage, ClientMessage, ProtocolVersion (..)) import Proto.CMS.Common1 (Logon, OperationStatus (SUCCESS)) -import Proto.CMS.Traderouting1 (TradeRoutingRequest, AccountScopeRequest, BalanceRecordsRequest, BalanceRecord) +import Proto.CMS.Traderouting1 (TradeRoutingRequest, AccountScopeRequest, BalanceRecordsRequest, BalanceRecord, UpdateBalanceRecord) -data CMSError = UnexpectedResponseType | UnexpectedNumOfResponses | OperationStatusFailure | ResponseNotDecodable String +data CMSError = UnexpectedResponseType | UnexpectedNumOfResponses | OperationStatusFailure | ResponseNotDecodable String | UnexpectedResponseId deriving Show @@ -87,17 +87,22 @@ getBalancesForAccount cqgAccountId conn = do [tradingRouteRes] -> do if (tradingRouteRes ^. field @"operationStatus") /= fromProtoEnum SUCCESS then pure $ Left OperationStatusFailure - else do - let balanceRecords = tradingRouteRes ^. field @"accountScopeResult" . field @"balanceRecordsResult" . field @"balanceRecord" - pure . Right $ fmap toBalance balanceRecords + else + if (tradingRouteRes ^. field @"requestId") /= requestId + then pure $ Left UnexpectedResponseId + else do + let balanceRecords = tradingRouteRes ^. field @"accountScopeResult" . field @"balanceRecordsResult" . field @"balanceRecord" + pure . Right $ fmap toBalance balanceRecords where + requestId = 1234 -- TODO: don't hardcode this + clientMsg = defMessage @ClientMessage & field @"tradeRoutingRequest" .~ [tradeRoutingRequestMsg] rawClientMsg = encodeMessage clientMsg tradeRoutingRequestMsg = defMessage @TradeRoutingRequest & - field @"id" .~ 1234 {- TODO -} & + field @"id" .~ requestId & field @"accountScopeRequest" .~ accountScopeRequestMsg accountScopeRequestMsg = @@ -115,3 +120,51 @@ getBalancesForAccount cqgAccountId conn = do , balanceCurrency = br ^. field @"currency" , balanceEndCashBalance = br ^. field @"endCashBalance" } + + +updateBalance :: + -- | CQG Balance ID + Int -> + -- | new balance amount + Double -> + Connection -> + IO (Either CMSError ()) +updateBalance cqgBalanceId newEndCashBalance conn = do + print clientMsg + sendBinaryData conn rawClientMsg + rawResp <- receiveData conn + let eitherServerMsg = decodeMessage rawResp :: Either String ServerMessage + print eitherServerMsg + case eitherServerMsg of + Left err -> pure . Left $ ResponseNotDecodable err + Right serverMsg -> + case serverMsg ^. field @"tradeRoutingResult" of + [] -> pure $ Left UnexpectedNumOfResponses + _ : _ : _ -> pure $ Left UnexpectedNumOfResponses + [tradingRouteRes] -> do + if (tradingRouteRes ^. field @"operationStatus") /= fromProtoEnum SUCCESS + then pure $ Left OperationStatusFailure + else + if (tradingRouteRes ^. field @"requestId") /= requestId + then pure $ Left UnexpectedResponseId + else pure $ Right () + where + requestId = 1235 -- TODO: don't hardcode this + + clientMsg = defMessage @ClientMessage & field @"tradeRoutingRequest" .~ [tradeRoutingRequestMsg] + + rawClientMsg = encodeMessage clientMsg + + tradeRoutingRequestMsg = + defMessage @TradeRoutingRequest & + field @"id" .~ requestId & + field @"accountScopeRequest" .~ accountScopeRequestMsg + + accountScopeRequestMsg = + defMessage @AccountScopeRequest & + field @"updateBalanceRecord" .~ updateBalanceRecordMsg + + updateBalanceRecordMsg = + defMessage @UpdateBalanceRecord & + field @"balanceId" .~ fromIntegral cqgBalanceId & + field @"endCashBalance" .~ newEndCashBalance