Converter.hs

{-# LANGUAGE BangPatterns #-}

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

import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Network.HTTP.Date.Types
import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)
import System.Posix.Types

-- |
--   Translating 'EpochTime' to 'HTTPDate'.
epochTimeToHTTPDate :: EpochTime -> HTTPDate
epochTimeToHTTPDate x
    | x < 0 = utcToHTTPDate $ posixSecondsToUTCTime $ realToFrac x
    | otherwise =
        defaultHTTPDate
            { hdYear = y
            , hdMonth = m
            , hdDay = d
            , hdHour = h
            , hdMinute = n
            , hdSecond = s
            , hdWkday = w
            }
  where
    w64 :: Word64
    w64 = fromIntegral $ fromEnum x
    (days', secs') = w64 `quotRem` 86400
    days = fromIntegral days'
    secs = fromIntegral secs'
    -- 1970/1/1 is Thu (4)
    w = (days + 3) `rem` 7 + 1
    (y, m, d) = toYYMMDD days
    (h, n, s) = toHHMMSS secs

-- | Translating 'HTTPDate' to 'UTCTime'.
--
--   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
    s =
        fromIntegral $
            (hdHour x `rem` 24) * 3600
                + (hdMinute x `rem` 60) * 60
                + (hdSecond x `rem` 60)

-- | 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 = fromEnum (w :: Int)
        }
  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

toYYMMDD :: Int -> (Int, Int, Int)
toYYMMDD x = (yy, mm, dd)
  where
    (y, d) = x `quotRem` 365
    cy = 1970 + y
    cy' = cy - 1
    leap = cy' `quot` 4 - cy' `quot` 100 + cy' `quot` 400 - 477
    (yy, days) = adjust cy d leap
    (mm, dd) = findMonth days
    adjust !ty td aj
        | td >= aj = (ty, td - aj)
        | isLeap (ty - 1) =
            if td + 366 >= aj
                then (ty - 1, td + 366 - aj)
                else adjust (ty - 1) (td + 366) aj
        | otherwise =
            if td + 365 >= aj
                then (ty - 1, td + 365 - aj)
                else adjust (ty - 1) (td + 365) aj
    isLeap year =
        year `rem` 4 == 0
            && ( year `rem` 400 == 0
                    || year `rem` 100 /= 0
               )
    (mnths, daysArr) =
        if isLeap yy
            then (leapMonth, leapDayInMonth)
            else (normalMonth, normalDayInMonth)
    findMonth n =
        unsafeDupablePerformIO $
            (,) <$> peekElemOff mnths n <*> peekElemOff daysArr n

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

normalMonthDays :: [Int]
normalMonthDays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]

leapMonthDays :: [Int]
leapMonthDays = [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]

mkPtrInt :: [Int] -> Ptr Int
mkPtrInt = unsafePerformIO . newArray . concat . zipWith (flip replicate) [1 ..]

mkPtrInt2 :: [Int] -> Ptr Int
mkPtrInt2 = unsafePerformIO . newArray . concatMap (enumFromTo 1)

normalMonth :: Ptr Int
normalMonth = mkPtrInt normalMonthDays

normalDayInMonth :: Ptr Int
normalDayInMonth = mkPtrInt2 normalMonthDays

leapMonth :: Ptr Int
leapMonth = mkPtrInt leapMonthDays

leapDayInMonth :: Ptr Int
leapDayInMonth = mkPtrInt2 leapMonthDays

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

toHHMMSS :: Int -> (Int, Int, Int)
toHHMMSS x = (hh, mm, ss)
  where
    (hhmm, ss) = x `quotRem` 60
    (hh, mm) = hhmm `quotRem` 60