bfx.hs

bfx.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad.Reader hiding ( asks)
import Control.Monad.State.Lazy
import Control.Monad.Loops
import Text.Printf
--import Formatting
import Data.Aeson
import GHC.Generics
import qualified Data.ByteString.Lazy as B
import Network.HTTP.Conduit (simpleHttp)
import Data.Maybe
import Data.List.Split
import System.IO
import System.IO.Unsafe
import System.Log.Logger
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple (streamHandler)
import System.Log.Formatter
import System.Console.ANSI

clBold = SetConsoleIntensity BoldIntensity
clFg i c = SetColor Foreground i c
cl = setSGRCode

colBold = setSGRCode [ clBold ]
colFg i c = setSGRCode [ clFg i c ]
colRst = setSGRCode [ Reset ]

colorize sgr s = setSGRCode sgr ++ s ++ colRst
colorizeF sgr f v = colorize sgr $ printf f v

pretty sgr align s = colorize sgr $
    if align == 0
    then s
    else printf ("%" ++ show align ++ "s") s

prettyf sgr align f v = pretty sgr align $ printf f v

colorLogFormatter h (prio, msg) loggername = return $
    case prio of
        DEBUG     -> setSGRCode [ SetColor Foreground Vivid Black ]
        INFO      -> setSGRCode [ SetColor Foreground Vivid Green ]
        NOTICE    -> setSGRCode [ SetColor Foreground Dull Blue ]
        WARNING   -> setSGRCode [ SetColor Foreground Vivid Blue ]
        ERROR     -> setSGRCode [ SetColor Foreground Dull Red ]
        CRITICAL  -> setSGRCode [ SetColor Foreground Vivid Red ]
        ALERT     -> setSGRCode [ SetColor Foreground Dull Yellow ]
        EMERGENCY -> setSGRCode [ SetColor Foreground Vivid Yellow ]
    ++ printf "[%10s] " loggername
    ++ setSGRCode [ Reset ] ++ msg

initialize = do
    h <- streamHandler stdout DEBUG >>= \lh -> return $
        setFormatter lh colorLogFormatter
    updateGlobalLogger rootLoggerName (
        setHandlers [h] .
        setLevel DEBUG
        )

type Amount = Double
type Price = Double
type Fraction = Double

asAmountBTC x = prettyf [ clBold, clFg Dull Magenta ] 0 "%.2f" x

asAmountUSD' :: Amount -> String
asAmountUSD' x = (if x < 0 then "-" else "") ++ (printf "$%.2f" (abs x))

asAmountUSD x = pretty [ clBold, clFg Dull Yellow ] 0 $ asAmountUSD' x

asPrice x = prettyf [ clBold, clFg Vivid White ] 0 "$%.2f" x

asProfit x = pretty
    [ clBold
    , clFg Vivid $ if x >= 0
        then Green
        else Red
    ] 0 $ asAmountUSD' x

apiBaseURL = "https://api.bitfinex.com/v1/"
apiSymbol = "BTCUSD"

data Order = Order
    { orderPrice :: Price
    , orderAmount :: Amount
    }

instance FromJSON Order where
  parseJSON (Object v) = let unfuck x = fmap read (v .: x) in
    Order <$>
      unfuck "price" <*>
      unfuck "amount"
instance Show Order where
    show (Order p a) = printf "\n%8.2f @ $%-4.2f" a p

data OrderBook = OrderBook
    { bids :: [Order]
    , asks :: [Order]
    } deriving (Generic)

instance FromJSON OrderBook
instance Show OrderBook where
    show (OrderBook (b:_) (a:_)) = 
        "Max bid: " ++ asPrice (orderPrice b)  ++
        "\nMin ask: " ++ asPrice (orderPrice a)
    show (OrderBook b a) =  "Max bid: " ++ show b ++ "\nMin ask: " ++ show a

getOrderBook :: IO OrderBook
getOrderBook = fromJust . decode <$> simpleHttp (apiBaseURL ++ "book/" ++ apiSymbol)

type OrderBookState = StateT OrderBook IO

