-- This file is part of purebred-email
-- Copyright (C) 2021  Fraser Tweedale
--
-- purebred-email is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE OverloadedStrings #-}

module Data.IMF.DateTime
  ( dateTime
  ) where

import Control.Applicative ((<|>), optional)
import Control.Monad (guard)
import Data.Functor (($>))

import Data.Attoparsec.ByteString as A
import Data.Attoparsec.ByteString.Char8 (char8, isDigit_w8)
import qualified Data.ByteString as B
import qualified Data.Time
import Data.Time
  ( Day, DayOfWeek(..), LocalTime(LocalTime), TimeOfDay, TimeZone(TimeZone)
  , ZonedTime(ZonedTime), fromGregorianValid, makeTimeOfDayValid
  , minutesToTimeZone, hoursToTimeZone, utc
  )
import Data.IMF.Syntax (fws, optionalCFWS, optionalFWS)

dateTime :: Parser ZonedTime
dateTime :: Parser ZonedTime
dateTime = do
  Maybe DayOfWeek
dow <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString DayOfWeek
dayOfWeek forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Word8
char8 Char
',')
  Day
theDate <- Parser Day
date

  -- ensure day of week matches date
  case Maybe DayOfWeek
dow of
    Just DayOfWeek
dow' | Day -> DayOfWeek
Data.Time.dayOfWeek Day
theDate forall a. Eq a => a -> a -> Bool
/= DayOfWeek
dow'
      -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"day of week inconsistent with date"
    Maybe DayOfWeek
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  TimeOfDay
tod <- Parser TimeOfDay
timeOfDay
  TimeZone
z <- Parser TimeZone
zone
  ByteString
_ <- forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime Day
theDate TimeOfDay
tod) TimeZone
z


dayOfWeek :: Parser DayOfWeek
dayOfWeek :: Parser ByteString DayOfWeek
dayOfWeek = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString DayOfWeek
dayName

dayName :: Parser DayOfWeek
dayName :: Parser ByteString DayOfWeek
dayName =
  ByteString -> Parser ByteString
string ByteString
"Mon" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Monday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Tue" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Tuesday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Wed" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Wednesday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Thu" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Thursday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Fri" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Friday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sat" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Saturday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sun" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Sunday
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid day-of-week"

date :: Parser Day
date :: Parser Day
date = do
  Int
d <- Parser Int
day
  Int
m <- Parser Int
month
  Integer
y <- Parser Integer
year
  case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d of
    Just Day
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
r
    Maybe Day
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date"

day :: Parser Int
day :: Parser Int
day = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws
  where
  go :: Parser Int
go = (Parser Int
twoDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
digit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> String -> a -> Parser a
check (\Int
n -> Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
31) String
"day out of range"

month :: Parser Int
month :: Parser Int
month =
  ByteString -> Parser ByteString
string ByteString
"Jan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
1
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Feb" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
2
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Mar" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
3
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Apr" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
4
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"May" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
5
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Jun" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
6
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Jul" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
7
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Aug" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
8
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sep" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
9
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Oct" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
10
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Nov" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
11
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Dec" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
12
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid month"

year :: Parser Integer
year :: Parser Integer
year = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Integer
go forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> String -> a -> Parser a
check (forall a. Ord a => a -> a -> Bool
>= Integer
1900) String
"year cannot be < 1900") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws
  where
  go :: Parser Integer
go = Parser Integer
fourOrMoreDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Integer
obsYear forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too few digits in year"
  fourOrMoreDigit :: Parser Integer
fourOrMoreDigit = do
    ByteString
digits <- (Word8 -> Bool) -> Parser ByteString
A.takeWhile Word8 -> Bool
isDigit_w8
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B.length ByteString
digits forall a. Ord a => a -> a -> Bool
>= Int
4)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' forall {a} {a}. (Integral a, Num a) => a -> a -> a
step Integer
0 ByteString
digits)
  step :: a -> a -> a
step a
r a
a = a
r forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
a forall a. Num a => a -> a -> a
- a
48)
  obsYear :: Parser Integer
obsYear = do
    Int
yy <- Parser Int
twoDigit
    forall a b. (Integral a, Num b) => a -> b
