module Fixer.Cache
( FixerCache(..)
, insertRates
, FixerCacheResult(..)
, lookupRates
, emptyFixerCache
, RateCache(..)
, emptyRateCache
, insertRatesInCache
, lookupRatesInCache
, smartInsertInCache
, smartLookupRateInCache
, defaultBaseCurrency
, allSymbolsExcept
, 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 Fixer.Types
data FixerCache = FixerCache
{ fCacheRates :: RateCache
, fCacheDaysWithoutRates :: Set Day
} deriving (Show, Eq, Generic)
instance Validity FixerCache
instance FromJSON FixerCache where
parseJSON =
withObject "FixerCache" $ \o ->
FixerCache <$> o .: "rates" <*> o .: "days-without-rates"
instance ToJSON FixerCache where
toJSON FixerCache {..} =
object
[ "rates" .= fCacheRates
, "days-without-rates" .= fCacheDaysWithoutRates
]
insertRates ::
Day
-> Day
-> Rates
-> FixerCache
-> FixerCache
insertRates n d r fc =
if ratesDate r == d
then let rc' = insertRatesInCache r $ fCacheRates fc
in fc {fCacheRates = rc'}
else if d >= n
then fc
else let dwr' = S.insert d $ fCacheDaysWithoutRates fc
in fc {fCacheDaysWithoutRates = dwr'}
data FixerCacheResult
= NotInCache
| CacheDateNotInPast
| WillNeverExist
| InCache Rates
deriving (Show, Eq, Generic)
instance Validity FixerCacheResult
lookupRates ::
Day
-> Day
-> Currency
-> Symbols
-> FixerCache
-> FixerCacheResult
lookupRates n d c s FixerCache {..} =
if d >= n
then CacheDateNotInPast
else if S.member d fCacheDaysWithoutRates
then WillNeverExist
else case lookupRatesInCache d c s fCacheRates of
Nothing -> NotInCache
Just r -> InCache r
emptyFixerCache :: FixerCache
emptyFixerCache =
FixerCache {fCacheRates = emptyRateCache, fCacheDaysWithoutRates = S.empty}
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
emptyRateCache :: RateCache
emptyRateCache = RateCache M.empty
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
rawLookupInCache :: Day -> Currency -> Currency -> RateCache -> Maybe Rate
rawLookupInCache d from to (RateCache fc) =
M.lookup d fc >>= M.lookup from >>= M.lookup to
defaultBaseCurrency :: Currency
defaultBaseCurrency = EUR
allSymbolsExcept :: Currency -> Symbols
allSymbolsExcept base =
Symbols $ NE.fromList $ filter (/= base) [minBound .. maxBound]
insertRatesInCache :: Rates -> RateCache -> RateCache
insertRatesInCache rs fc =
if ratesBase rs == defaultBaseCurrency
then insertRatesAsIs rs
else case M.lookup defaultBaseCurrency $ ratesRates rs of
Just r -> insertRatesAtOtherBase r rs
Nothing
->
case rawLookupInCache
(ratesDate rs)
(ratesBase rs)
defaultBaseCurrency
fc of
Just r -> insertRatesAtOtherBase r rs
Nothing
-> 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_
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
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))
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
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
tr <-
if newFrom == to
then Just oneRate
else M.lookup to nfm
pure $ divRate tr nfr
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