{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{- | Helper functions for the @hledger-stockquotes@ application.

-}
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


-- | Given a list of Commodities to exclude and a Journal File, return the
-- Commodities in the Journal and the minimum/maximum days from the
-- Journal.
getCommoditiesAndDateRange
    :: [T.Text] -> FilePath -> IO ([CommoditySymbol], Day, Day)
getCommoditiesAndDateRange excluded journalPath = do
    journal <- fmap (either error id) . runExceptT $ readJournalFile
        definputopts
        journalPath
    currentTime <- getCurrentTime
    let commodities =
            filter (`notElem` excluded)
                $  M.keys (jcommodities journal)
                <> M.keys (jinferredcommodities journal)
        dates       = map tdate $ jtxns journal
        currentYear = (\(y, _, _) -> y) $ toGregorian $ utctDay currentTime
        minDate     = case minimumMay dates of
            Just d  -> d
            Nothing -> fromGregorian currentYear 1 1
        maxDate = case maximumMay dates of
            Just d  -> d
            Nothing -> utctDay currentTime
    return (L.sort $ L.nub commodities, minDate, maxDate)


-- | Fetch the Prices for the Commodities from the AlphaVantage API,
-- limiting the returned prices between the given Days.
--
-- Note: Fetching errors are currently logged to 'stderr'.
fetchPrices
    :: Config
    -- ^ AlphaVantage Configuration
    -> [CommoditySymbol]
    -- ^ Commodities to Fetch
    -> [T.Text]
    -- ^ Commodities to Classify as Cryptocurrencies
    -> Day
    -- ^ Start of Price Range
    -> Day
    -- ^ End of Price Range
    -> Bool
    -- ^ Rate Limit Requests
    -> IO [(CommoditySymbol, [(Day, GenericPrice)])]
fetchPrices cfg symbols cryptoCurrencies start end rateLimit = do
    let (stockSymbols, cryptoSymbols) =
            L.partition (`notElem` cryptoCurrencies) symbols
        genericAction =
            map FetchStock stockSymbols <> map FetchCrypto cryptoSymbols
    if rateLimit
        then fmap catMaybes $ rateLimitActions $ map fetch genericAction
        else catMaybes <$> mapM fetch genericAction
  where
    fetch
        :: AlphaRequest -> IO (Maybe (CommoditySymbol, [(Day, GenericPrice)]))
    fetch req = do
        (symbol, label, resp) <- case req of
            FetchStock symbol ->
                (symbol, "Stock", )
                    <$> try
                            (   fmap (map (second Stock))
                            <$> getDailyPrices cfg symbol start end
                            )
            FetchCrypto symbol -> (symbol, "Cryptocurrency", ) <$> try
                (   fmap (map (second Crypto))
                <$> getDailyCryptoPrices cfg symbol "USD" start end
                )
        case resp of
            Left (e :: SomeException) -> do
                logError
                    $  "Error Fetching Prices for "
                    <> label
                    <> "  `"
                    <> T.unpack symbol
                    <> "`:\n\t"
                    ++ displayException e
                    ++ "\n"
                return Nothing

            Right (ApiError note) -> do
                logError
                    $  "Error Fetching Prices for "
                    <> label
                    <> " `"
                    <> T.unpack symbol
                    <> "`:\n\t"
                    <> T.unpack note
                    <> "\n"
                return Nothing

            Right (ApiResponse prices) -> return $ Just (symbol, prices)

    logError :: String -> IO ()
    logError = hPutStrLn stderr


-- | Types of AlphaVantage requests we make. Unified under one type so we
-- write a generic fetching function that can be rate limited.
data AlphaRequest
    = FetchStock CommoditySymbol
    | FetchCrypto CommoditySymbol

-- | Union type for all the various prices we can return.
data GenericPrice
    = Stock Prices
    | Crypto CryptoPrices

-- | Get the day's closing price.
getClosePrice :: GenericPrice -> Scientific
getClosePrice = \case
    Stock  Prices { pClose }        -> pClose
    Crypto CryptoPrices { cpClose } -> cpClose

-- | Perform the actions at a rate of 5 per minute, then return all the
-- results.
--
-- Note: Will log waiting times to stdout.
rateLimitActions :: [IO a] -> IO [a]
rateLimitActions a = case chunksOf 5 a of
    [     first]    -> sequence first
    first :    rest -> do
        rest_  <- concat <$> mapM runAndDelay rest
        first_ <- sequence first
        return $ first_ ++ rest_
    [] -> return []
  where
    runAndDelay actions = do
        results <- sequence actions
        putStrLn "Waiting 60 seconds to respect API rate limits."
        threadDelay (60 * 1_000_000)
        return results


-- | Build the Price Directives for the Daily Prices of the given
-- Commodities.
makePriceDirectives
    :: [(CommoditySymbol, [(Day, GenericPrice)])] -> LBS.ByteString
makePriceDirectives = (<> "\n") . LBS.intercalate "\n\n" . map makeDirectives
  where
    makeDirectives
        :: (CommoditySymbol, [(Day, GenericPrice)]) -> LBS.ByteString
    makeDirectives (symbol, prices) =
        LBS.intercalate "\n"
            $ ("; " <> LBS.fromStrict (encodeUtf8 symbol))
            : map (makeDirective symbol) prices
    makeDirective :: CommoditySymbol -> (Day, GenericPrice) -> LBS.ByteString
    makeDirective symbol (day, prices) = LBS.intercalate
        " "
        [ "P"
        , LC.pack $ formatTime defaultTimeLocale "%F" day
        , LBS.fromStrict $ encodeUtf8 symbol
        , "$" <> LC.pack (show $ getClosePrice prices)
        ]