fromIntegral
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
yy forall a. Num a => a -> a -> a
+ if Int
yy forall a. Ord a => a -> a -> Bool
<= Int
49 then Int
2000 else Int
1900) (Int
1900 forall a. Num a => a -> a -> a
+ Int
yy forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Int
digit

timeOfDay :: Parser TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
  Int
hour <- Parser Int
twoDigit
  Word8
_ <- Char -> Parser Word8
char8 Char
':'
  Int
minute <- Parser Int
twoDigit
  Int
second <- Char -> Parser Word8
char8 Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  case Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid Int
hour Int
minute (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
second) of
    Maybe TimeOfDay
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time-of-day"
    Just TimeOfDay
tod -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeOfDay
tod

zone :: Parser TimeZone
zone :: Parser TimeZone
zone = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser TimeZone
go forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
obsZone)
  where
  go :: Parser TimeZone
go = do
    Int -> Int
posNeg <- Char -> Parser Word8
char8 Char
'+' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. a -> a
id forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Word8
char8 Char
'-' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Num a => a -> a
negate
    Int
h <- Parser Int
twoDigit
    Int
m <- Parser Int
twoDigit
    Bool -> String -> Parser ByteString ()
guardFail (Int
m forall a. Ord a => a -> a -> Bool
<= Int
59) String
"zone minutes must be in range 0..59"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> TimeZone
minutesToTimeZone (Int -> Int
posNeg (Int
h forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
+ Int
m))

obsZone :: Parser TimeZone
obsZone :: Parser TimeZone
obsZone =
  TimeZone
utc forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ByteString -> Parser ByteString
string ByteString
"GMT" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"UT")
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
usZone
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
milZone
  where
  usZone :: Parser TimeZone
usZone = do
    (Int
off, Char
c1) <-
      forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
5) Char
'E'      -- eastern
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
6) Char
'C'  -- central
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
7) Char
'M'  -- mountain
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
8) Char
'P'  -- pacific
    (Int
dst, Char
c2) <- forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal Int
0 Char
'S' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal Int
1 Char
'D'  -- standard / dst
    Word8
_ <- Char -> Parser Word8
char8 Char
'T'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> TimeZone
TimeZone ((Int
off forall a. Num a => a -> a -> a
+ Int
dst) forall a. Num a => a -> a -> a
* Int
60) (Int
dst forall a. Eq a => a -> a -> Bool
== Int
1) (Char
c1forall a. a -> [a] -> [a]
:Char
c2forall a. a -> [a] -> [a]
:String
"T")
  charVal :: a -> Char -> Parser ByteString (a, Char)
charVal a
a Char
c = (a
a, Char
c) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Word8
char8 Char
c
  milZone :: Parser TimeZone
milZone =
    TimeZone
utc forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Parser Word8
char8 Char
'Z' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Word8
char8 Char
'z')
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go     forall a. a -> a
id Int
0x40 Word8
0x41 Word8
0x49  -- A..I
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go     forall a. a -> a
id Int
0x41 Word8
0x4b Word8
0x4d  -- K..M
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. Num a => a -> a
negate Int
0x4d Word8
0x4c Word8
0x59  -- N..Y
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go     forall a. a -> a
id Int
0x60 Word8
0x61 Word8
0x69  -- a..i
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go     forall a. a -> a
id Int
0x61 Word8
0x6b Word8
0x6d  -- k..m
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. Num a => a -> a
negate Int
0x6d Word8
0x6e Word8
0x79  -- n..y
  go :: (b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go b -> Int
f b
off Word8
lo Word8
hi =
    Int -> TimeZone
hoursToTimeZone forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract b
off forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser Word8
satisfy (\Word8
c -> Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
lo Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
hi)


guardFail :: Bool -> String -> Parser ()
guardFail :: Bool -> String -> Parser ByteString ()
guardFail Bool
True String
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guardFail Bool
False String
s = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s

check :: (a -> Bool) -> String -> a -> Parser a
check :: forall a. (a -> Bool) -> String -> a -> Parser a
check a -> Bool
f String
s a
a = Bool -> String -> Parser ByteString ()
guardFail (a -> Bool
f a
a) String
s forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a

digit :: Parser Int
digit :: Parser Int
digit = (\Word8
c -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
48)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser Word8
satisfy Word8 -> Bool
isDigit_w8

twoDigit :: Parser Int
twoDigit :: Parser Int
twoDigit = (\Int
hi Int
lo -> Int
hi forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
lo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
digit forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
digit