exchangerates (empty) → 0.0.0.0
raw patch · 15 files changed
+1267/−0 lines, 15 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, containers, directory, exchangerates, genvalidity, genvalidity-containers, genvalidity-hspec, genvalidity-hspec-aeson, genvalidity-text, genvalidity-time, hspec, http-api-data, http-client, http-client-tls, mtl, servant, servant-client, stm, text, time, validity, validity-containers, validity-time, yaml
Files
- LICENSE +30/−0
- README.md +64/−0
- Setup.hs +3/−0
- exchangerates.cabal +100/−0
- src/ExchangeRates.hs +32/−0
- src/ExchangeRates/API.hs +44/−0
- src/ExchangeRates/Cache.hs +278/−0
- src/ExchangeRates/Client.hs +211/−0
- src/ExchangeRates/Types.hs +198/−0
- test/ExchangeRates/Cache/Gen.hs +23/−0
- test/ExchangeRates/CacheSpec.hs +192/−0
- test/ExchangeRates/Types/Gen.hs +36/−0
- test/ExchangeRates/TypesSpec.hs +36/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +19/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tom Sydney Kerckhove (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tom Sydney Kerckhove nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,64 @@+# ExchangeRates, a Haskell client for http://exchangeratesapi.io/++## Automatic Transparent Caching++Because historical currency conversion rates do not change post-hoc,+we can cache them indefinitely.+Because of this, and because http://exchangeratesapi.io/ is a free service,+we should cache the results of the API as much as possible.+This client automatically transparenly caches results so that the real+API is only called when absolutely necessary.++## Example usage:++``` Haskell+main :: IO+main = do+ rates <-+ autoRunExchangeRatesClient $+ withFileCache "/tmp/exchangerates.cache" $+ getAtDate (fromGregorian 2018 01 19) (Just EUR) Nothing+ case rates of+ Left err -> die $ show err+ Right v -> print v+```++```+Rates+ { ratesBase = EUR+ , ratesDate = 2018-01-19+ , ratesRates = fromList+ [ (AUD,Rate {unRate = 6891408149802333 % 4503599627370496})+ , (BGN,Rate {unRate = 550508759450701 % 281474976710656})+ , (BRL,Rate {unRate = 8852275427559447 % 2251799813685248})+ , (CAD,Rate {unRate = 3433093995944529 % 2251799813685248})+ , (CHF,Rate {unRate = 5295332441862229 % 4503599627370496})+ , (CNY,Rate {unRate = 8836175058891597 % 1125899906842624})+ , (CZK,Rate {unRate = 3579376541341057 % 140737488355328})+ , (DKK,Rate {unRate = 8382775166406073 % 1125899906842624})+ , (GBP,Rate {unRate = 3979605810725939 % 4503599627370496})+ , (HKD,Rate {unRate = 5393848683710959 % 562949953421312})+ , (HRK,Rate {unRate = 4185645493678139 % 562949953421312})+ , (HUF,Rate {unRate = 5439503924933427 % 17592186044416})+ , (IDR,Rate {unRate = 16316 % 1})+ , (ILS,Rate {unRate = 2355213720128743 % 562949953421312})+ , (INR,Rate {unRate = 2752790087858127 % 35184372088832})+ , (JPY,Rate {unRate = 4768889792920289 % 35184372088832})+ , (KRW,Rate {unRate = 2873903492680909 % 2199023255552})+ , (MXN,Rate {unRate = 6422133068630327 % 281474976710656})+ , (MYR,Rate {unRate = 5433592950422503 % 1125899906842624})+ , (NOK,Rate {unRate = 5417999236712733 % 562949953421312})+ , (NZD,Rate {unRate = 3790004266413641 % 2251799813685248})+ , (PHP,Rate {unRate = 8745146051423371 % 140737488355328})+ , (PLN,Rate {unRate = 2348402025692345 % 562949953421312})+ , (RON,Rate {unRate = 2623009012971261 % 562949953421312})+ , (RUB,Rate {unRate = 609850721415725 % 8796093022208})+ , (SEK,Rate {unRate = 5535655776977787 % 562949953421312})+ , (SGD,Rate {unRate = 1821480869289997 % 1125899906842624})+ , (THB,Rate {unRate = 2749236466277155 % 70368744177664})+ , (TRY,Rate {unRate = 5241852196287205 % 1125899906842624})+ , (USD,Rate {unRate = 5519161343342543 % 4503599627370496})+ , (ZAR,Rate {unRate = 8418916553415721 % 562949953421312})+ ]+ }+```
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ exchangerates.cabal view
@@ -0,0 +1,100 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: f5ceb8768f72ccd0d9edecac5641da4d679cc19e8e5244f2d2347a4a9a9c6dbf++name: exchangerates+version: 0.0.0.0+synopsis: A Haskell client for https://exchangeratesapi.io/+description: Please see the README on Github at <https://github.com/NorfairKing/exchangerates#readme>+category: API+homepage: https://github.com/NorfairKing/exchangerates#readme+bug-reports: https://github.com/NorfairKing/exchangerates/issues+author: Tom Sydney Kerckhove+maintainer: syd.kerckhove@gmail.com+copyright: Copyright: (c) 2018 Tom Sydney Kerckhove+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/exchangerates++library+ exposed-modules:+ ExchangeRates+ ExchangeRates.Types+ ExchangeRates.API+ ExchangeRates.Client+ ExchangeRates.Cache+ other-modules:+ Paths_exchangerates+ hs-source-dirs:+ src+ build-depends:+ aeson+ , base >=4.7 && <5+ , containers+ , directory+ , http-api-data+ , http-client+ , http-client-tls+ , mtl+ , servant+ , servant-client+ , stm+ , text+ , time+ , validity >=0.4.0.3+ , validity-containers+ , validity-time+ , yaml+ default-language: Haskell2010++test-suite exchangerates-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ ExchangeRates.Cache.Gen+ ExchangeRates.CacheSpec+ ExchangeRates.Types.Gen+ ExchangeRates.TypesSpec+ TestImport+ Paths_exchangerates+ hs-source-dirs:+ test/+ default-extensions: NoImplicitPrelude+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ QuickCheck+ , aeson+ , base >=4.9 && <=5+ , containers+ , directory+ , exchangerates+ , genvalidity >=0.4.0.4+ , genvalidity-containers+ , genvalidity-hspec+ , genvalidity-hspec-aeson+ , genvalidity-text+ , genvalidity-time+ , hspec+ , http-api-data+ , http-client+ , http-client-tls+ , mtl+ , servant+ , servant-client+ , stm+ , text+ , time+ , validity >=0.4.0.3+ , validity-containers+ , validity-time+ , yaml+ default-language: Haskell2010
+ src/ExchangeRates.hs view
@@ -0,0 +1,32 @@+-- | The top-level API for the Haskell ExchangeRates client.+--+-- There is an example usage in the 'README' file.+module ExchangeRates+ ( FClient+ , autoRunExchangeRatesClient+ , RatesResult(..)+ , getLatest+ , getAtDate+ , withFileCache+ -- * Types+ , Currency(..)+ , Symbols(..)+ , Rate+ , Rates(..)+ , oneRate+ , mulRate+ , divRate+ , rateToDouble+ -- * Re-exports+ -- ** NonEmpty+ , NonEmpty(..)+ -- ** Date+ , Day+ , fromGregorian+ ) where++import Data.List.NonEmpty (NonEmpty(..))+import Data.Time++import ExchangeRates.Client+import ExchangeRates.Types
+ src/ExchangeRates/API.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | The raw API+module ExchangeRates.API+ ( ExchangeRatesAPI+ , exchangeRatesAPI+ , GetLatest+ , GetAtDate+ , getLatest+ , getAtDate+ ) where++import Data.Proxy+import Data.Time+import Servant.API+import Servant.Client++import ExchangeRates.Types++-- | A 'Proxy' for 'ExchangeRatesAPI'+exchangeRatesAPI :: Proxy ExchangeRatesAPI+exchangeRatesAPI = Proxy++-- | The full API at api.exchangeratesapi.io+type ExchangeRatesAPI = GetLatest :<|> GetAtDate++-- | Get latest rates+--+-- @/latest?base=\<base\>&symbols=\<symbols\>@+type GetLatest+ = "latest" :> QueryParam "base" Currency :> QueryParam "symbols" Symbols :> Get '[ JSON] Rates++-- | Get rates on a given date+--+-- @/\<date\>?base=\<base\>&symbols=\<symbols\>@+type GetAtDate+ = Capture "date" Day :> QueryParam "base" Currency :> QueryParam "symbols" Symbols :> Get '[ JSON] Rates++-- | The client function for 'GetLatest'+getLatest :: Maybe Currency -> Maybe Symbols -> ClientM Rates+-- | The client function for 'GetAtDate'+getAtDate :: Day -> Maybe Currency -> Maybe Symbols -> ClientM Rates+getLatest :<|> getAtDate = client exchangeRatesAPI
+ src/ExchangeRates/Cache.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Caches for the raw API+module ExchangeRates.Cache+ ( ExchangeRatesCache(..)+ , insertRates+ , ExchangeRatesCacheResult(..)+ , lookupRates+ , emptyExchangeRatesCache+ , RateCache(..)+ , emptyRateCache+ , insertRatesInCache+ , lookupRatesInCache+ , smartInsertInCache+ , smartLookupRateInCache+ -- Defaults+ , defaultBaseCurrency+ , allSymbolsExcept+ -- Helpers+ , convertToBaseWithRate+ , rawInsertInCache+ , rawLookupInCache+ ) where++import Control.Monad+import Data.Aeson+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Map (Map)+import Data.Maybe+import qualified Data.Set as S+import Data.Set (Set)+import Data.Time+import Data.Validity+import GHC.Generics (Generic)++import ExchangeRates.Types++-- | A complete cache for the raw API.+--+-- This includes a cache for the rates we get, as well as a cache for the+-- rates we do not get.+data ExchangeRatesCache = ExchangeRatesCache+ { fCacheRates :: RateCache+ , fCacheDaysWithoutRates :: Set Day+ } deriving (Show, Eq, Generic)++instance Validity ExchangeRatesCache++instance FromJSON ExchangeRatesCache where+ parseJSON =+ withObject "ExchangeRatesCache" $ \o ->+ ExchangeRatesCache <$> o .: "rates" <*> o .: "days-without-rates"++instance ToJSON ExchangeRatesCache where+ toJSON ExchangeRatesCache {..} =+ object+ [ "rates" .= fCacheRates+ , "days-without-rates" .= fCacheDaysWithoutRates+ ]++-- | Insert a given raw response in a 'ExchangeRatesCache'+insertRates ::+ Day -- ^ The current date+ -> Day -- ^ The requested date+ -> Rates+ -> ExchangeRatesCache+ -> ExchangeRatesCache+insertRates n d r fc+ | ratesDate r == d =+ let rc' = insertRatesInCache r $ fCacheRates fc+ in fc {fCacheRates = rc'}+ | d >= n = fc+ | otherwise =+ let dwr' = S.insert d $ fCacheDaysWithoutRates fc+ in fc {fCacheDaysWithoutRates = dwr'}++-- | The result of looking up rates in a 'ExchangeRatesCache'+data ExchangeRatesCacheResult+ = NotInCache+ | CacheDateNotInPast -- ^ Because we requested a date in the future+ | WillNeverExist -- ^ Because it was on a weekend or holiday+ | InCache Rates+ deriving (Show, Eq, Generic)++instance Validity ExchangeRatesCacheResult++-- | Look up rates in cache+lookupRates ::+ Day -- ^ The current date+ -> Day -- ^ The requested date+ -> Currency+ -> Symbols+ -> ExchangeRatesCache+ -> ExchangeRatesCacheResult+lookupRates n d c s ExchangeRatesCache {..}+ | d >= n = CacheDateNotInPast+ | S.member d fCacheDaysWithoutRates = WillNeverExist+ | otherwise =+ case lookupRatesInCache d c s fCacheRates of+ Nothing -> NotInCache+ Just r -> InCache r++-- | The empty 'ExchangeRatesCache'+emptyExchangeRatesCache :: ExchangeRatesCache+emptyExchangeRatesCache =+ ExchangeRatesCache+ {fCacheRates = emptyRateCache, fCacheDaysWithoutRates = S.empty}++-- | A cache for currency rates+--+-- This cache uses 'EUR' as the base currency, but will still cache+-- rates appropriately if rates with a different base currency are cached.+newtype RateCache = RateCache+ { unRateCache :: Map Day (Map Currency (Map Currency Rate))+ } deriving (Show, Eq, Generic, FromJSON, ToJSON)++instance Validity RateCache where+ validate RateCache {..} =+ mconcat+ [ unRateCache <?!> "unRateCache"+ , let go :: Map Currency (Map Currency Rate) -> Bool+ go m =+ not . or $+ M.mapWithKey (\c m_ -> isJust (M.lookup c m_)) m+ in all go unRateCache <?@>+ "Does not contain conversions to from a currency to itself"+ ]+ isValid = isValidByValidating++-- | The empty Cache+emptyRateCache :: RateCache+emptyRateCache = RateCache M.empty++-- | Insert a rate into the cache as-is.+--+-- You probably want to be using 'insertRatesInCache' or 'smartInsertInCache' instead.+rawInsertInCache ::+ Day -> Currency -> Currency -> Rate -> RateCache -> RateCache+rawInsertInCache d from to rate (RateCache fc) = RateCache $ M.alter go1 d fc+ where+ go1 :: Maybe (Map Currency (Map Currency Rate))+ -> Maybe (Map Currency (Map Currency Rate))+ go1 Nothing = Just $ M.singleton from $ M.singleton to rate+ go1 (Just c1) = Just $ M.alter go2 from c1+ go2 :: Maybe (Map Currency Rate) -> Maybe (Map Currency Rate)+ go2 Nothing = Just $ M.singleton to rate+ go2 (Just c2) = Just $ M.insert to rate c2++-- | Lookup a rate in the cache as-is.+--+-- You probably want to be using 'smartLookupRateInCache' instead.+rawLookupInCache :: Day -> Currency -> Currency -> RateCache -> Maybe Rate+rawLookupInCache d from to (RateCache fc) =+ M.lookup d fc >>= M.lookup from >>= M.lookup to++-- | The default base currency. Currently this is 'EUR'+defaultBaseCurrency :: Currency+defaultBaseCurrency = EUR++-- | The symbols to get by default, given a base currency.+allSymbolsExcept :: Currency -> Symbols+allSymbolsExcept base =+ Symbols $ NE.fromList $ filter (/= base) [minBound .. maxBound]++-- | Insert a result into the cache.+--+-- This is probably the function you want to use, it does all the smartness.+insertRatesInCache :: Rates -> RateCache -> RateCache+insertRatesInCache rs fc =+ if ratesBase rs == defaultBaseCurrency+ then insertRatesAsIs rs+ -- If we're not already using the base, then we need to see if we can figure out how many+ -- of this base we can get for the default base+ -- We can figure this out in two ways:+ -- 1 if the default base is in the rates+ else case M.lookup defaultBaseCurrency $ ratesRates rs of+ Just r -> insertRatesAtOtherBase r rs+ Nothing+ -- or+ -- 2 if the default base is in the cache+ ->+ case rawLookupInCache+ (ratesDate rs)+ (ratesBase rs)+ defaultBaseCurrency+ fc of+ Just r -> insertRatesAtOtherBase r rs+ Nothing+ -- If we find neither, then we just save in the cache as-is+ -> insertRatesAsIs rs+ where+ insertRatesAsIs :: Rates -> RateCache+ insertRatesAsIs rates =+ M.foldlWithKey (go (ratesBase rates)) fc $ ratesRates rates+ insertRatesAtOtherBase :: Rate -> Rates -> RateCache+ insertRatesAtOtherBase r =+ insertRatesAsIs . convertToBaseWithRate defaultBaseCurrency r+ go :: Currency -> RateCache -> Currency -> Rate -> RateCache+ go base fc_ c r = smartInsertInCache (ratesDate rs) base c r fc_++-- | Insert a rate in a cache, but don't insert it if the from and to currencies are the same.+smartInsertInCache ::+ Day -> Currency -> Currency -> Rate -> RateCache -> RateCache+smartInsertInCache date from to rate fc =+ if from == to+ then fc+ else rawInsertInCache date from to rate fc++-- | Look up multiple rates in a cache.+--+-- This function uses 'smartLookupRateInCache' for each requested symbol.+lookupRatesInCache :: Day -> Currency -> Symbols -> RateCache -> Maybe Rates+lookupRatesInCache date base (Symbols nec) fc =+ Rates base date <$>+ (M.fromList <$>+ mapM+ (\to -> (,) to <$> smartLookupRateInCache date base to fc)+ (NE.filter (/= base) nec))++-- | Look up a rate in a cache.+--+-- This function will try to be smart about what it can find, but will+-- give up after one redirection.+smartLookupRateInCache :: Day -> Currency -> Currency -> RateCache -> Maybe Rate+smartLookupRateInCache date from to fc@(RateCache m) =+ if from == to+ then Just oneRate+ else case rawLookupInCache date from to fc of+ Just r -> pure r+ -- First try to look up at the correct base currency+ -- If that works, return it.+ -- Otherwise, try all the other bases at that day, and convert if necessary.+ Nothing -> do+ dm <- M.lookup date m+ msum $+ M.elems $+ flip M.mapWithKey dm $ \newFrom nfm ->+ lookupVia newFrom from to nfm++lookupVia :: Currency -> Currency -> Currency -> Map Currency Rate -> Maybe Rate+lookupVia newFrom from to nfm = do+ nfr <-+ if newFrom == from+ then Just oneRate+ else M.lookup from nfm+ -- This is the rate at which we can convert from newFrom to from+ -- for each 'from', you get '1/nfr' newFroms+ tr <-+ if newFrom == to+ then Just oneRate+ else M.lookup to nfm+ -- This is the rate at which we can convert from newFrom to to+ pure $ divRate tr nfr++-- | Convert a set of rates to another base currency with the given rate of the new base currency+-- with respect to the old base currency.+-- In the map, we have the info that+-- for 1 base currency, you get s of the currency in the key.+--+-- If we now say that for 1 of the old base currency, you can get+-- r of the new base currency+--+-- This rate means for one of the new base currency, you can get s / r of+-- the currency in the key.+convertToBaseWithRate :: Currency -> Rate -> Rates -> Rates+convertToBaseWithRate new rate rs =+ if ratesBase rs == new+ then rs+ else rs {ratesBase = new, ratesRates = newRates}+ where+ newRates =+ M.map (`divRate` rate) . withOldBase . withoutNewBase $ ratesRates rs+ withOldBase = M.insert (ratesBase rs) oneRate+ withoutNewBase = M.delete new
+ src/ExchangeRates/Client.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-}++-- | The transparently caching client+module ExchangeRates.Client+ ( autoRunExchangeRatesClient+ , defaultConfig+ , runExchangeRatesClient+ , FClient+ , getLatest+ , getAtDate+ , RatesResult(..)+ , withFileCache+ , readCacheFromFileIfExists+ , flushCacheToFile+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Reader+import Data.Maybe+import Data.Time+import Data.Validity+import qualified Data.Yaml as Yaml+import GHC.Generics+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Servant.Client+import System.Directory (doesFileExist)+import System.Exit (die)++import qualified ExchangeRates.API as Raw+import ExchangeRates.Cache+import ExchangeRates.Types++-- | A client function+newtype FClient a = FClient+ { runFClient :: ReaderT FEnv ClientM a+ } deriving (Functor, Applicative, Monad, MonadReader FEnv, MonadIO)++data FEnv = FEnv+ { fEnvConfig :: Config+ , fEnvLastFetch :: TVar (Maybe UTCTime)+ , fEnvCache :: TVar ExchangeRatesCache+ } deriving (Generic)++newtype Config = Config+ { confRateDelay :: Int -- ^ Microseconds+ } deriving (Show, Eq, Generic)++-- | Run a 'FClient' action and figure out the 'ClientEnv' and 'ExchangeRatesCache'+-- arguments automatically.+--+-- This is probably the function you want to use+autoRunExchangeRatesClient :: FClient a -> IO (Either ServantError a)+autoRunExchangeRatesClient func = do+ man <- newManager tlsManagerSettings+ burl <- parseBaseUrl "https://exchangeratesapi.io/api"+ env <- makeEnv+ runExchangeRatesClient env (ClientEnv man burl Nothing) func++makeEnv :: IO FEnv+makeEnv = do+ lastFetchVar <- newTVarIO Nothing+ cacheVar <- newTVarIO emptyExchangeRatesCache+ pure+ FEnv+ { fEnvConfig = defaultConfig+ , fEnvLastFetch = lastFetchVar+ , fEnvCache = cacheVar+ }++-- | A default configuration for the client: One second of delay between calls+defaultConfig :: Config+defaultConfig =+ Config+ { confRateDelay = 1 * microsecondsPerSecond -- One second+ }++-- | Run a 'FClient' action with full control over the inputs.+runExchangeRatesClient ::+ FEnv -> ClientEnv -> FClient a -> IO (Either ServantError a)+runExchangeRatesClient env ce func =+ runClientM (runReaderT (runFClient func) env) ce++-- | Get the latest rates.+--+-- Note that this function fetches the latest rates, but that does not mean+-- that the latest symbols appeared on the current date. However, there is no+-- way to predict what date the last rates appeared on, so we still look in the+-- cache at the current date. For maximum cache hits, use 'getAtDate' and only+-- look at the past beyond the last three days.+getLatest :: Maybe Currency -> Maybe Symbols -> FClient RatesResult+getLatest mc ms = do+ date <- liftIO $ utctDay <$> getCurrentTime+ withCacheAndRate date mc ms $ Raw.getLatest mc ms++-- | Get the rates at a specific date.+getAtDate :: Day -> Maybe Currency -> Maybe Symbols -> FClient RatesResult+getAtDate date mc ms = withCacheAndRate date mc ms $ Raw.getAtDate date mc ms++microsecondsPerSecond :: Int+microsecondsPerSecond = 1000 * 1000++-- | The result of calling the API the local cache+data RatesResult+ = DateNotInPast -- ^ because you tried to call the API for a future date+ | RateDoesNotExist -- ^ because the date is on a weekend, for example+ | RatesFound Rates+ deriving (Show, Eq, Generic)++instance Validity RatesResult++withCacheAndRate ::+ Day+ -> Maybe Currency+ -> Maybe Symbols+ -> ClientM Rates+ -> FClient RatesResult+withCacheAndRate requestDate mc ms func = do+ let base = fromMaybe defaultBaseCurrency mc+ let symbols = fromMaybe (allSymbolsExcept base) ms+ cacheVar <- asks fEnvCache+ now <- liftIO getCurrentTime+ let nowDate = utctDay now+ c <- liftIO $ readTVarIO cacheVar+ case lookupRates nowDate requestDate base symbols c of+ NotInCache -> do+ rates <- rateLimit func+ liftIO $+ atomically $+ modifyTVar' cacheVar (insertRates nowDate requestDate rates)+ pure $+ if ratesDate rates == requestDate+ then RatesFound rates+ else if ratesDate rates >= nowDate+ then DateNotInPast+ else RateDoesNotExist+ CacheDateNotInPast -> pure DateNotInPast+ WillNeverExist -> pure RateDoesNotExist+ InCache r -> pure $ RatesFound r++rateLimit :: ClientM a -> FClient a+rateLimit func = do+ now <- liftIO getCurrentTime+ lastFetchVar <- asks fEnvLastFetch+ mLastFetch <- liftIO $ readTVarIO lastFetchVar+ delayTime <- asks $ confRateDelay . fEnvConfig+ let timeToWait =+ max 0 $+ case mLastFetch of+ Nothing -> 0+ Just lastFetch ->+ let timeSinceLastFetch = diffUTCTime now lastFetch+ timeSinceLastFetchMicro =+ round+ (realToFrac timeSinceLastFetch *+ fromIntegral microsecondsPerSecond :: Double)+ in delayTime - timeSinceLastFetchMicro+ -- Wait+ liftIO $ threadDelay timeToWait+ -- Make the request+ res <- FClient $ lift func+ after <- liftIO getCurrentTime+ liftIO $ atomically $ writeTVar lastFetchVar $ Just after+ pure res++-- | Declare that we want to use the given file as a persistent cache.+--+-- Note that 'FClient' will still use a per-run cache if this function is not used.+-- This function only makes sure that the cache is persistent accross runs.+--+-- > withFileCache path func = do+-- > readCacheFromFileIfExists path+-- > r <- func+-- > flushCacheToFile path+-- > pure r+withFileCache :: FilePath -> FClient a -> FClient a+withFileCache path func = do+ readCacheFromFileIfExists path+ r <- func+ flushCacheToFile path+ pure r++-- | Read a persistent cache from the given file if that file exists.+readCacheFromFileIfExists :: FilePath -> FClient ()+readCacheFromFileIfExists fp = do+ fe <- liftIO $ doesFileExist fp+ mfc <-+ if fe+ then liftIO $ do+ errOrRes <- Yaml.decodeFileEither fp+ case errOrRes of+ Left e ->+ die $+ unlines ["Failed to read cache file YAML:", show e]+ Right r -> pure r+ else pure Nothing+ case mfc of+ Nothing -> pure ()+ Just fc -> do+ cacheVar <- asks fEnvCache+ liftIO $ atomically $ writeTVar cacheVar fc++-- | Flush the currently gathered cache to the given file.+flushCacheToFile :: FilePath -> FClient ()+flushCacheToFile fp = do+ cacheVar <- asks fEnvCache+ liftIO $ do+ cache <- readTVarIO cacheVar+ Yaml.encodeFile fp cache
+ src/ExchangeRates/Types.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Types for the API+module ExchangeRates.Types+ ( Rate(..)+ , oneRate+ , mulRate+ , divRate+ , normaliseRate+ , rateToRational+ , rateToDouble+ , Currency(..)+ , Symbols(..)+ , Rates(..)+ ) where++import Control.Applicative+import Data.Aeson as JSON+import Data.Aeson.Types as JSON+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Ratio+import qualified Data.Text as T+import Data.Text (Text)+import Data.Time+import Data.Validity+import Data.Validity.Containers ()+import Data.Validity.Time ()+import GHC.Generics (Generic)+import GHC.Natural+import GHC.Real (Ratio(..))+import Servant.API+import Text.Read++-- | A positive and non-0 ratio+newtype Rate = Rate+ { unRate :: Ratio Natural+ } deriving (Show, Eq, Generic)++-- | The identity of 'mulRate'+oneRate :: Rate+oneRate = Rate 1++-- | Multiply two rates+mulRate :: Rate -> Rate -> Rate+mulRate (Rate r1) (Rate r2) = normaliseRate $ Rate (r1 * r2)++-- | Divide one rate by another+divRate :: Rate -> Rate -> Rate+divRate (Rate r1) (Rate r2) = normaliseRate $ Rate (r1 / r2)++-- | Ensure that a rate is internally normalised.+-- This is a requirement for 'Validity'+normaliseRate :: Rate -> Rate+normaliseRate = Rate . fromRational . toRational . unRate++-- | Convert a rate to a 'Ratio Integer' instead of 'Ratio Natural'.+--+-- This is a lossless transformation.+rateToRational :: Rate -> Rational+rateToRational (Rate (num :% den)) = fromIntegral num :% fromIntegral den++-- | Convert a rate to a 'Double'.+--+-- This may not be a lossless transformation+rateToDouble :: Rate -> Double+rateToDouble = fromRational . rateToRational++-- | A rate is valid if:+--+-- * The ratio inside is valid.+-- * The ratio is not zero.+-- * The ratio is normalised.+instance Validity Rate where+ validate r@Rate {..} =+ mconcat+ [ unRate <?!> "unRate"+ , (numerator unRate /= 0) <?@> "ratio is not 0"+ , (normaliseRate r == r) <?@> "is normalised"+ ]+ isValid = isValidByValidating++instance FromJSON Rate where+ parseJSON v =+ (Rate <$> parseJSON v) <|>+ -- First try to parse as a ratio+ (do d <- parseJSON v :: JSON.Parser Double+ -- The api has a precision of 0.0001.+ let r@(num :% den) = toRational d+ if r == 0+ then fail "Failed to parse zero rate"+ else pure $+ normaliseRate $+ Rate $ naturalFromInteger num % naturalFromInteger den)++instance ToJSON Rate where+ toJSON = toJSON . unRate++-- | A sum-type of the supported currencies on exchangeratesapi.io+data Currency+ = AUD+ | BGN+ | BRL+ | CAD+ | CHF+ | CNY+ | CZK+ | DKK+ | EUR+ | GBP+ | HKD+ | HRK+ | HUF+ | IDR+ | ILS+ | INR+ | JPY+ | KRW+ | MXN+ | MYR+ | NOK+ | NZD+ | PHP+ | PLN+ | RON+ | RUB+ | SEK+ | SGD+ | THB+ | TRY+ | USD+ | ZAR+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)++instance Validity Currency++instance ToHttpApiData Currency where+ toUrlPiece = currencyToText++-- | A nonempty list of 'Currency's+newtype Symbols = Symbols+ { unSymbols :: NonEmpty Currency+ } deriving (Show, Eq, Ord, Generic)++instance Validity Symbols++instance ToHttpApiData Symbols where+ toUrlPiece = T.intercalate "," . map toUrlPiece . NE.toList . unSymbols++-- | The raw response of exchangeratesapi.io+data Rates = Rates+ { ratesBase :: Currency+ , ratesDate :: Day+ , ratesRates :: Map Currency Rate+ } deriving (Show, Eq, Generic)++instance Validity Rates where+ validate Rates {..} =+ mconcat+ [ ratesBase <?!> "ratesBase"+ , ratesDate <?!> "ratesDate"+ , ratesRates <?!> "ratesRates"+ , isNothing (M.lookup ratesBase ratesRates) <?@>+ "does not contain the base rate in the rates."+ ]+ isValid = isValidByValidating++instance FromJSON Currency where+ parseJSON = withText "Currency" currencyTextParser++instance FromJSONKey Currency where+ fromJSONKey = FromJSONKeyTextParser currencyTextParser++currencyTextParser :: Text -> JSON.Parser Currency+currencyTextParser t =+ let s = T.unpack t+ in case readMaybe s of+ Nothing -> fail $ "Not a valid currency: " ++ s+ Just c -> pure c++instance ToJSON Currency where+ toJSON = JSON.String . currencyToText++instance ToJSONKey Currency where+ toJSONKey = toJSONKeyText currencyToText++currencyToText :: Currency -> Text+currencyToText = T.pack . show++instance FromJSON Rates where+ parseJSON =+ withObject "Rates" $ \o ->+ Rates <$> o .: "base" <*> o .: "date" <*> o .: "rates"
+ test/ExchangeRates/Cache/Gen.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ExchangeRates.Cache.Gen where++import TestImport++import ExchangeRates.Types.Gen ()++import ExchangeRates.Cache++instance GenUnchecked ExchangeRatesCache++instance GenValid ExchangeRatesCache where+ genValid = ExchangeRatesCache <$> genValid <*> genValid++instance GenUnchecked ExchangeRatesCacheResult++instance GenValid ExchangeRatesCacheResult++instance GenUnchecked RateCache++instance GenValid RateCache where+ genValid = (RateCache <$> genValid) `suchThat` isValid
+ test/ExchangeRates/CacheSpec.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE TypeApplications #-}++module ExchangeRates.CacheSpec+ ( spec+ ) where++import TestImport++import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Map as M++import ExchangeRates.Cache+import ExchangeRates.Types++import ExchangeRates.Cache.Gen ()+import ExchangeRates.Types.Gen ()++spec :: Spec+spec = do+ rateCacheSpec+ exchangeRatesCacheSpec++rateCacheSpec :: Spec+rateCacheSpec = do+ eqSpecOnValid @RateCache+ genValidSpec @RateCache+ jsonSpecOnValid @RateCache+ describe "rawInsertInCache" $+ it "produces valid caches if the currencies are distinct" $+ forAllValid $ \d ->+ forAllValid $ \c1 ->+ forAll (genValid `suchThat` (/= c1)) $ \c2 ->+ forAllValid $ \r ->+ producesValidsOnValids $ rawInsertInCache d c1 c2 r+ describe "rawLookupInCache" $ do+ it "produces valid rates" $+ producesValidsOnValids3 (uncurry rawLookupInCache)+ it "finds what was just put there" $+ forAllValid $ \d ->+ forAllValid $ \c1 ->+ forAllValid $ \c2 ->+ forAllValid $ \r ->+ forAllValid $ \fc ->+ let fc' = rawInsertInCache d c1 c2 r fc+ in rawLookupInCache d c1 c2 fc' `shouldBe`+ Just r+ describe "defaultBaseCurrency" $+ it "is valid" $ shouldBeValid defaultBaseCurrency+ describe "allSymbols" $+ it "is valid" $ producesValidsOnValids allSymbolsExcept+ describe "insertRatesInCache" $+ it "produces valid caches" $+ forAllValid $ \rates ->+ producesValidsOnValids $ insertRatesInCache rates+ describe "smartLookupRateInCache" $ do+ it "produces valid rates" $+ forAllValid $ \date ->+ forAllValid $ \from ->+ forAllValid $ \to ->+ producesValidsOnValids $+ smartLookupRateInCache date from to+ it+ "finds the same as rawLookupInCache if rawLookupInCache finds a result" $+ forAllValid $ \date ->+ forAllValid $ \from ->+ forAllValid $ \to ->+ equivalentWhenSucceedOnValid+ (rawLookupInCache date from to)+ (smartLookupRateInCache date from to)+ it "succesfully lookups up a rate that is cached in reverse" $+ forAllValid $ \date ->+ forAllValid $ \from ->+ forAllValid $ \to ->+ forAllValid $ \rate ->+ forAllValid $ \fc ->+ unless (from == to) $ do+ let fc' =+ smartInsertInCache+ date+ from+ to+ rate+ fc+ shouldBeValid fc'+ smartLookupRateInCache date to from fc' `shouldBe`+ (Just $ divRate oneRate rate)+ describe "lookupRatesInCache" $ do+ it "produces valid caches" $+ forAllValid $ \date ->+ forAllValid $ \base ->+ forAllValid $ \symbols ->+ producesValidsOnValids $+ lookupRatesInCache date base symbols+ it "works for a cache with a single rate" $+ forAllValid $ \date ->+ forAllValid $ \base ->+ forAll (genValid `suchThat` (/= base)) $ \symbol ->+ forAllValid $ \rate ->+ let cache =+ RateCache+ { unRateCache =+ M.fromList+ [ ( date+ , M.fromList+ [ ( base+ , M.fromList+ [ ( symbol+ , rate)+ ])+ ])+ ]+ }+ rates =+ Rates+ { ratesBase = base+ , ratesDate = date+ , ratesRates =+ M.fromList [(symbol, rate)]+ }+ in lookupRatesInCache+ date+ base+ (Symbols $ symbol :| [])+ cache `shouldBe`+ Just rates+ it+ "finds the rates that were just added with insertRatesInCache when adding at the default base currency" $+ forAllValid $ \rates' ->+ forAllValid $ \fc ->+ let rates =+ rates'+ { ratesBase = defaultBaseCurrency+ , ratesRates =+ M.delete defaultBaseCurrency $+ ratesRates rates'+ }+ fc' = insertRatesInCache rates fc+ in case NE.nonEmpty (M.keys $ ratesRates rates) of+ Nothing -> pure () -- Fine+ Just symbols ->+ lookupRatesInCache+ (ratesDate rates)+ (ratesBase rates)+ (Symbols symbols)+ fc' `shouldBe`+ Just rates+ it "finds the rates that were just added with insertRatesInCache" $+ forAllValid $ \rates ->+ forAllValid $ \fc ->+ let fc' = insertRatesInCache rates fc+ in case NE.nonEmpty (M.keys $ ratesRates rates) of+ Nothing -> pure () -- Fine+ Just symbols ->+ lookupRatesInCache+ (ratesDate rates)+ (ratesBase rates)+ (Symbols symbols)+ fc' `shouldBe`+ Just rates+ describe "convertToBaseWithRate" $ do+ it "produces valid caches" $+ forAllValid $ \base ->+ forAllValid $ \rate ->+ producesValidsOnValids $ convertToBaseWithRate base rate+ it+ "converts the rates such that the new base has a 1-to-rate conversion with the old base" $+ forAllValid $ \base ->+ forAllValid $ \rate ->+ forAllValid $ \rates ->+ unless (base == ratesBase rates) $+ let rates' =+ rates+ { ratesRates =+ M.insert base rate $ ratesRates rates+ }+ rates'' = convertToBaseWithRate base rate rates'+ in M.lookup (ratesBase rates) (ratesRates rates'') `shouldBe`+ Just (divRate oneRate rate)++exchangeRatesCacheSpec :: Spec+exchangeRatesCacheSpec = do+ eqSpecOnValid @ExchangeRatesCache+ genValidSpec @ExchangeRatesCache+ jsonSpecOnValid @ExchangeRatesCache+ describe "insertRates" $+ it "produces valid caches" $+ forAllValid $ \d -> producesValidsOnValids3 $ insertRates d+ describe "lookupRates" $+ it "produces valid results" $+ forAllValid $ \dn ->+ forAllValid $ \dr -> producesValidsOnValids3 $ lookupRates dn dr
+ test/ExchangeRates/Types/Gen.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ExchangeRates.Types.Gen where++import TestImport++import Numeric.Natural++import ExchangeRates.Types++-- Until genvalidity has these.+instance GenUnchecked Natural where+ genUnchecked = fromInteger . abs <$> genValid -- Cannot even generate wrong ones+ shrinkUnchecked _ = []++instance GenValid Natural where+ genValid = fromInteger . abs <$> genValid++instance GenUnchecked Rate++instance GenValid Rate where+ genValid = (Rate <$> genValid) `suchThat` isValid++instance GenUnchecked Currency++instance GenValid Currency++instance GenUnchecked Symbols++instance GenValid Symbols where+ genValid = Symbols <$> genValid++instance GenUnchecked Rates++instance GenValid Rates where+ genValid = (Rates <$> genValid <*> genValid <*> genValid) `suchThat` isValid
+ test/ExchangeRates/TypesSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TypeApplications #-}++module ExchangeRates.TypesSpec+ ( spec+ ) where++import TestImport++import Data.Ratio++import ExchangeRates.Types++import ExchangeRates.Types.Gen ()++spec :: Spec+spec = do+ eqSpec @Rate+ genValidSpec @Rate+ jsonSpecOnValid @Rate+ describe "Rate" $ do+ describe "oneRate" $ it "is a valid rate" $ shouldBeValid oneRate+ specify "0 % x is an invalid rate" $+ forAllValid $ \n -> Rate (0 % (n + 1)) `shouldNotSatisfy` isValid+ describe "normaliseRate" $+ it "produces valid rates" $ producesValidsOnValids normaliseRate+ describe "mulRate" $+ it "produces valid rates" $ producesValidsOnValids2 mulRate+ describe "divRate" $+ it "produces valid rates" $ producesValidsOnValids2 divRate+ eqSpec @Currency+ genValidSpec @Currency+ jsonSpecOnValid @Currency+ eqSpec @Symbols+ genValidSpec @Symbols+ eqSpec @Rates+ genValidSpec @Rates
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,19 @@+module TestImport+ ( module X+ ) where++import Debug.Trace as X+import Prelude as X hiding (head, init, last, tail)++import Data.Maybe as X++import Control.Monad as X++import Test.Hspec as X+import Test.QuickCheck as X+import Test.Validity as X+import Test.Validity.Aeson as X++import Data.GenValidity.Containers as X+import Data.GenValidity.Text as X ()+import Data.GenValidity.Time as X ()