blob: 2f0a78ab9189fae3ced3aa271ce86cf0b7440aef (
plain)
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
|
{-# 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
|
