{-# LANGUAGE BangPatterns #-}
module Network.HTTP.Date.Converter (epochTimeToHTTPDate) where
import Control.Applicative
import Data.ByteString.Internal
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Network.HTTP.Date.Types
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types
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'
w = (days + 3) `rem` 7 + 1
(y,m,d) = toYYMMDD days
(h,n,s) = toHHMMSS secs
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)
(months, daysArr) = if isLeap yy
then (leapMonth, leapDayInMonth)
else (normalMonth, normalDayInMonth)
findMonth n = inlinePerformIO $ (,) <$> (peekElemOff months 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