commit
5b00b9ad9b
9 changed files with 1569 additions and 0 deletions
@ -0,0 +1,30 @@
@@ -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. |
||||
@ -0,0 +1,2 @@
@@ -0,0 +1,2 @@
|
||||
import Distribution.Simple |
||||
main = defaultMain |
||||
@ -0,0 +1,35 @@
@@ -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 |
||||
@ -0,0 +1,124 @@
@@ -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 () |
||||
|
||||
@ -0,0 +1,32 @@
@@ -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" |
||||
@ -0,0 +1,28 @@
@@ -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 |
||||
|
||||
@ -0,0 +1,69 @@
@@ -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 |
||||
Loading…
Reference in new issue