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

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 _) = do
  zones <- zoneHeaders
  let (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders
      tz = foldr' (flip (<>)) (Left dateTz) zones
  foldMap pure <$> mapM (flip runReaderT TimeCtx{..} . parseDelay) delayHeaders
  where
    delayHeaders :: [Field]
    delayHeaders = do
      (OptionalField field content) <- headers
      guard $ CI.mk field == "X-Delay"
      return . OptionalField field $ decodeWords content
    dateHeaders :: [(UTCTime, TimeZone)]
    dateHeaders = do
      (Date CalendarTime{..}) <- headers
      let tz = minutesToTimeZone . round $ ctTZ % 60
      return . (, tz) . localTimeToUTC tz $ LocalTime
        (fromGregorian (fromIntegral ctYear) (fromEnum ctMonth + 1) ctDay)
        (TimeOfDay ctHour ctMin $ fromIntegral ctSec + fromIntegral ctPicosec * 1e-12)
    zoneHeaders :: m [Either TimeZone TZ]
    zoneHeaders = runListT $ do
      (OptionalField field content) <- ListT $ return headers
      guard $ CI.mk field == "X-Timezone"
      Right r <- runParserT (spaces *> pTimeZone <* spaces <* eof) () field content
      return r
    parseDelay :: Field -> ReaderT TimeCtx m Delay
    parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content