Parser.hs

{-# 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 bs = case parseOnly httpDate bs of
    Right hd -> Just hd
    _ -> Nothing

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 <- rfc1123Date <|> rfc850Date <|> asctimeDate
    skipWhile (\c -> c == ' ' || c == '\t')
    endOfInput
    guard $ isJust $ httpDateToUTCValid hd
    return hd

mkHTTPDate :: Int -> (Int, Int, Int) -> (Int, Int, Int) -> HTTPDate
mkHTTPDate w (y, m, d) (h, n, s) =
    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 = do
    w <- 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 = do
    w <- weekday
    void $ string ", "
    d <- digit2
    void $ char '-'
    m <- month
    void $ char '-'
    yy <- digit2
    sp
    t <- time
    sp
    gmt
    let y = if yy < 70 then 2000 + yy else 1900 + yy
    return $ mkHTTPDate w (y, m, d) t

-- Sun Nov  6 08:49:37 1994
asctimeDate :: Parser HTTPDate
asctimeDate = do
    w <- 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 = void $ string "GMT" <|> string "+0000" <|> string "UTC"

wkday :: Parser Int
wkday =
    1 <$ string "Mon"
        <|> 2 <$ string "Tue"
        <|> 3 <$ string "Wed"
        <|> 4 <$ string "Thu"
        <|> 5 <$ string "Fri"
        <|> 6 <$ string "Sat"
        <|> 7 <$ string "Sun"

weekday :: Parser Int
weekday =
    1 <$ string "Monday"
        <|> 2 <$ string "Tuesday"
        <|> 3 <$ string "Wednesday"
        <|> 4 <$ string "Thursday"
        <|> 5 <$ string "Friday"
        <|> 6 <$ string "Saturday"
        <|> 7 <$ string "Sunday"

sp :: Parser ()
sp = () <$ char ' '

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

month :: Parser Int
month =
    1 <$ string "Jan"
        <|> 2 <$ string "Feb"
        <|> 3 <$ string "Mar"
        <|> 4 <$ string "Apr"
        <|> 5 <$ string "May"
        <|> 6 <$ string "Jun"
        <|> 7 <$ string "Jul"
        <|> 8 <$ string "Aug"
        <|> 9 <$ string "Sep"
        <|> 10 <$ string "Oct"
        <|> 11 <$ string "Nov"
        <|> 12 <$ string "Dec"

digit1 :: Parser Int
digit1 = toInt <$> digit

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

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

toInt :: Char -> Int
toInt c = ord c - ord '0'