mergeOrders :: [Order] -> [Order]
mergeOrders [] = []
mergeOrders (x:[]) = [x]
mergeOrders (x1:(x2:xs)) = if orderPrice x1 == orderPrice x2 then
  mergeOrders (x1{orderAmount = orderAmount x1 + orderAmount x2}:xs) else
  (x1:(mergeOrders (x2:xs)))

collectUntilAmount :: [Order] -> Amount -> Amount -> ([Order], [Order], Amount)
collectUntilAmount []     _ acc = ([], [], acc)
collectUntilAmount os     0 acc = (os, [], acc)
collectUntilAmount (o:os) a acc
  | oa > a      = (o{orderAmount = oa - a} : os, [o{orderAmount = a}], acc + a * op)
  | oa == a     = (os, [o], acc + a * op)
  | otherwise   = (\(rs, rl, racc) -> (rs, o:rl, racc)) $ collectUntilAmount os (a - oa) (acc + oa * op)
    where
      oa = orderAmount o
      op = orderPrice o

collectUntilValue :: [Order] -> Amount -> Amount -> ([Order], [Order], Amount)
collectUntilValue []     _ acc = ([], [], acc)
collectUntilValue (o:os) v acc
  | ov > v      = (o{orderAmount = oa - va} : os, [o{orderAmount = va}], acc + va)
  | ov == v     = (os, [o], acc + va)
  | otherwise   = (\(rs, rl, racc) -> (rs, o:rl, racc)) $ collectUntilValue os (v - ov) (acc + oa)
    where
      oa = orderAmount o
      op = orderPrice o
      ov = oa * op
      va = v / op

bb = [Order x 10 | x <- [1..10]]

executeTrade :: Amount -> Deal Amount
executeTrade amount = lift $ lift $ iterateUntilM
    (\(a, _) -> a < 0.0001)
    (\(a, sum) -> do
        x:xs <- getBook
        let
            oa = orderAmount x
            op = orderPrice x
            in if oa < a
            then do
                liftIO $ debugM "market" $
                    "execute " ++ asAmountBTC oa ++ " @ " ++ asPrice op
                putBook xs
                return (a - oa, sum + (oa*op))
            else do
                liftIO $ debugM "market" $
                    "execute " ++ asAmountBTC a ++ " @ " ++ asPrice op
                putBook (x{orderAmount = oa - a}:xs)
                return (0, sum + (a*op)))
    (abs amount, 0) >>= (return . (/ abs amount) . snd)
    where
        getBook = gets (if amount < 0 then bids else asks)
        putBook :: [Order] -> OrderBookState ()
        putBook xs = do 
            b <- get
            put (if amount < 0 then b{bids = xs} else b{asks = xs})

executeBuy amount = executeTrade amount
executeSell amount = executeTrade (-amount)

initiallyRequired = 0.3 :: Fraction
maintenanceRequired = 0.15 :: Fraction
takerFee = 0.002 :: Fraction
makerFee = 0.001 :: Fraction

type Deal a = ReaderT Fraction AccountState a

--deal :: Fraction -> Deal a -> AccountState a
deal = (flip runReaderT)
market = deal takerFee
limit = deal makerFee

dealFee :: Amount -> Price -> Deal Amount
dealFee a p = do
    f <- ask
    return $ (abs a) * p * f
dealWithFee a p = dealFee a p >>= (return . (a*p -))

data Position = Position
    { amount :: Amount
    , price :: Price
    }

instance Show Position where
    show pos@(Position a p) = asAmountBTC a ++ " @ " ++ asPrice p
        ++ ", profitable at "
        ++ [if a > 0 then '>' else '<']
        ++ asPrice (runReader (profitablePrice pos) takerFee)

positionProfit :: Position -> Price -> Deal Amount
positionProfit (Position a p0) p1 = dealFee a p1 >>= (return . (a * (p1-p0) - ))

(Position a1 p1) |+| (Position a2 p2) = Position (a1+a2) ((a1*p1+a2*p2)/(a1+a2))

profitablePrice :: Position -> Reader Fraction Price
profitablePrice (Position a p) = do
    fee <- ask
    let fc = fee * abs a /a in (return $ p * (1+fc)/(1-fc))
--profitablePrice (Position a p) = a * p * (fc/a + 1) / (a-fc) where fc = takerFee * abs a

