{-# LANGUAGE BangPatterns #-}
module Network.HTTP.Date.Converter ( epochTimeToHTTPDate
                                   , httpDateToUTC
                                   , utcToHTTPDate
                                   ) where

import Data.Time
import Data.Time.Calendar.WeekDate
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 = 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