summaryrefslogtreecommitdiff
path: root/TimeUtil.hs
blob: 879bc3205c00889bce630b61743a22bf4d749f67 (plain)
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
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
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
#if !MIN_VERSION_time(1,5,0)
import System.Locale (defaultTimeLocale)
#endif
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 ()
-}