cryptocompare-0.1.2: src/CryptoCompare.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A haskell wrapper for the cryptocompare API, a source of information and pricing of different crypto currencies
--
-- > module Main (main) where
-- >
-- > import CryptoCompare
-- >
-- > main :: IO ()
-- > main = do
-- >   coinList <- fetchCoinList
-- >   either print (print . length) coinList
-- >   either print (print . head) coinList
-- >   priceResp <- fetchCurrentPrice "BTC" ["USD", "EUR", "BTC"]
-- >   print priceResp
-- >   priceHistResp <- fetchDailyPriceHistory "BTC" "USD" 300
-- >   print priceHistResp
-- >   snapshotResp <- fetchCoinSnapshot "BTC" "USD"
-- >   print snapshotResp
--
module CryptoCompare
  ( fetchCoinList
  , fetchCurrentPrice
  , fetchDailyPriceHistory
  , fetchCoinSnapshot
  , CoinDetails(..)
  , PriceHistoryResponse(..)
  , PriceHistoryResponseData(..)
  , CoinSnapshot(..)
  , AggregatedSnapshot(..)
  , PriceResponse(..)
  ) where

import qualified Control.Exception      as E
import           Control.Monad.IO.Class
import           Data.Aeson
import           Data.Aeson.Types
import           Data.HashMap.Strict
import           Data.List
import           Data.Map               (Map)
import           Data.Maybe
import           Data.Time.Clock
import           GHC.Generics
import           Network.HTTP.Simple
import           Text.Printf

-- | Typeclass for datatypes from which url query parameters can be generated
class ToQueryString a where
  toQueryString :: a -> String

-- | List of all known coins, and some basic info for them
data CoinListResponse = CoinListResponse {
  response     :: String,
  message      :: String,
  responseType :: Integer,
  coins        :: [CoinDetails]
} deriving (Show, Generic)

-- | High level information about each coin.
data CoinDetails = CoinDetails {
  _key      :: String,
  id        :: String,
  url       :: String,
  imageUrl  :: Maybe String,
  name      :: String,
  coinName  :: String,
  fullName  :: String,
  algorithm :: String,
  proofType :: String,
  sortOrder :: String
} deriving (Show, Generic)

-- | Request the current price of a particular cryptocurrency
data PriceRequest = PriceRequest {
  fromSym :: String,
  toSyms  :: [String]
}

instance ToQueryString PriceRequest where
  toQueryString req =
    printf
      "?fsym=%s&tsyms=%s"
      (fromSym (req :: PriceRequest))
      (intercalate "," $ toSyms (req :: PriceRequest))

-- TODO - get rid of repeated code

-- | Request a more detailed view of a coin's information
data CoinSnapshotRequest = CoinSnapshotRequest {
  snapshotFromSym :: String,
  snapshotToSym   :: String
}

instance ToQueryString CoinSnapshotRequest where
  toQueryString req =
    printf
      "?fsym=%s&tsym=%s"
      (snapshotFromSym req)
      (snapshotToSym req)

-- | Response containing more detailed meta information about a coin, as well as
-- aggregated pricing information
data CoinSnapshotResponse = CoinSnapshotResponse
  { snapshotResponseMessage :: String
  , snapshotResponseType    :: Integer
  , snapshot                :: CoinSnapshot
  } deriving (Show)

instance FromJSON CoinSnapshotResponse where
  parseJSON (Object x) =
    CoinSnapshotResponse <$> x .: "Message" <*> x .: "Type" <*>
    x .: "Data"
  parseJSON _ = error "expected an object"

-- | High level data about a particular coin
data CoinSnapshot = CoinSnapshot
  { snapshotAlgorithm      :: String
  , snapshotProofType      :: String
  , blockNumber            :: Integer
  , netHashesPerSecond     :: Float
  , totalCoinsMined        :: Float
  , blockReward            :: Float
  , aggregatedSnapshotData :: AggregatedSnapshot
  } deriving (Show)

