diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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}) + ] + } +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/exchangerates.cabal b/exchangerates.cabal new file mode 100644 --- /dev/null +++ b/exchangerates.cabal @@ -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 +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 diff --git a/src/ExchangeRates.hs b/src/ExchangeRates.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeRates.hs @@ -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 diff --git a/src/ExchangeRates/API.hs b/src/ExchangeRates/API.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeRates/API.hs @@ -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=\&symbols=\@ +type GetLatest + = "latest" :> QueryParam "base" Currency :> QueryParam "symbols" Symbols :> Get '[ JSON] Rates + +-- | Get rates on a given date +-- +-- @/\?base=\&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 diff --git a/src/ExchangeRates/Cache.hs b/src/ExchangeRates/Cache.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeRates/Cache.hs @@ -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 diff --git a/src/ExchangeRates/Client.hs b/src/ExchangeRates/Client.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeRates/Client.hs @@ -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 diff --git a/src/ExchangeRates/Types.hs b/src/ExchangeRates/Types.hs new file mode 100644 --- /dev/null +++ b/src/ExchangeRates/Types.hs @@ -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" diff --git a/test/ExchangeRates/Cache/Gen.hs b/test/ExchangeRates/Cache/Gen.hs new file mode 100644 --- /dev/null +++ b/test/ExchangeRates/Cache/Gen.hs @@ -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 diff --git a/test/ExchangeRates/CacheSpec.hs b/test/ExchangeRates/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExchangeRates/CacheSpec.hs @@ -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 diff --git a/test/ExchangeRates/Types/Gen.hs b/test/ExchangeRates/Types/Gen.hs new file mode 100644 --- /dev/null +++ b/test/ExchangeRates/Types/Gen.hs @@ -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 diff --git a/test/ExchangeRates/TypesSpec.hs b/test/ExchangeRates/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExchangeRates/TypesSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 --- /dev/null +++ b/test/TestImport.hs @@ -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 ()