data Account = Account
    { balance :: Amount
    , position :: Maybe Position
    }
instance Show Account where
    show a@(Account bal pos) =
        printf "Balance:  %s$%.2f%s" 
            (setSGRCode [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Yellow ])
            bal
            (setSGRCode [ Reset ])
        ++
        if (isJust pos)
            then "\nPosition: " ++ (show $ fromJust pos) ++
                ", liq at " ++ asPrice (liquidationPrice a)
            else ""

type AccountState = StateT Account OrderBookState

liquidationPrice :: Account -> Price
liquidationPrice (Account bal (Just (Position a p))) = (1+maintenanceRequired)*p-bal/a

pay :: Amount -> AccountState ()
pay x = do
    acc <- get
    put $ acc{balance = balance acc - x}


maxAmount :: Price -> Deal Amount
maxAmount p = do
    Account bal _ <- get
    fee <- ask
    return $ ((1-fee)/p/initiallyRequired) * bal

trade :: Price -> Amount -> Deal ()
trade price amount = do
    Account bal pos <- get
    fee <- dealFee amount price
    liftIO $ debugM "account" $ "trade "
        ++ asAmountBTC amount ++ " @ " ++ asPrice price
        ++ ", fee: " ++ (asProfit (-fee))
    put $ Account (bal - fee) (Just $ (fromMaybe (Position 0 0) pos) |+| Position amount price)

-- close currently opened position
close :: Price -> Deal ()
close price = do
    Account bal pos <- get
    p <- positionProfit (fromJust pos) price
    liftIO $ debugM "account" $ printf "close position "
        ++ asAmountBTC (amount $ fromJust pos) ++ " @ " ++ asPrice price
        ++ ", profit: " ++ asProfit p
    put $ Account (bal + p) Nothing

-- buy or sell given amount of btc for specified price
buy price amount = trade price amount
sell price amount = trade price (-amount)

-- buy or sell for all account value
buyAll price = maxAmount price >>= buy price
sellAll price = maxAmount price >>= sell price

-- reopen will close position and open new one in same direction
reopen p = do
    a <- gets (amount . fromJust . position)
    close p
    if a > 0 then buyAll p else sellAll p

-- turnaround will close position and open new one in opposite direction
turnaround p = do
    a <- gets (amount . fromJust . position)
    close p
    if a > 0 then sellAll p else buyAll p

-- buy, sell and close using actual bitfinex orderbook
buyNow a = (executeBuy a) >>= flip buy a
sellNow a = (executeSell a) >>= flip sell a
closeNow = do
    a <- gets (amount . fromJust . position)
    (executeTrade (-a)) >>= close

-- inital account state
now' :: OrderBookState Account
now' = return $ Account  533.47352936  Nothing

{-
now' = execStateT (do
    limit $ sell 413 10.65
    market $
        buy 463.45 0.39 >>
        buy 463.52 1.26
    ) $ Account 1320.12413017 Nothing
-}

-- some trades that already happened on the account
recent = do
	market $ sell 385.55 4.6
	pay (-315.88533705)


-- call like this:
-- estimate $ limit $ buy 330 1 >> turnaround 340 >> close 320 >> buyAll 330
newtype TradingResult = TR (Account, OrderBook)
instance Show TradingResult where
    show (TR (a, ob)) = show a ++ "\n\n" ++ show ob

accountInfo = mapM_ (\x -> liftIO $ infoM "account" x) . lines

estimate x = evalStateT (do
    n <- now'
    accountInfo $
        "\n--<[ Before ]>------------------------------------\n" ++
        show n ++
        "\n--------------------------------------------------\n\n"
    r <- execStateT x n
    accountInfo $
        "\n--<[ After  ]>------------------------------------\n" ++
        show r ++
        "\n--------------------------------------------------" ++
        "\nOverall profit: " ++ asProfit (balance r - balance n)
    ) $ unsafePerformIO getOrderBook

-- estimate prepending 'recent' trades
estim x = estimate $ do
    recent
    x

-- print current account state
now = evalStateT (do
    n <- now'
    accountInfo $
        "--<[ Current state ]>-----------------------------\n" ++
        show n
    ) $ unsafePerformIO getOrderBook