{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
-- | Example using ghci, where we read the currency rates relative to Euros, and re-base
-- them to hard currency.
--
-- > > :m Financial.EuroFXRef Data.Map
-- > > fmap (assocs . raRates . rebase (Currency "NZD")) fetch :: IO [(Currency, Double)]
-- > [(Currency "AUD",0.7696441703909034),(Currency "BGN",1.1064094586185438),...
--
-- Each number is one unit of the reference currency in that currency,
-- e.g. in this example NZD 1 == AUD 0.77.

module Financial.EuroFXRef (
        -- * Simple
        fetch,
        EuropeanCentralBankException(..),
        -- * Lower-level
        europeanCentralBankDaily,
        fetchFrom,
        parseEuropeanCentralBank,
        module Financial.CurrencyRates
    ) where

import Financial.CurrencyRates

import Control.Applicative
import Control.Arrow (second, first)
import Control.Exception
import Control.Failure
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Data.Enumerator (Iteratee (..), run_)
import Data.Enumerator.List (consume)
import qualified Data.Map as M
import Data.Monoid
import Data.Time.Calendar
import Data.Time.Clock
import Data.Typeable
import Network.HTTP.Enumerator as HTTP
import Network.HTTP.Types as HTTP
import Text.XML.Expat.Tree

-- | calendar time YYYYMMDDHHMMSS to posix microseconds 
cal2utc :: (Int, Int, Int, Int, Int, Int) -> UTCTime
cal2utc (y,m,d,hh,mm,ss) =
    let ymd = toModifiedJulianDay $ fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)
    in  UTCTime
            (ModifiedJulianDay $ fromIntegral ymd)
            (fromIntegral $ hh * 3600 + mm * 60 + ss)

maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
    [(a, "")] -> Just a
    _         -> Nothing

-- | An exception indicating a parse error in the parsing of European Central Bank.
data EuropeanCentralBankException =
    ECBXMLParseException XMLParseError |
    ECBHttpException HttpException |
    ECBHttpStatusException HTTP.Status |
    ECBParseException String 
    deriving (Show, Typeable)

instance Exception EuropeanCentralBankException where

-- | Parse the European Central Bank's XML format.
parseEuropeanCentralBank :: Read a => UNode String -> Either String (Rates a)
parseEuropeanCentralBank (Element _ _ chs) =
    case execStateT (mapM_ p2 chs) (Nothing, M.empty) of
        Right (Just time, rates) -> Right $ Rates euro time rates
        Right (Nothing, _)       -> Left $ "time stamp is missing"
        Left err                 -> Left err
  where
    euro = Currency "EUR"
    p2 (Element "Cube" _ chs) = mapM_ p3 chs
    p2 _                 = return ()
    p3 e@(Element "Cube" _ chs) = do
        case getAttribute e "time" of
            Just tstr -> case words (map (\x -> if x == '-' then ' ' else x) tstr) of
                [ys, ms, ds] -> case (maybeRead ys, maybeRead ms, maybeRead ds) of
                    (Just y, Just m, Just d) -> modify $ first $ const $ Just $
                        cal2utc (y, m, d, 13, 0, 0)  -- Updated at "3PM CET" which corresponds to
                                                     -- 13:00 UTC. Not sure about daylight savings!
                    _ -> lift $ fail $ "bad time: " ++ tstr
                _ -> lift $ fail $ "bad time: " ++ tstr
            Nothing -> lift $ fail "missing time"
        mapM_ p4 chs
    p3 _                 = return ()
    p4 e@(Element "Cube" _ _) = case (getAttribute e "currency", join $ maybeRead <$> getAttribute e "rate") of
        (Just cur, Just rate) -> modify $ second $ M.insert (Currency cur) rate
        _                     -> return ()
    p4 _                 = return ()
parseEuropeanCentralBank _ = Left "element expected at top level"

-- | The URL for the European Central Bank's free daily reference rates.
europeanCentralBankDaily :: Failure HttpException m => m (HTTP.Request m)
europeanCentralBankDaily = parseUrl "http://www.ecb.int/stats/eurofxref/eurofxref-daily.xml"

-- | Fetch today's currency rates from the specified URL.
--
-- Throws a 'EuropeanCentralBankException' for failures at HTTP and above,
-- or 'IOException' for network-level failures.
fetchFrom :: (Failure EuropeanCentralBankException m, Failure HttpException m, MonadIO m, Read a) =>
             HTTP.Request m
          -> m (Rates a)
fetchFrom req = do
    mgr <- liftIO newManager
    run_ $ httpRedirect req processResponse mgr

processResponse :: (Failure EuropeanCentralBankException m, Read a) =>
                   HTTP.Status
                -> ResponseHeaders
                -> Iteratee B.ByteString m (Rates a)
processResponse status@(Status statusCode _) headers = do
    body <- mconcat <$> consume
    case statusCode of
        200 -> do
            case parse' defaultParseOptions body of
                Left err -> lift $ failure $ ECBXMLParseException err
                Right xml ->
                    case parseEuropeanCentralBank xml of
                        Left err -> lift $ failure $ ECBParseException err
                        Right rates -> return rates
        _ -> lift $ failure $ ECBHttpStatusException status

-- | Fetch today's currency rates from European Central Bank server.
-- 'IO' works for @m@ and 'Double' for @a@.
--
-- Throws a 'EuropeanCentralBankException' for failures at HTTP and above,
-- or 'IOException' for network-level failures.
fetch :: (Failure EuropeanCentralBankException m, Failure HttpException m, MonadIO m, Read a) =>
         m (Rates a)
fetch = fetchFrom =<< europeanCentralBankDaily