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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module TimeUtil
( now
, IsTime(..)
, fromTime
, toUTC
, parseRFC2822
, printRFC2822
, dateParser
) where
import Data.Time.LocalTime
import Data.Time.Format
import Data.Time.Clock
import Data.Time.Clock.POSIX
import System.Locale
import Data.String
import Control.Applicative
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Foreign.C.Types ( CTime(..) )
import Data.Word ( Word32 )
import ScanningParser
class IsTime a where
fromZonedTime :: ZonedTime -> a
toZonedTime :: a -> IO ZonedTime
instance IsTime ZonedTime where
fromZonedTime x = x
toZonedTime x = return x
instance IsTime UTCTime where
toZonedTime t = utcToLocalZonedTime t
fromZonedTime zt = zonedTimeToUTC zt
instance IsTime Integer where
toZonedTime t = utcToLocalZonedTime utime
where
utime = posixSecondsToUTCTime (fromIntegral t)
fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime
where
utime = zonedTimeToUTC zt
printRFC2822 :: (IsString b, IsTime a) => a -> IO b
printRFC2822 tm = do
zt@(ZonedTime lt z) <- toZonedTime tm
let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone
timeZoneStr = timeZoneOffsetString z
printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")"
return $ fromString $ rfc2822
parseRFC2822 :: IsTime b => S.ByteString -> Maybe b
parseRFC2822 str =
case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of
[] -> Nothing
(zt:_) -> Just $ fromZonedTime zt
where
str' = S.unpack stripped
stripped = strip $ str
strip bs = bs3
where
(_,bs0) = S.span isSpace bs
(bs1,_) = S.spanEnd isSpace bs0
(bs2,cp) = S.spanEnd (==')') bs1
bs3 = if S.null cp
then bs2
else let (op,_) = S.spanEnd (/='(') bs2
in fst $ S.spanEnd isSpace $ S.init op
formatRFC2822 = [ "%a, %e %b %Y %T GMT"
, "%a, %e %b %Y %T %z"
, "%e %b %Y %T GMT"
, "%e %b %Y %T %z"
, "%a, %e %b %Y %R GMT"
, "%a, %e %b %Y %R %z"
, "%e %b %Y %R GMT"
, "%e %b %Y %R %z"
]
now :: IO Integer
now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
dateParser :: ScanningParser L.ByteString UTCTime
dateParser = ScanningParser ffst pbdy
where
ffst bs = do
let (h,bs') = L.splitAt 6 bs
if h=="Date: "
then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs'
else Nothing
pbdy date xs = (date,xs)
class IsUTC a where
fromUTC :: UTCTime -> a
toUTC :: a -> UTCTime
fromTime :: ( IsUTC a, IsUTC b ) => a -> b
fromTime = fromUTC . toUTC
instance IsUTC UTCTime where
fromUTC = id
toUTC = id
instance IsUTC CTime where
fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc)
toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t)
instance IsUTC Word32 where
fromUTC utc = round $ utcTimeToPOSIXSeconds utc
toUTC t = posixSecondsToUTCTime (realToFrac t)
{-
main = do
nowtime <- now
printRFC2822 nowtime >>= putStrLn
let test1 = "Thu, 08 May 2014 23:24:47 -0400"
test2 = " Thu, 08 May 2014 23:24:47 -0400 (EDT) "
putStrLn $ show (parseRFC2822 test1 :: Maybe Integer)
putStrLn $ show (parseRFC2822 test2 :: Maybe Integer)
return ()
-}
|
