1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# 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
|
