{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns #-}

module Postdelay.Scan
  ( scan
  , Delay(..)
  , ParseError(..)
  ) where

import Postdelay.Types
import Postdelay.Utils
import Postdelay.TimeSpec

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.List
import Control.Exception.Base

import Text.Parsec.Char
import Text.Parsec.Prim
import Text.Parsec.Combinator
import Text.Parsec.Error (ParseError(..))
import Text.ParserCombinators.Parsec.Rfc2822
import Codec.MIME.Decode (decodeWords)

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Data.Either
import Data.Foldable
import Data.Semigroup
import Data.Time
import Data.List
import Data.Ord
import Data.Ratio

import Data.Time.Zones
import System.Time (CalendarTime(..))

import Debug.Trace


scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay)
scan = fmap getOption . extractDelay <=< either throwError return . parse message ""

extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay)
extractDelay (Message headers _)
  = let latestCtx = maximumBy (comparing baseTime) dateHeaders
    in foldMap pure <$> mapM (flip runReaderT latestCtx . parseDelay) delayHeaders
  where
    delayHeaders :: [Field]
    delayHeaders = do
      (OptionalField field content) <- headers
      guard $ CI.mk field == "X-Delay"
      return . OptionalField field $ decodeWords content
    dateHeaders :: [TimeCtx]
    dateHeaders = do
      (Date CalendarTime{..}) <- headers
      let tz = minutesToTimeZone . round $ ctTZ % 60
      return $ TimeCtx
        { baseTime = localTimeToUTC tz $ LocalTime
                     (fromGregorian (fromIntegral ctYear) (fromEnum ctMonth + 1) ctDay)
                     (TimeOfDay ctHour ctMin $ fromIntegral ctSec + fromIntegral ctPicosec * 1e-12)
        , tz = Left tz
        }
    parseDelay :: Field -> ReaderT TimeCtx m Delay
    parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content