instance FromJSON CoinSnapshot where
  parseJSON = withObject "coin shapshot" $ \object -> do
    coinInfo <- object .: "CoinInfo"
    CoinSnapshot <$> coinInfo .: "Algorithm" <*> coinInfo .: "ProofType" <*>
      coinInfo .: "BlockNumber" <*>
      coinInfo .: "NetHashesPerSecond" <*>
      coinInfo .: "TotalCoinsMined" <*>
      coinInfo .: "BlockReward" <*>
      object   .: "AggregatedData"

-- | Aggregated data about a particular coin
data AggregatedSnapshot = AggregatedSnapshot
  { market         :: String
  , fromSymbol     :: String
  , toSymbol       :: String
  , flags          :: String
  , price          :: Float
  , lastUpdate     :: Integer
  , lastVolume     :: Float
  , lastVolumeto   :: Float
  , lastTradeId    :: String
  , volume24Hour   :: Float
  , volume24HourTo :: Float
  , open24Hour     :: Float
  , high24Hour     :: Float
  , low24Hour      :: Float
  , lastMarket     :: String
  } deriving (Show)
instance FromJSON AggregatedSnapshot where
  parseJSON (Object x) =
    AggregatedSnapshot <$> x .: "MARKET" <*> x .: "FROMSYMBOL" <*>
    x .: "TOSYMBOL" <*>
    x .: "FLAGS" <*>
    x .: "PRICE" <*>
    x .: "LASTUPDATE" <*>
    x .: "LASTVOLUME" <*>
    x .: "LASTVOLUMETO" <*>
    x .: "LASTTRADEID" <*>
    x .: "VOLUME24HOUR" <*>
    x .: "VOLUME24HOURTO" <*>
    x .: "OPEN24HOUR" <*>
    x .: "HIGH24HOUR" <*>
    x .: "LOW24HOUR" <*>
    x .: "LASTMARKET"
  parseJSON _ = error "expected an object"

-- | contains pairs of prices: crypto symbol -> (regular currency symbol, price)
newtype PriceResponse =
  PriceResponse (Map String Float)
  deriving (Show, Generic)
instance FromJSON PriceResponse

-- | Get the price history of a coin (daily)
data PriceHistoryRequest = PriceHistoryRequest {
  -- | coin symbol
  historyFromSym :: String,
  -- | display in currency
  historyToSym   :: String,
  -- | most recent timestamp in returned result
  toTimestamp    :: Maybe UTCTime,
  -- | days to go back
  limit          :: Maybe Integer
}
priceHistReqDefault :: PriceHistoryRequest
priceHistReqDefault = PriceHistoryRequest "" [] Nothing Nothing

-- | API response container for daily price history
data PriceHistoryResponse = PriceHistoryResponse {
  responseData :: [PriceHistoryResponseData], -- ^ the actual response, list of price entries
  timeTo       :: Maybe Integer, -- ^ latest price returned
  timeFrom     :: Maybe Integer -- ^ earliest price returned
} deriving (Show, Generic)

instance FromJSON PriceHistoryResponse where
  parseJSON (Object x) =
    PriceHistoryResponse <$> x .: "Data" <*> x .:? "TimeTo" <*> x .:? "TimeFrom"
  parseJSON _ = error "expected an object"

-- | Data for a particular snapshot of a coin's daily price
data PriceHistoryResponseData = PriceHistoryResponseData {
    time       :: Float,
    open       :: Float,
    high       :: Float,
    low        :: Float,
    close      :: Float,
    volumefrom :: Float,
    volumeto   :: Float
} deriving (Show, Generic)

instance FromJSON PriceHistoryResponseData

instance ToQueryString PriceHistoryRequest where
  toQueryString req =
    printf
      "?fsym=%s&tsym=%s&limit=%s"
      (historyFromSym req)
      (historyToSym req)
      (fromMaybe "" (show <$> limit req))

instance FromJSON CoinListResponse where
  parseJSON (Object x) =
    CoinListResponse <$> x .: "Response" <*> x .: "Message" <*> x .: "Type" <*>
    x .: "Data"
  parseJSON _ = error "expected an object"

-- Aeson claims this definition overlaps with the internal
-- instance of FromJSON [a], so the overlap pragma seems to fix that
-- TODO - this seems wrong, there's probably a cleaner way to write
-- that doesn't involve extension pragmas
instance {-# OVERLAPS #-} FromJSON [CoinDetails] where
    parseJSON x =
      parseJSON x >>= mapM parseCointListResponseData . toList

showError :: HttpException -> Either String a
showError = Left . show

-- Since this entry uses keys that we don't know ahead of time, we
-- need to do some special parsing that doesn't require it.
parseCointListResponseData :: (String, Value) -> Parser CoinDetails
parseCointListResponseData (i, v) =
  withObject
    "entry body"
    (\o ->
       CoinDetails i <$> o .: "Id" <*> o .: "Url" <*> o .:? "ImageUrl" <*>
       o .: "Name" <*>
       o .: "CoinName" <*>
       o .: "FullName" <*>
       o .: "Algorithm" <*>
       o .: "ProofType" <*>
       o .: "SortOrder")
    v

-- | Get a list of all of the coins the API is aware of, and high level details
-- about those coins
--
-- @
-- do
--   coinList <- fetchCoinList
--   either print (print . length) coinList
--   either print (print . head) coinList
-- @
--
fetchCoinList :: (MonadIO m) => m (Either String [CoinDetails])
fetchCoinList =
  liftIO $
  E.catch
    (do r <- httpJSON "https://www.cryptocompare.com/api/data/coinlist/"
        return . Right . coins $ getResponseBody r)
    (return . showError)

-- | For a given coin, get a daily history of the coin's price
--
-- > do
-- >   priceHistResp <- fetchDailyPriceHistory "BTC" "USD" 300
-- >   print priceHistResp
--
fetchDailyPriceHistory ::
     (MonadIO m)
  => String -- ^ Coin symbol (`BTC`, `ETH`, etc)
  -> String -- ^ Currency symbol to display prices in (`USD`, `EUR`, etc)
  -> Integer -- ^ Days of history to return (Max 2000)
  -> m (Either String PriceHistoryResponse) -- ^ Either an error or response data
fetchDailyPriceHistory coinSymbol priceCurrency days =
  liftIO $
  E.catch
    (do priceHistReq <-
          return . parseRequest $
          "https://min-api.cryptocompare.com/data/histoday" ++
          toQueryString
            (priceHistReqDefault
             { historyFromSym = coinSymbol
             , historyToSym = priceCurrency
             , limit = Just days
             } :: PriceHistoryRequest)
        r <- httpJSON <$> priceHistReq
        Right . getResponseBody <$> r)
    (return . showError)

-- | For a given coin, get the current price
--
--
-- > do
-- >   priceResp <- fetchCurrentPrice "BTC" ["USD", "EUR", "BTC"]
-- >   print priceResp
--
fetchCurrentPrice ::
     MonadIO m
  => String -- ^ Coin symbol (`BTC`, `ETH`, etc)
  -> [String] -- ^ Currency symbol(s) to display prices in. Eg [`USD`, `EUR`, ...]
  -> m (Either String PriceResponse) -- ^ Either an error or response data
fetchCurrentPrice coinSymbol priceSymbols =
  liftIO $
  E.catch
    (do priceReq <-
          return . parseRequest $
          "https://min-api.cryptocompare.com/data/price" ++
          toQueryString (PriceRequest coinSymbol priceSymbols)
        r <- httpJSON <$> priceReq
        Right . getResponseBody <$> r)
    (return . showError)

-- | Fetch details about a particular coin
--
-- > do
-- >  snapshotResp <- fetchCoinSnapshot "BTC" "USD"
-- >  print snapshotResp
--
fetchCoinSnapshot ::
     MonadIO m
  => String -- ^ Coin symbol (`BTC`, `ETH`, etc)
  -> String -- ^ Currency symbol(s) to display prices in (`USD`, `EUR`, etc)
  -> m (Either String CoinSnapshot) -- ^ Either an error or response data
fetchCoinSnapshot fSym tSym =
  liftIO $
  E.catch
    (do snapshotReq <-
          return . parseRequest $
          "https://min-api.cryptocompare.com/data/top/exchanges/full" ++
          toQueryString (CoinSnapshotRequest fSym tSym)
        r <- httpJSON <$> snapshotReq
        Right . snapshot . getResponseBody <$> r)
    (return . showError)