Represent the Bittrex API using Servant

bittrex-servant.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Bittrex.Types
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Except
import Data.Aeson
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import GHC.Generics hiding (packageName)
import Servant.API
import Servant.Client
import Network.HTTP.Client.TLS (newTlsManager, tlsManagerSettings)

import qualified Data.Text    as T
import qualified Data.Text.IO as T

-- Based loosely on http://haskell-servant.readthedocs.io/en/stable/tutorial/Client.html

-- From Servant.Client.Internal.HttpClient
-- newtype ClientM a = ClientM
--   { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
--   deriving ( Functor, Applicative, Monad, MonadIO, Generic
--            , MonadReader ClientEnv, MonadError ServantError, MonadThrow
--            , MonadCatch)

-- Map as closely to the real API as possible (even if it doesn't fit Servant particularly well)
type BittrexAPI = "public" :> ("getmarkets" :> Get '[JSON] (BittrexR [Market]) 
                         :<|> "getcurrencies" :> Get '[JSON] (BittrexR [Currency]) 
                         :<|> "getticker" :> QueryParam "market" MarketName :> Get '[JSON] (BittrexR Ticker)
                         :<|> "getmarketsummaries" :> Get '[JSON] (BittrexR [MarketSummary]) 
                         :<|> "getmarketsummary" :> QueryParam "market" MarketName :> Get '[JSON] (BittrexR MarketSummary) 
                         :<|> "getorderbook" :> QueryParam "market" MarketName :> QueryParam "type" OrderBookType :> Get '[JSON] (BittrexR OrderBook) 
                         :<|> "getorderbook" :> QueryParam "market" MarketName :> QueryParam "type" OrderBookType :> Get '[JSON] (BittrexR [OrderBookEntry]) 
                              )

bittrexAPI :: Proxy BittrexAPI
bittrexAPI = Proxy

-- The 'Maybe' representation of the required query parameter isn't ideal
-- We could export a new function which wraps the argument in Just
-- See https://github.com/haskell-servant/servant/issues/241

getMarkets :: ClientM (BittrexR [Market])
getCurrencies :: ClientM (BittrexR [Currency])
getTicker :: Maybe MarketName -> ClientM (BittrexR Ticker)
getMarketSummaries :: ClientM (BittrexR [MarketSummary])
getMarketSummary :: Maybe MarketName -> ClientM (BittrexR MarketSummary)
-- These are a little nasty as the structure of data is dependent on the 'type' of order
getOrderBookBoth :: Maybe MarketName -> Maybe OrderBookType -> ClientM (BittrexR OrderBook)
getOrderBookSingle :: Maybe MarketName -> Maybe OrderBookType -> ClientM (BittrexR [OrderBookEntry])

getMarkets :<|> getCurrencies :<|> getTicker :<|> getMarketSummaries :<|> getMarketSummary :<|> getOrderBookBoth :<|> getOrderBookSingle = client bittrexAPI 

instance ToHttpApiData MarketName where
  toQueryParam =  T.replace "_" "-" . T.pack . show

data OrderBookType
  = Buy | Sell | Both
  deriving (Show, Eq, Generic)

instance ToHttpApiData OrderBookType where
  toQueryParam = T.toLower . T.pack . show

-- Bittrex API response wrapper
data BittrexR a 
  = BittrexR
  { success :: Bool
  , message :: Text
  , result  :: Maybe a
  } deriving (Show, Eq, Generic)

instance FromJSON a => FromJSON (BittrexR a)

runBittrexR :: BittrexR a -> Either Text a
runBittrexR (BittrexR False m _)
  = Left m
runBittrexR (BittrexR True m res) 
  = case res of
      Just x  -> Right x
      Nothing -> Left m -- I don't think this will ever be called (by API design)

main :: IO ()
main = do
   manager' <- newTlsManager
   let env = ClientEnv manager' (BaseUrl Https "bittrex.com" 443 "/api/v1.1")
--   res <- runClientM (getTicker (Just BTC_LTC)) env
--   res <- runClientM (getMarkets) env
--   res <- runClientM (getMarketSummaries) env
   res <- runClientM (getOrderBookSingle (Just BTC_LTC) (Just Buy)) env
   print $ fmap runBittrexR res