{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Date.Parser (parseHTTPDate) where

import Control.Applicative
import Control.Monad
import Data.Attoparsec.ByteString.Char8
import Data.ByteString (ByteString)
import Data.Char
import Data.Maybe (isJust)
import Network.HTTP.Date.Converter (httpDateToUTCValid)
import Network.HTTP.Date.Types

----------------------------------------------------------------

-- |
-- Parsing HTTP Date. The three formats of RFC 9110 are supported:
-- IMF-fixdate (RFC 1123), the obsolete RFC 850 format and asctime.
-- Dates which do not exist are rejected while the day of the week is
-- not checked against the date.
--
-- >>> :set -XOverloadedStrings
-- >>> parseHTTPDate "Tue, 15 Nov 1994 08:12:31 GMT"
-- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})
-- >>> parseHTTPDate "Tuesday, 15-Nov-94 08:12:31 GMT"
-- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})
-- >>> parseHTTPDate "Tue Nov 15 08:12:31 1994"
-- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})
-- >>> parseHTTPDate "Tue, 31 Feb 1994 08:12:31 GMT"
-- Nothing
--
-- A two-digit year of the RFC 850 format is taken as 1970-2069.
parseHTTPDate :: ByteString -> Maybe HTTPDate
parseHTTPDate :: ByteString -> Maybe HTTPDate
parseHTTPDate ByteString
bs = case Parser HTTPDate -> ByteString -> Either String HTTPDate
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser HTTPDate
httpDate ByteString
bs of
    Right HTTPDate
hd -> HTTPDate -> Maybe HTTPDate
forall a. a -> Maybe a
Just HTTPDate
hd
    Either String HTTPDate
_ -> Maybe HTTPDate
forall a. Maybe a
Nothing

httpDate :: Parser HTTPDate
httpDate :: Parser HTTPDate
httpDate = do
    -- Trailing OWS is not part of a field value (RFC 9110 Section 5.5)
    -- but some HTTP parsers leave it there.
    hd <- Parser HTTPDate
rfc1123Date Parser HTTPDate -> Parser HTTPDate -> Parser HTTPDate
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser HTTPDate
rfc850Date Parser HTTPDate -> Parser HTTPDate -> Parser HTTPDate
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser HTTPDate
asctimeDate
    skipWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t')
    endOfInput
    guard $ isJust $ httpDateToUTCValid hd
    return hd

mkHTTPDate :: Int -> (Int, Int, Int) -> (Int, Int, Int) -> HTTPDate
mkHTTPDate :: Int -> (Int, Int, Int) -> (Int, Int, Int) -> HTTPDate
mkHTTPDate Int
w (Int
y, Int
m, Int
d) (Int
h, Int
n, Int
s) =
    HTTPDate
defaultHTTPDate
        { hdYear = y
        , hdMonth = m
        , hdDay = d
        , hdHour = h
        , hdMinute = n
        , hdSecond = s
        , hdWkday = w
        }

-- Sun, 06 Nov 1994 08:49:37 GMT
rfc1123Date :: Parser HTTPDate
rfc1123Date :: Parser HTTPDate
rfc1123Date = do
    w <- Parser Int
wkday
    void $ string ", "
    d <- digit2
    sp
    m <- month
    sp
    y <- digit4
    sp
    t <- time
    sp
    gmt
    return $ mkHTTPDate w (y, m, d) t

-- Sunday, 06-Nov-94 08:49:37 GMT
rfc850Date :: Parser HTTPDate
rfc850Date :: Parser HTTPDate
rfc850Date = do
    w <- Parser Int
weekday
    void $ string ", "
    d <- digit2
    void $ char '-'
    m <- month
    void $ char '-'
    yy <- digit2
    sp
    t <- time
    sp
    gmt
    let y = if Int
yy Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
70 then Int
2000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yy else Int
1900 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yy
    return $ mkHTTPDate w (y, m, d) t

-- Sun Nov  6 08:49:37 1994
asctimeDate :: Parser HTTPDate
asctimeDate :: Parser HTTPDate
asctimeDate = do
    w <- Parser Int
wkday
    sp
    m <- month
    sp
    d <- digit2 <|> (sp *> digit1)
    sp
    t <- time
    sp
    y <- digit4
    return $ mkHTTPDate w (y, m, d) t

-- RFC 9110 defines GMT only but there are actually ill-formed ones such
-- as "+0000" and "UTC" in the wild.
gmt :: Parser ()
gmt :: Parser ()
gmt = Parser ByteString ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString ByteString -> Parser ())
-> Parser ByteString ByteString -> Parser ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString ByteString
string ByteString
"GMT" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString ByteString
string ByteString
"+0000" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString ByteString
string ByteString
"UTC"

wkday :: Parser Int
wkday :: Parser Int
wkday =
    Int
1 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Mon"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
2 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Tue"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
3 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Wed"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
4 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Thu"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
5 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Fri"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
6 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Sat"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
7 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Sun"

weekday :: Parser Int
weekday :: Parser Int
weekday =
    Int
1 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Monday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
2 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Tuesday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
3 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Wednesday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
4 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Thursday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
5 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Friday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
6 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Saturday"
        Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
7 Int -> Parser ByteString ByteString -> Parser Int
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"Sunday"

sp :: Parser ()
sp :: Parser ()
sp = () () -> Parser ByteString Char -> Parser ()
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
char Char
' '

time :: Parser (Int, Int, Int)
time :: Parser (Int, Int, Int)
time = do
    h <- Parser Int
digit2
    void $ char ':'
    m <- digit2
    void $ char ':'
    s <- digit2
    return (h, m, s)

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

digit1 :: Parser Int
digit1 :: Parser Int
digit1 = Char -> Int
toInt (Char -> Int) -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Char
digit

digit2 :: Parser Int
digit2 :: Parser Int
digit2 = do
    x1 <- Parser Int
digit1
    x2 <- digit1
    return $ x1 * 10 + x2

digit4 :: Parser Int
digit4 :: Parser Int
digit4 = do
    x1 <- Parser Int
digit2
    x2 <- digit2
    return $ x1 * 100 + x2

toInt :: Char -> Int
toInt :: Char -> Int
toInt Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'