{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Hledger.StockQuotes
( getCommoditiesAndDateRange
, fetchPrices
, makePriceDirectives
, GenericPrice(..)
, getClosePrice
)
where
import Control.Concurrent ( threadDelay )
import Control.Exception ( SomeException
, displayException
, try
)
import Data.Bifunctor ( second )
import Data.List.Split ( chunksOf )
import Data.Maybe ( catMaybes )
import Data.Scientific ( Scientific )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Time ( Day
, UTCTime(utctDay)
, defaultTimeLocale
, formatTime
, fromGregorian
, getCurrentTime
, toGregorian
)
import Hledger
import Safe.Foldable ( maximumMay
, minimumMay
)
import System.IO ( hPutStrLn
, stderr
)
import Web.AlphaVantage ( AlphaVantageResponse(..)
, Config
, CryptoPrices(..)
, Prices(..)
, getDailyCryptoPrices
, getDailyPrices
)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Text as T
getCommoditiesAndDateRange
:: [T.Text] -> FilePath -> IO ([CommoditySymbol], Day, Day)
getCommoditiesAndDateRange :: [Text] -> FilePath -> IO ([Text], Day, Day)
getCommoditiesAndDateRange [Text]
excluded FilePath
journalPath = do
Journal
journal <- (FilePath -> Journal)
-> (Journal -> Journal) -> Either FilePath Journal -> Journal
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Journal
forall a. HasCallStack => FilePath -> a
error Journal -> Journal
forall a. a -> a
id (Either FilePath Journal -> Journal)
-> IO (Either FilePath Journal) -> IO Journal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputOpts -> FilePath -> IO (Either FilePath Journal)
readJournalFile InputOpts
definputopts FilePath
journalPath
UTCTime
currentTime <- IO UTCTime
getCurrentTime
let commodities :: [Text]
commodities =
(Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
excluded)
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text Commodity -> [Text]
forall k a. Map k a -> [k]
M.keys (Journal -> Map Text Commodity
jcommodities Journal
journal)
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Map Text AmountStyle -> [Text]
forall k a. Map k a -> [k]
M.keys (Journal -> Map Text AmountStyle
jinferredcommodities Journal
journal)
dates :: [Day]
dates = (Transaction -> Day) -> [Transaction] -> [Day]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Day
tdate ([Transaction] -> [Day]) -> [Transaction] -> [Day]
forall a b. (a -> b) -> a -> b
$ Journal -> [Transaction]
jtxns Journal
journal
currentYear :: Integer
currentYear = (\(Integer
y, Int
_, Int
_) -> Integer
y) ((Integer, Int, Int) -> Integer) -> (Integer, Int, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian (Day -> (Integer, Int, Int)) -> Day -> (Integer, Int, Int)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
currentTime
minDate :: Day
minDate = case [Day] -> Maybe Day
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Maybe a
minimumMay [Day]
dates of
Just Day
d -> Day
d
Maybe Day
Nothing -> Integer -> Int -> Int -> Day
fromGregorian Integer
currentYear Int
1 Int
1
maxDate :: Day
maxDate = case [Day] -> Maybe Day
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Maybe a
maximumMay [Day]
dates of
Just Day
d -> Day
d
Maybe Day
Nothing -> UTCTime -> Day
utctDay UTCTime
currentTime
([Text], Day, Day) -> IO ([Text], Day, Day)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Eq a => [a] -> [a]
L.nub [Text]
commodities, Day
minDate, Day
maxDate)
fetchPrices
:: Config
-> [CommoditySymbol]
-> [T.Text]
-> Day
-> Day
-> Bool
-> IO [(CommoditySymbol, [(Day, GenericPrice)])]
fetchPrices :: Config
-> [Text]
-> [Text]
-> Day
-> Day
-> Bool
-> IO [(Text, [(Day, GenericPrice)])]
fetchPrices Config
cfg [Text]
symbols [Text]
cryptoCurrencies Day
start Day
end Bool
rateLimit = do
let ([Text]
stockSymbols, [Text]
cryptoSymbols) =
(Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
cryptoCurrencies) [Text]
symbols
genericAction :: [AlphaRequest]
genericAction =
(Text -> AlphaRequest) -> [Text] -> [AlphaRequest]
forall a b. (a -> b) -> [a] -> [b]
map Text -> AlphaRequest
FetchStock [Text]
stockSymbols [AlphaRequest] -> [AlphaRequest] -> [AlphaRequest]
forall a. Semigroup a => a -> a -> a
<> (Text -> AlphaRequest) -> [Text] -> [AlphaRequest]
forall a b. (a -> b) -> [a] -> [b]
map Text -> AlphaRequest
FetchCrypto [Text]
cryptoSymbols
if Bool
rateLimit
then ([Maybe (Text, [(Day, GenericPrice)])]
-> [(Text, [(Day, GenericPrice)])])
-> IO [Maybe (Text, [(Day, GenericPrice)])]
-> IO [(Text, [(Day, GenericPrice)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Text, [(Day, GenericPrice)])]
-> [(Text, [(Day, GenericPrice)])]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (Text, [(Day, GenericPrice)])]
-> IO [(Text, [(Day, GenericPrice)])])
-> IO [Maybe (Text, [(Day, GenericPrice)])]
-> IO [(Text, [(Day, GenericPrice)])]
forall a b. (a -> b) -> a -> b
$ [IO (Maybe (Text, [(Day, GenericPrice)]))]
-> IO [Maybe (Text, [(Day, GenericPrice)])]
forall a. [IO a] -> IO [a]
rateLimitActions ([IO (Maybe (Text, [(Day, GenericPrice)]))]
-> IO [Maybe (Text, [(Day, GenericPrice)])])
-> [IO (Maybe (Text, [(Day, GenericPrice)]))]
-> IO [Maybe (Text, [(Day, GenericPrice)])]
forall a b. (a -> b) -> a -> b
$ (AlphaRequest -> IO (Maybe (Text, [(Day, GenericPrice)])))
-> [AlphaRequest] -> [IO (Maybe (Text, [(Day, GenericPrice)]))]
forall a b. (a -> b) -> [a] -> [b]
map AlphaRequest -> IO (Maybe (Text, [(Day, GenericPrice)]))
fetch [AlphaRequest]
genericAction
else [Maybe (Text, [(Day, GenericPrice)])]
-> [(Text, [(Day, GenericPrice)])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, [(Day, GenericPrice)])]
-> [(Text, [(Day, GenericPrice)])])
-> IO [Maybe (Text, [(Day, GenericPrice)])]
-> IO [(Text, [(Day, GenericPrice)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AlphaRequest -> IO (Maybe (Text, [(Day, GenericPrice)])))
-> [AlphaRequest] -> IO [Maybe (Text, [(Day, GenericPrice)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AlphaRequest -> IO (Maybe (Text, [(Day, GenericPrice)]))
fetch [AlphaRequest]
genericAction
where
fetch :: AlphaRequest -> IO (Maybe (CommoditySymbol, [(Day, GenericPrice)]))
fetch :: AlphaRequest -> IO (Maybe (Text, [(Day, GenericPrice)]))
fetch AlphaRequest
req = do
(Text
symbol, FilePath
label, Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])
resp) <- case AlphaRequest
req of
FetchStock Text
symbol ->
(Text
symbol, FilePath
"Stock", )
(Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])
-> (Text, FilePath,
Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])))
-> IO
(Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
-> IO
(Text, FilePath,
Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (AlphaVantageResponse [(Day, GenericPrice)])
-> IO
(Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
forall e a. Exception e => IO a -> IO (Either e a)
try
( ([(Day, Prices)] -> [(Day, GenericPrice)])
-> AlphaVantageResponse [(Day, Prices)]
-> AlphaVantageResponse [(Day, GenericPrice)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Day, Prices) -> (Day, GenericPrice))
-> [(Day, Prices)] -> [(Day, GenericPrice)]
forall a b. (a -> b) -> [a] -> [b]
map ((Prices -> GenericPrice) -> (Day, Prices) -> (Day, GenericPrice)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Prices -> GenericPrice
Stock))
(AlphaVantageResponse [(Day, Prices)]
-> AlphaVantageResponse [(Day, GenericPrice)])
-> IO (AlphaVantageResponse [(Day, Prices)])
-> IO (AlphaVantageResponse [(Day, GenericPrice)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config
-> Text -> Day -> Day -> IO (AlphaVantageResponse [(Day, Prices)])
getDailyPrices Config
cfg Text
symbol Day
start Day
end
)
FetchCrypto Text
symbol -> (Text
symbol, FilePath
"Cryptocurrency", ) (Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])
-> (Text, FilePath,
Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])))
-> IO
(Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
-> IO
(Text, FilePath,
Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (AlphaVantageResponse [(Day, GenericPrice)])
-> IO
(Either SomeException (AlphaVantageResponse [(Day, GenericPrice)]))
forall e a. Exception e => IO a -> IO (Either e a)
try
( ([(Day, CryptoPrices)] -> [(Day, GenericPrice)])
-> AlphaVantageResponse [(Day, CryptoPrices)]
-> AlphaVantageResponse [(Day, GenericPrice)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Day, CryptoPrices) -> (Day, GenericPrice))
-> [(Day, CryptoPrices)] -> [(Day, GenericPrice)]
forall a b. (a -> b) -> [a] -> [b]
map ((CryptoPrices -> GenericPrice)
-> (Day, CryptoPrices) -> (Day, GenericPrice)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second CryptoPrices -> GenericPrice
Crypto))
(AlphaVantageResponse [(Day, CryptoPrices)]
-> AlphaVantageResponse [(Day, GenericPrice)])
-> IO (AlphaVantageResponse [(Day, CryptoPrices)])
-> IO (AlphaVantageResponse [(Day, GenericPrice)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config
-> Text
-> Text
-> Day
-> Day
-> IO (AlphaVantageResponse [(Day, CryptoPrices)])
getDailyCryptoPrices Config
cfg Text
symbol Text
"USD" Day
start Day
end
)
case Either SomeException (AlphaVantageResponse [(Day, GenericPrice)])
resp of
Left (SomeException
e :: SomeException) -> do
FilePath -> IO ()
logError
(FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error Fetching Prices for "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
label
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" `"
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
symbol
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"`:\n\t"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
e
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
Maybe (Text, [(Day, GenericPrice)])
-> IO (Maybe (Text, [(Day, GenericPrice)]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, [(Day, GenericPrice)])
forall a. Maybe a
Nothing
Right (ApiError Text
note) -> do
FilePath -> IO ()
logError
(FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error Fetching Prices for "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
label
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" `"
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
symbol
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"`:\n\t"
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
note
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n"
Maybe (Text, [(Day, GenericPrice)])
-> IO (Maybe (Text, [(Day, GenericPrice)]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Text, [(Day, GenericPrice)])
forall a. Maybe a
Nothing
Right (ApiResponse [(Day, GenericPrice)]
prices) -> Maybe (Text, [(Day, GenericPrice)])
-> IO (Maybe (Text, [(Day, GenericPrice)]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, [(Day, GenericPrice)])
-> IO (Maybe (Text, [(Day, GenericPrice)])))
-> Maybe (Text, [(Day, GenericPrice)])
-> IO (Maybe (Text, [(Day, GenericPrice)]))
forall a b. (a -> b) -> a -> b
$ (Text, [(Day, GenericPrice)])
-> Maybe (Text, [(Day, GenericPrice)])
forall a. a -> Maybe a
Just (Text
symbol, [(Day, GenericPrice)]
prices)
logError :: String -> IO ()
logError :: FilePath -> IO ()
logError = Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr
data AlphaRequest
= FetchStock CommoditySymbol
| FetchCrypto CommoditySymbol
data GenericPrice
= Stock Prices
| Crypto CryptoPrices
getClosePrice :: GenericPrice -> Scientific
getClosePrice :: GenericPrice -> Scientific
getClosePrice = \case
Stock Prices { Scientific
pClose :: Prices -> Scientific
pClose :: Scientific
pClose } -> Scientific
pClose
Crypto CryptoPrices { Scientific
cpClose :: CryptoPrices -> Scientific
cpClose :: Scientific
cpClose } -> Scientific
cpClose
rateLimitActions :: [IO a] -> IO [a]
rateLimitActions :: [IO a] -> IO [a]
rateLimitActions [IO a]
a = case Int -> [IO a] -> [[IO a]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
5 [IO a]
a of
[ [IO a]
first] -> [IO a] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO a]
first
[IO a]
first : [[IO a]]
rest -> do
[a]
rest_ <- [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> IO [[a]] -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([IO a] -> IO [a]) -> [[IO a]] -> IO [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [IO a] -> IO [a]
forall (t :: * -> *) a. Traversable t => t (IO a) -> IO (t a)
runAndDelay [[IO a]]
rest
[a]
first_ <- [IO a] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO a]
first
[a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ [a]
first_ [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rest_
[] -> [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
runAndDelay :: t (IO a) -> IO (t a)
runAndDelay t (IO a)
actions = do
t a
results <- t (IO a) -> IO (t a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence t (IO a)
actions
FilePath -> IO ()
putStrLn FilePath
"Waiting 60 seconds to respect API rate limits."
Int -> IO ()
threadDelay (Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000)
t a -> IO (t a)
forall (m :: * -> *) a. Monad m => a -> m a
return t a
results
makePriceDirectives
:: [(CommoditySymbol, [(Day, GenericPrice)])] -> LBS.ByteString
makePriceDirectives :: [(Text, [(Day, GenericPrice)])] -> ByteString
makePriceDirectives = (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") (ByteString -> ByteString)
-> ([(Text, [(Day, GenericPrice)])] -> ByteString)
-> [(Text, [(Day, GenericPrice)])]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
LBS.intercalate ByteString
"\n\n" ([ByteString] -> ByteString)
-> ([(Text, [(Day, GenericPrice)])] -> [ByteString])
-> [(Text, [(Day, GenericPrice)])]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [(Day, GenericPrice)]) -> ByteString)
-> [(Text, [(Day, GenericPrice)])] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [(Day, GenericPrice)]) -> ByteString
makeDirectives
where
makeDirectives :: (CommoditySymbol, [(Day, GenericPrice)]) -> LBS.ByteString
makeDirectives :: (Text, [(Day, GenericPrice)]) -> ByteString
makeDirectives (Text
symbol, [(Day, GenericPrice)]
prices) =
ByteString -> [ByteString] -> ByteString
LBS.intercalate ByteString
"\n"
([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
LBS.fromStrict (Text -> ByteString
encodeUtf8 Text
symbol))
ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ((Day, GenericPrice) -> ByteString)
-> [(Day, GenericPrice)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> (Day, GenericPrice) -> ByteString
makeDirective Text
symbol) [(Day, GenericPrice)]
prices
makeDirective :: CommoditySymbol -> (Day, GenericPrice) -> LBS.ByteString
makeDirective :: Text -> (Day, GenericPrice) -> ByteString
makeDirective Text
symbol (Day
day, GenericPrice
prices) = ByteString -> [ByteString] -> ByteString
LBS.intercalate
ByteString
" "
[ ByteString
"P"
, FilePath -> ByteString
LC.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> Day -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%F" Day
day
, ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
symbol
, ByteString
"$" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> ByteString
LC.pack (Scientific -> FilePath
forall a. Show a => a -> FilePath
show (Scientific -> FilePath) -> Scientific -> FilePath
forall a b. (a -> b) -> a -> b
$ GenericPrice -> Scientific
getClosePrice GenericPrice
prices)
]