Converter.hs

module Network.HTTP.Date.Converter (
    epochTimeToHTTPDate,
    httpDateToUTC,
    httpDateToUTCValid,
    utcToHTTPDate,
) where

import Data.Time
import Data.Time.Calendar.WeekDate
import Foreign.C.Types (CTime (..))
import Network.HTTP.Date.Types
import System.Posix.Types

-- |
--   Translating 'EpochTime' to 'HTTPDate'.
--
-- >>> epochTimeToHTTPDate 784887151
-- HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2}
epochTimeToHTTPDate :: EpochTime -> HTTPDate
epochTimeToHTTPDate (CTime i) =
    defaultHTTPDate
        { hdYear = y
        , hdMonth = m
        , hdDay = d
        , hdHour = h
        , hdMinute = n
        , hdSecond = s
        , hdWkday = w
        }
  where
    (days, secs) = fromIntegral i `divMod` 86400
    -- 1970/1/1 is Thu (4)
    w = (days + 3) `mod` 7 + 1
    (y, m, d) = civilFromDays days
    (hhmm, s) = secs `quotRem` 60
    (h, n) = hhmm `quotRem` 60

-- Howard Hinnant's civil_from_days: days since 1970-01-01 to (y, m, d)
-- in constant time, for any sign. See:
-- http://howardhinnant.github.io/date_algorithms.html#civil_from_days
civilFromDays :: Int -> (Int, Int, Int)
civilFromDays z0 = (y + if m <= 2 then 1 else 0, m, d)
  where
    z = z0 + 719468
    era = z `div` 146097
    doe = z - era * 146097
    yoe = (doe - doe `quot` 1460 + doe `quot` 36524 - doe `quot` 146096) `quot` 365
    y = yoe + era * 400
    doy = doe - (365 * yoe + yoe `quot` 4 - yoe `quot` 100)
    mp = (5 * doy + 2) `quot` 153
    d = doy - (153 * mp + 2) `quot` 5 + 1
    m = if mp < 10 then mp + 3 else mp - 9

-- | Translating 'HTTPDate' to 'UTCTime'.
--
--   Out-of-range fields are clipped to the nearest valid value, as
--   'fromGregorian' does. 'hdWkday' is ignored. A second of 60 is kept
--   as a leap second only at 23:59. Use 'httpDateToUTCValid' to reject
--   invalid values instead.
--
-- >>> httpDateToUTC defaultHTTPDate {hdMonth = 2, hdDay = 31, hdHour = 25}
-- 1970-02-28 23:00:00 UTC
--
--   Since 0.0.7.
httpDateToUTC :: HTTPDate -> UTCTime
httpDateToUTC x = UTCTime (fromGregorian y m d) (secondsToDiffTime s)
  where
    y = fromIntegral $ hdYear x
    m = hdMonth x
    d = hdDay x
    h = clip 0 23 $ hdHour x
    n = clip 0 59 $ hdMinute x
    s0 = clip 0 60 $ hdSecond x
    s0'
        | s0 == 60 && (h /= 23 || n /= 59) = 59
        | otherwise = s0
    s = fromIntegral $ h * 3600 + n * 60 + s0'
    clip lo hi v = max lo $ min hi v

-- | Translating 'HTTPDate' to 'UTCTime' if all fields except
--   'hdWkday' are valid. A second of 60 is accepted only at 23:59.
--
-- >>> httpDateToUTCValid defaultHTTPDate {hdMonth = 2, hdDay = 31}
-- Nothing
--
--   Since 0.0.13.
httpDateToUTCValid :: HTTPDate -> Maybe UTCTime
httpDateToUTCValid x
    | validTime (hdHour x) (hdMinute x) (hdSecond x) = do
        day <- fromGregorianValid (fromIntegral $ hdYear x) (hdMonth x) (hdDay x)
        return $ UTCTime day $ secondsToDiffTime s
    | otherwise = Nothing
  where
    s = fromIntegral $ hdHour x * 3600 + hdMinute x * 60 + hdSecond x

validTime :: Int -> Int -> Int -> Bool
validTime h n s =
    0 <= h
        && h <= 23
        && 0 <= n
        && n <= 59
        && 0 <= s
        && (s <= 59 || s == 60 && h == 23 && n == 59)

-- | Translating 'UTCTime' to 'HTTPDate'.
--
--   Since 0.0.7.
utcToHTTPDate :: UTCTime -> HTTPDate
utcToHTTPDate x =
    defaultHTTPDate
        { hdYear = fromIntegral y
        , hdMonth = m
        , hdDay = d
        , hdHour = h
        , hdMinute = n
        , hdSecond = truncate s
        , hdWkday = w
        }
  where
    (y, m, d) = toGregorian day
    (h, n, s) = (todHour tod, todMin tod, todSec tod)
    (_, _, w) = toWeekDate day
    day = localDay time
    tod = localTimeOfDay time
    time = utcToLocalTime utc x