{-# 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 :: EpochTime -> HTTPDate
epochTimeToHTTPDate EpochTime
x = HTTPDate
defaultHTTPDate {
    hdYear :: Int
hdYear   = Int
y
  , hdMonth :: Int
hdMonth  = Int
m
  , hdDay :: Int
hdDay    = Int
d
  , hdHour :: Int
hdHour   = Int
h
  , hdMinute :: Int
hdMinute = Int
n
  , hdSecond :: Int
hdSecond = Int
s
  , hdWkday :: Int
hdWkday  = Int
w
  }
  where
    w64 :: Word64
    w64 :: Word64
w64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ EpochTime -> Int
forall a. Enum a => a -> Int
fromEnum EpochTime
x
    (Word64
days',Word64
secs') = Word64
w64 Word64 -> Word64 -> (Word64, Word64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word64
86400
    days :: Int
days = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
days'
    secs :: Int
secs = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
secs'
    -- 1970/1/1 is Thu (4)
    w :: Int
w = (Int
days Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    (Int
y,Int
m,Int
d) = Int -> (Int, Int, Int)
toYYMMDD Int
days
    (Int
h,Int
n,Int
s) = Int -> (Int, Int, Int)
toHHMMSS Int
secs

-- | Translating 'HTTPDate' to 'UTCTime'.
--
--   Since 0.0.7.
httpDateToUTC :: HTTPDate -> UTCTime
httpDateToUTC :: HTTPDate -> UTCTime
httpDateToUTC HTTPDate
x = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d) (Integer -> DiffTime
secondsToDiffTime Integer
s)
  where
    y :: Integer
y = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ HTTPDate -> Int
hdYear HTTPDate
x
    m :: Int
m = HTTPDate -> Int
hdMonth HTTPDate
x
    d :: Int
d = HTTPDate -> Int
hdDay HTTPDate
x
    s :: Integer
s = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ (HTTPDate -> Int
hdHour   HTTPDate
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
24) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3600
                     Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (HTTPDate -> Int
hdMinute HTTPDate
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
60) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60
                     Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (HTTPDate -> Int
hdSecond HTTPDate
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
60)

-- | Translating 'UTCTime' to 'HTTPDate'.
--
--   Since 0.0.7.
utcToHTTPDate :: UTCTime -> HTTPDate
utcToHTTPDate :: UTCTime -> HTTPDate
utcToHTTPDate UTCTime
x = HTTPDate
defaultHTTPDate {
    hdYear :: Int
hdYear   = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y
  , hdMonth :: Int
hdMonth  = Int
m
  , hdDay :: Int
hdDay    = Int
d
  , hdHour :: Int
hdHour   = Int
h
  , hdMinute :: Int
hdMinute = Int
n
  , hdSecond :: Int
hdSecond = Pico -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s
  , hdWkday :: Int
hdWkday  = Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int
w :: Int)
  }
  where
    (Integer
y, Int
m, Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
    (Int
h, Int
n, Pico
s) = ((TimeOfDay -> Int
todHour TimeOfDay
tod), (TimeOfDay -> Int
todMin TimeOfDay
tod), (TimeOfDay -> Pico
todSec TimeOfDay
tod))
    (Integer
_, Int
_, Int
w) = Day -> (Integer, Int, Int)
toWeekDate Day
day
    day :: Day
day       = LocalTime -> Day
localDay LocalTime
time
    tod :: TimeOfDay
tod       = LocalTime -> TimeOfDay
localTimeOfDay LocalTime
time
    time :: LocalTime
time      = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
x

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

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

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

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

mkPtrInt :: [Int] -> Ptr Int
mkPtrInt :: [Int] -> Ptr Int
mkPtrInt = IO (Ptr Int) -> Ptr Int
forall a. IO a -> a
unsafePerformIO (IO (Ptr Int) -> Ptr Int)
-> ([Int] -> IO (Ptr Int)) -> [Int] -> Ptr Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IO (Ptr Int)
forall a. Storable a => [a] -> IO (Ptr a)
newArray ([Int] -> IO (Ptr Int))
-> ([Int] -> [Int]) -> [Int] -> IO (Ptr Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> ([Int] -> [[Int]]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> [Int]) -> [Int] -> [Int] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Int -> Int -> [Int]) -> Int -> Int -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate) [Int
1..]

mkPtrInt2 :: [Int] -> Ptr Int
mkPtrInt2 :: [Int] -> Ptr Int
mkPtrInt2 = IO (Ptr Int) -> Ptr Int
forall a. IO a -> a
unsafePerformIO (IO (Ptr Int) -> Ptr Int)
-> ([Int] -> IO (Ptr Int)) -> [Int] -> Ptr Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IO (Ptr Int)
forall a. Storable a => [a] -> IO (Ptr a)
newArray ([Int] -> IO (Ptr Int))
-> ([Int] -> [Int]) -> [Int] -> IO (Ptr Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
1)

normalMonth :: Ptr Int
normalMonth :: Ptr Int
normalMonth = [Int] -> Ptr Int
mkPtrInt [Int]
normalMonthDays

normalDayInMonth :: Ptr Int
normalDayInMonth :: Ptr Int
normalDayInMonth = [Int] -> Ptr Int
mkPtrInt2 [Int]
normalMonthDays

leapMonth :: Ptr Int
leapMonth :: Ptr Int
leapMonth = [Int] -> Ptr Int
mkPtrInt [Int]
leapMonthDays

leapDayInMonth :: Ptr Int
leapDayInMonth :: Ptr Int
leapDayInMonth = [Int] -> Ptr Int
mkPtrInt2 [Int]
leapMonthDays

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

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