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

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

import Postdelay.Types
import Postdelay.TimeSpec

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.List
import Control.Exception.Base
import Control.Lens

import qualified Text.Parsec as P
import Text.Megaparsec
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

instance Exception P.ParseError


scan :: (MonadIO m, MonadThrow m) => String -> m (Maybe Delay)
scan = fmap getOption . extractDelay <=< either throwM return . P.parse message ""

extractDelay :: forall m. (MonadIO m, MonadThrow m) => Message -> m (Option Delay)
extractDelay (Message headers _) = do
  tz <- foldr' (flip (<>)) (Left dateTz) <$> zoneHeaders
  let apply f = Until (baseTime & localT tz %~ appEndo f)
  fmap apply . foldMap pure <$> mapM parseDelay delayHeaders
  where
    (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders

    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"
      either throwM return =<< runParserT (spaceConsumer *> lexeme timeZone <* eof) field content
    parseDelay :: Field -> m (Endo LocalTime)
    parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme timeSpec <* eof) field content

localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime
localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz)
localT (Right tz) = iso (utcToLocalTimeTZ tz) (localTimeToUTCTZ tz)