diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Avi Press + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# CryptoCompare + +[![Build Status](https://travis-ci.org/aviaviavi/cryptocompare.svg?branch=master)](https://travis-ci.org/aviaviavi/cryptocompare) + +A Haskell wrapper to the public [CryptoCompare API](https://www.cryptocompare.com/api/), a +source of information and pricing of different crypto currencies + +## State + +This library is usable but not complete. It currently covers a subset of the API. +Breaking changes will occur if necessary but will be avoided if possible. + +## Contributing + +Contributions in any form are always welcome. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,15 @@ +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 diff --git a/cryptocompare.cabal b/cryptocompare.cabal new file mode 100644 --- /dev/null +++ b/cryptocompare.cabal @@ -0,0 +1,81 @@ +name: cryptocompare +version: 0.0.1 +synopsis: Haskell wrapper for the cryptocompare API +description: + # CryptoCompare + + [![Build Status](https://travis-ci.org/aviaviavi/cryptocompare.svg?branch=master)](https://travis-ci.org/aviaviavi/cryptocompare) + + A Haskell wrapper to the public [CryptoCompare API](https://www.cryptocompare.com/api/), a + source of information and pricing of different crypto currencies + + ## State + + This library is usable but not complete. It currently covers a subset of the API. + Breaking changes will occur if necessary but will be avoided if possible. + + ## Contributing + + Contributions in any form are always welcome. +homepage: https://github.com/aviaviavi/cryptocompare +license: MIT +license-file: LICENSE +author: Avi Press +maintainer: avipress@gmail.com +copyright: 2017 Avi Press +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: CryptoCompare + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , directory + , text + , MissingH + , time + , aeson + , unordered-containers + , http-conduit + , bytestring + , containers + , transformers + , exceptions + + +executable cryptocompare-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , cryptocompare + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , directory + , text + , MissingH + , time + , aeson + , unordered-containers + , http-conduit + , bytestring + , containers + , transformers + , exceptions + +test-suite cryptocompare-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , cryptocompare + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/githubuser/cryptocompare diff --git a/src/CryptoCompare.hs b/src/CryptoCompare.hs new file mode 100644 --- /dev/null +++ b/src/CryptoCompare.hs @@ -0,0 +1,334 @@ +{-# 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 Control.Monad.Catch +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 (Object x) = + CoinSnapshot <$> x .: "Algorithm" <*> x .: "ProofType" <*> + x .: "BlockNumber" <*> + x .: "NetHashesPerSecond" <*> + x .: "TotalCoinsMined" <*> + x .: "BlockReward" <*> + x .: "AggregatedData" + parseJSON _ = error "expected an object" + +-- | 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" <*> + (read <$> x .: "PRICE") <*> + (read <$> x .: "LASTUPDATE") <*> + (read <$> x .: "LASTVOLUME") <*> + (read <$> x .: "LASTVOLUMETO") <*> + x .: "LASTTRADEID" <*> + (read <$> x .: "VOLUME24HOUR") <*> + (read <$> x .: "VOLUME24HOURTO") <*> + (read <$> x .: "OPEN24HOUR") <*> + (read <$> x .: "HIGH24HOUR") <*> + (read <$> 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 + +-- 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, MonadCatch m) => m (Either String [CoinDetails]) +fetchCoinList = catchIOError (do + r <- httpJSON "https://www.cryptocompare.com/api/data/coinlist/" + return . Right . coins $ getResponseBody r) + (return . Left . show) + +-- | For a given coin, get a daily history of the coin's price +-- +-- > do +-- > priceHistResp <- fetchDailyPriceHistory "BTC" "USD" 300 +-- > print priceHistResp +-- +fetchDailyPriceHistory :: + (MonadIO m, MonadThrow m, MonadCatch 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 = catchIOError (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 . Left . show) + +-- | For a given coin, get the current price +-- +-- +-- > do +-- > priceResp <- fetchCurrentPrice "BTC" ["USD", "EUR", "BTC"] +-- > print priceResp +-- +fetchCurrentPrice :: + (MonadIO m, MonadThrow m, MonadCatch 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 = catchIOError (do + priceReq <- + return . parseRequest $ + "https://min-api.cryptocompare.com/data/price" ++ + toQueryString (PriceRequest coinSymbol priceSymbols) + r <- httpJSON <$> priceReq + Right . getResponseBody <$> r) + (return . Left . show) + +-- | Fetch details about a particular coin +-- +-- > do +-- > snapshotResp <- fetchCoinSnapshot "BTC" "USD" +-- > print snapshotResp +-- +fetchCoinSnapshot :: (MonadIO m, MonadThrow m, MonadCatch 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 = catchIOError (do + snapshotReq <- + return . parseRequest $ + "https://www.cryptocompare.com/api/data/coinsnapshot" ++ + toQueryString (CoinSnapshotRequest fSym tSym) + r <- httpJSON <$> snapshotReq + Right . snapshot . getResponseBody <$> r) + (return . Left . show) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"