1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# 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)
|
