{-# 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
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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum EpochTime
x
(Word64
days',Word64
secs') = Word64
w64 forall a. Integral a => a -> a -> (a, a)
`quotRem` Word64
86400
days :: Int
days = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
days'
secs :: Int
secs = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
secs'
w :: Int
w = (Int
days forall a. Num a => a -> a -> a
+ Int
3) forall a. Integral a => a -> a -> a
`rem` Int
7 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
httpDateToUTC :: HTTPDate -> UTCTime
httpDateToUTC :: HTTPDate -> UTCTime
httpDateToUTC HTTPDate
x = Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
y Int
m Int
d) (Year -> DiffTime
secondsToDiffTime Year
s)
where
y :: Year
y = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 :: Year
s = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ (HTTPDate -> Int
hdHour HTTPDate
x forall a. Integral a => a -> a -> a
`rem` Int
24) forall a. Num a => a -> a -> a
* Int
3600
forall a. Num a => a -> a -> a
+ (HTTPDate -> Int
hdMinute HTTPDate
x forall a. Integral a => a -> a -> a
`rem` Int
60) forall a. Num a => a -> a -> a
* Int
60
forall a. Num a => a -> a -> a
+ (HTTPDate -> Int
hdSecond HTTPDate
x forall a. Integral a => a -> a -> a
`rem` Int
60)
utcToHTTPDate :: UTCTime -> HTTPDate
utcToHTTPDate :: UTCTime -> HTTPDate
utcToHTTPDate UTCTime
x = HTTPDate
defaultHTTPDate {
hdYear :: Int
hdYear = forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
y
, hdMonth :: Int
hdMonth = Int
m
, hdDay :: Int
hdDay = Int
d
, hdHour :: Int
hdHour = Int
h
, hdMinute :: Int
hdMinute = Int
n
, hdSecond :: Int
hdSecond = forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s
, hdWkday :: Int
hdWkday = forall a. Enum a => a -> Int
fromEnum (Int
w :: Int)
}
where
(Year
y, Int
m, Int
d) = Day -> (Year, 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))
(Year
_, Int
_, Int
w) = Day -> (Year, 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 forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
365
cy :: Int
cy = Int
1970 forall a. Num a => a -> a -> a
+ Int
y
cy' :: Int
cy' = Int
cy forall a. Num a => a -> a -> a
- Int
1
leap :: Int
leap = Int
cy' forall a. Integral a => a -> a -> a
`quot` Int
4 forall a. Num a => a -> a -> a
- Int
cy' forall a. Integral a => a -> a -> a
`quot` Int
100 forall a. Num a => a -> a -> a
+ Int
cy' forall a. Integral a => a -> a -> a
`quot` Int
400 forall a. Num a => a -> a -> a
- Int
477
(Int
yy,Int
days) = forall {t} {a}. (Integral t, Num a, Ord a) => t -> a -> a -> (t, a)
adjust Int
cy Int
d Int
leap
(Int
mm,Int
dd) = Int -> (Int, Int)
findMonth Int
days
adjust :: t -> a -> a -> (t, a)
adjust !t
ty a
td a
aj
| a
td forall a. Ord a => a -> a -> Bool
>= a
aj = (t
ty, a
td forall a. Num a => a -> a -> a
- a
aj)
| forall {a}. Integral a => a -> Bool
isLeap (t
ty forall a. Num a => a -> a -> a
- t
1) = if a
td forall a. Num a => a -> a -> a
+ a
366 forall a. Ord a => a -> a -> Bool
>= a
aj
then (t
ty forall a. Num a => a -> a -> a
- t
1, a
td forall a. Num a => a -> a -> a
+ a
366 forall a. Num a => a -> a -> a
- a
aj)
else t -> a -> a -> (t, a)
adjust (t
ty forall a. Num a => a -> a -> a
- t
1) (a
td forall a. Num a => a -> a -> a
+ a
366) a
aj
| Bool
otherwise = if a
td forall a. Num a => a -> a -> a
+ a
365 forall a. Ord a => a -> a -> Bool
>= a
aj
then (t
ty forall a. Num a => a -> a -> a
- t
1, a
td forall a. Num a => a -> a -> a
+ a
365 forall a. Num a => a -> a -> a
- a
aj)
else t -> a -> a -> (t, a)
adjust (t
ty forall a. Num a => a -> a -> a
- t
1) (a
td forall a. Num a => a -> a -> a
+ a
365) a
aj
isLeap :: a -> Bool
isLeap a
year = a
year forall a. Integral a => a -> a -> a
`rem` a
4 forall a. Eq a => a -> a -> Bool
== a
0
Bool -> Bool -> Bool
&& (a
year forall a. Integral a => a -> a -> a
`rem` a
400 forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
||
a
year forall a. Integral a => a -> a -> a
`rem` a
100 forall a. Eq a => a -> a -> Bool
/= a
0)
(Ptr Int
mnths, Ptr Int
daysArr) = if 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 = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Int
mnths Int
n) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (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 = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> IO (Ptr a)
newArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> a -> [a]
replicate) [Int
1..]
mkPtrInt2 :: [Int] -> Ptr Int
mkPtrInt2 :: [Int] -> Ptr Int
mkPtrInt2 = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> IO (Ptr a)
newArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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 forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
60
(Int
hh,Int
mm) = Int
hhmm forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
60