summaryrefslogtreecommitdiff
path: root/lib/TimeUtil.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/TimeUtil.hs')
-rw-r--r--lib/TimeUtil.hs128
1 files changed, 128 insertions, 0 deletions
diff --git a/lib/TimeUtil.hs b/lib/TimeUtil.hs
new file mode 100644
index 0000000..879bc32
--- /dev/null
+++ b/lib/TimeUtil.hs
@@ -0,0 +1,128 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE CPP #-}
4module TimeUtil
5 ( now
6 , IsTime(..)
7 , fromTime
8 , toUTC
9 , parseRFC2822
10 , printRFC2822
11 , dateParser
12 ) where
13
14import Data.Time.LocalTime
15import Data.Time.Format
16import Data.Time.Clock
17import Data.Time.Clock.POSIX
18#if !MIN_VERSION_time(1,5,0)
19import System.Locale (defaultTimeLocale)
20#endif
21import Data.String
22import Control.Applicative
23import Data.Maybe
24import Data.Char
25import qualified Data.ByteString.Char8 as S
26import qualified Data.ByteString.Lazy.Char8 as L
27import Foreign.C.Types ( CTime(..) )
28import Data.Word ( Word32 )
29
30import ScanningParser
31
32class IsTime a where
33 fromZonedTime :: ZonedTime -> a
34 toZonedTime :: a -> IO ZonedTime
35
36instance IsTime ZonedTime where
37 fromZonedTime x = x
38 toZonedTime x = return x
39
40instance IsTime UTCTime where
41 toZonedTime t = utcToLocalZonedTime t
42 fromZonedTime zt = zonedTimeToUTC zt
43
44instance IsTime Integer where
45 toZonedTime t = utcToLocalZonedTime utime
46 where
47 utime = posixSecondsToUTCTime (fromIntegral t)
48 fromZonedTime zt = round $ utcTimeToPOSIXSeconds utime
49 where
50 utime = zonedTimeToUTC zt
51
52printRFC2822 :: (IsString b, IsTime a) => a -> IO b
53printRFC2822 tm = do
54 zt@(ZonedTime lt z) <- toZonedTime tm
55 let rfc2822 = formatTime defaultTimeLocale "%a, %0e %b %Y %T" zt ++ printZone
56 timeZoneStr = timeZoneOffsetString z
57 printZone = " " ++ timeZoneStr ++ " (" ++ fromString (show z) ++ ")"
58 return $ fromString $ rfc2822
59
60parseRFC2822 :: IsTime b => S.ByteString -> Maybe b
61parseRFC2822 str =
62 case mapMaybe (\f->parseTime defaultTimeLocale f str') formatRFC2822 of
63 [] -> Nothing
64 (zt:_) -> Just $ fromZonedTime zt
65 where
66 str' = S.unpack stripped
67 stripped = strip $ str
68 strip bs = bs3
69 where
70 (_,bs0) = S.span isSpace bs
71 (bs1,_) = S.spanEnd isSpace bs0
72 (bs2,cp) = S.spanEnd (==')') bs1
73 bs3 = if S.null cp
74 then bs2
75 else let (op,_) = S.spanEnd (/='(') bs2
76 in fst $ S.spanEnd isSpace $ S.init op
77 formatRFC2822 = [ "%a, %e %b %Y %T GMT"
78 , "%a, %e %b %Y %T %z"
79 , "%e %b %Y %T GMT"
80 , "%e %b %Y %T %z"
81 , "%a, %e %b %Y %R GMT"
82 , "%a, %e %b %Y %R %z"
83 , "%e %b %Y %R GMT"
84 , "%e %b %Y %R %z"
85 ]
86
87now :: IO Integer
88now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
89
90dateParser :: ScanningParser L.ByteString UTCTime
91dateParser = ScanningParser ffst pbdy
92 where
93 ffst bs = do
94 let (h,bs') = L.splitAt 6 bs
95 if h=="Date: "
96 then return $ parseRFC2822 $ foldr1 S.append $ L.toChunks bs'
97 else Nothing
98 pbdy date xs = (date,xs)
99
100class IsUTC a where
101 fromUTC :: UTCTime -> a
102 toUTC :: a -> UTCTime
103
104fromTime :: ( IsUTC a, IsUTC b ) => a -> b
105fromTime = fromUTC . toUTC
106
107instance IsUTC UTCTime where
108 fromUTC = id
109 toUTC = id
110
111instance IsUTC CTime where
112 fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc)
113 toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t)
114
115instance IsUTC Word32 where
116 fromUTC utc = round $ utcTimeToPOSIXSeconds utc
117 toUTC t = posixSecondsToUTCTime (realToFrac t)
118
119{-
120main = do
121 nowtime <- now
122 printRFC2822 nowtime >>= putStrLn
123 let test1 = "Thu, 08 May 2014 23:24:47 -0400"
124 test2 = " Thu, 08 May 2014 23:24:47 -0400 (EDT) "
125 putStrLn $ show (parseRFC2822 test1 :: Maybe Integer)
126 putStrLn $ show (parseRFC2822 test2 :: Maybe Integer)
127 return ()
128-}