Initial commit

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1 @@
+# atradebot

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

atradebot.cabal

@@ -0,0 +1,35 @@
+name:                atradebot
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/githubuser/atradebot#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Denis Tershkin
+maintainer:          denis@kasan.ws
+copyright:           2018 Denis Tereshkin
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+executable atradebot
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  other-modules:       Config
+                     , Bot  
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , pontarius-xmpp
+                     , libatrade
+                     , aeson
+                     , text
+                     , xml-types
+                     , containers
+                     , data-default
+                     , zeromq4-haskell
+                     , network
+                     , bytestring
+                     , hslogger
+                     , th-printf
+                     , BoundedChan

src/Bot.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Bot
+  (
+    startBot
+  )
+  where
+
+import           ATrade.Broker.Protocol
+import           ATrade.QuoteSource.Client
+import           ATrade.Types
+import           Config
+import           Control.Concurrent
+import qualified Control.Concurrent.BoundedChan as BC
+import           Control.Exception
+import           Control.Monad
+import           Data.Aeson
+import qualified Data.ByteString.Lazy           as BL
+import           Data.Default
+import           Data.IORef
+import qualified Data.List                      as L
+import qualified Data.Map.Strict                as M
+import           Data.Text                      (isPrefixOf, stripPrefix)
+import qualified Data.Text                      as T
+import           Data.Text.Encoding
+import           Data.XML.Types
+import           Network.Xmpp
+import           System.Log.Logger
+import           System.ZMQ4                    hiding (message)
+import           Text.Printf.TH
+
+startBot :: Config -> IO ()
+startBot conf = do
+  mbsess <- session
+    (cHostname conf)
+    (Just ((\_ -> [scramSha1 (cUsername conf) Nothing (cPassword conf)]), Just "bot"))
+    def { onConnectionClosed = onConnectionClosed' }
+  case mbsess of
+    Left err -> print err
+    Right sess -> do
+      sendPresence presenceOnline sess
+      withContext $ \ctx -> do
+        forkIO $ threadSinkThread sess ctx
+        priceMapRef <- newIORef M.empty
+        forkIO $ quotesourceThread priceMapRef ctx
+        handleCommands sess priceMapRef
+  where
+    onConnectionClosed' sess _ = void $ reconnect' sess
+
+    threadSinkThread sess ctx = do
+      noticeM "ATradeBot.TradeSink" "Started trade sink thread"
+      withSocket ctx Rep $ \sock -> do
+        bind sock "tcp://0.0.0.0:5543"
+        forever $ do
+          infoM "ATradeBot.TradeSink" "Waiting for incoming packet"
+          mTrade <- eitherDecode' . BL.fromStrict <$> receive sock
+          send sock [] $ encodeUtf8 "{ \"response\" : \"ok\" }"
+          case mTrade of
+            Right trade -> do
+              debugM "ATradeBot.TradeSink" $ "Incoming trade: " ++ show trade
+              forM_ (cTargetUsers conf) $ \username -> do
+                r <- sendMessage (message { messageTo = jidFromText username, messagePayload = toXml . messageForTrade $ trade }) sess
+                case r of
+                  Left err -> warningM "ATradeBot" (show err)
+                  _        -> return ()
+            Left err -> warningM "ATradeBot.TradeSink" $ "Error: " ++ show err
+
+
+    quotesourceThread ref ctx = do
+      tickChan <- BC.newBoundedChan 1000
+      bracket (startQuoteSourceClient tickChan (cTickers conf) ctx (cQuoteSourceEndpoint conf)) stopQuoteSourceClient $ \_ ->
+        forever $ do
+          tick <- BC.readChan tickChan
+          when (datatype tick == LastTradePrice) $ do
+            debugM "ATradeBot.QS" $ "Incoming tick: " ++ show tick
+            atomicModifyIORef' ref (\s -> ((M.insert (security tick) tick s), ()))
+
+
+    handleCommands sess ref = forever $ do
+      msg <- getMessage sess
+      case L.find (\x -> (nameLocalName . elementName) x == "body") (messagePayload msg) of
+        Just body -> forM_ (elementNodes body) $ \node ->
+          case node of
+            NodeContent (ContentText cmd) -> do
+              mbresp <- handleCommand sess ref msg cmd
+              case mbresp of
+                Just resp -> do
+                  r <- sendMessage (message { messageFrom = messageTo msg, messageTo = messageFrom msg, messagePayload = toXml resp }) sess
+                  case r of
+                    Left err -> warningM "ATradeBot" (show err)
+                    _        -> return ()
+                Nothing -> return ()
+            _                             -> return ()
+        _ -> return ()
+    handleCommand sess ref msg cmd = do
+      if
+        | "#echo " `isPrefixOf` cmd -> return $ stripPrefix "#echo " cmd
+        | "#prices" `isPrefixOf` cmd -> Just <$> showPricesMsg ref
+        | otherwise -> return Nothing
+
+    showPricesMsg ref = do
+      m <- readIORef ref
+      return $ foldMap (\tick -> [st|%?: %?\n|] (security tick) (value tick)) m
+
+    toXml text = [Element (Name "body" Nothing Nothing) [] [NodeContent (ContentText text)]]
+
+    messageForTrade :: TradeSinkMessage -> T.Text
+    messageForTrade (TradeSinkTrade{..}) = [st|Trade: %? %? at %? (%? lots, %?/%?)|]
+      tsOperation
+      tsSecurity
+      tsPrice
+      tsQuantity
+      (strategyId tsSignalId)
+      (signalName tsSignalId)
+    messageForTrade _ = "?"
+
+    onJustM :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
+    onJustM ma f = case ma of
+      Just a  -> f a
+      Nothing -> return ()
+

src/Config.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Config
+  (
+    Config(..)
+  ) where
+
+import           ATrade.Types
+import           Data.Aeson
+import qualified Data.Text      as T
+import           Network.Socket
+import           Network.Xmpp
+
+data Config =
+  Config {
+    cUsername            :: Username,
+    cPassword            :: Password,
+    cHostname            :: HostName,
+    cTargetUsers         :: [Username],
+    cQuoteSourceEndpoint :: T.Text,
+    cTickers             :: [TickerId]
+  }
+
+instance FromJSON Config where
+  parseJSON = withObject "Config" $ \v ->
+    Config <$>
+      v .: "username" <*>
+      v .: "password" <*>
+      v .: "hostname" <*>
+      v .: "target_users" <*>
+      v .: "qs_endpoint" <*>
+      v .: "tickers"

src/Main.hs

@@ -0,0 +1,28 @@
+module Main where
+
+import           Bot
+import           Config
+import           Data.Aeson
+import qualified Data.ByteString.Lazy      as B
+import           GHC.IO.Handle.FD
+import           Network.Xmpp
+import           System.Log.Formatter
+import           System.Log.Handler        (setFormatter)
+import           System.Log.Handler.Simple
+import           System.Log.Logger
+
+main :: IO ()
+main = do
+  updateGlobalLogger "Pontarius.Xmpp" $ setLevel DEBUG
+  sf <- fileHandler "atradebot.log" DEBUG
+  updateGlobalLogger rootLoggerName (addHandler sf)
+  updateGlobalLogger rootLoggerName $ setLevel DEBUG
+
+  infoM rootLoggerName "Starting"
+
+  eConfig <- eitherDecode' <$> B.readFile "atradebot.config.json"
+  case eConfig of
+    Left err     -> do
+      criticalM rootLoggerName $ "Can't load config: " ++ err
+    Right config -> startBot config
+

stack.yaml

@@ -0,0 +1,69 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-11.9
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+- ../libatrade
+- ../zeromq4-haskell-zap
+- ../pontarius-xmpp
+
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+extra-deps: [ "datetime-0.3.1", "stringprep-1.0.0", "th-printf-0.5.1" ]
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor