{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
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
class ToQueryString a where
toQueryString :: a -> String
data CoinListResponse = CoinListResponse {
response :: String,
message :: String,
responseType :: Integer,
coins :: [CoinDetails]
} deriving (Show, Generic)
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)
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))
data CoinSnapshotRequest = CoinSnapshotRequest {
snapshotFromSym :: String,
snapshotToSym :: String
}
instance ToQueryString CoinSnapshotRequest where
toQueryString req =
printf
"?fsym=%s&tsym=%s"
(snapshotFromSym req)
(snapshotToSym req)
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"
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"
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"
newtype PriceResponse =
PriceResponse (Map String Float)
deriving (Show, Generic)
instance FromJSON PriceResponse
data PriceHistoryRequest = PriceHistoryRequest {
historyFromSym :: String,
historyToSym :: String,
toTimestamp :: Maybe UTCTime,
limit :: Maybe Integer
}
priceHistReqDefault :: PriceHistoryRequest
priceHistReqDefault = PriceHistoryRequest "" [] Nothing Nothing
data PriceHistoryResponse = PriceHistoryResponse {
responseData :: [PriceHistoryResponseData],
timeTo :: Maybe Integer,
timeFrom :: Maybe Integer
} deriving (Show, Generic)
instance FromJSON PriceHistoryResponse where
parseJSON (Object x) =
PriceHistoryResponse <$> x .: "Data" <*> x .:? "TimeTo" <*> x .:? "TimeFrom"
parseJSON _ = error "expected an object"
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"
instance {-# OVERLAPS #-} FromJSON [CoinDetails] where
parseJSON x =
parseJSON x >>= mapM parseCointListResponseData . toList
showError :: HttpException -> Either String a
showError = Left . show
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
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)
fetchDailyPriceHistory ::
(MonadIO m)
=> String
-> String
-> Integer
-> m (Either String PriceHistoryResponse)
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)
fetchCurrentPrice ::
MonadIO m
=> String
-> [String]
-> m (Either String PriceResponse)
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)
fetchCoinSnapshot ::
MonadIO m
=> String
-> String
-> m (Either String CoinSnapshot)
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)