summaryrefslogtreecommitdiff
path: root/lib/TimeUtil.hs
blob: b678d5fe69defab6090bccb1fbf0a92381dd45b7 (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
129
130
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
module TimeUtil
    ( now
    , IsTime(..)
    , fromTime
    , toUTC
    , parseRFC2822
    , printRFC2822
    , dateParser
    ) where

-- TODO: switch to hourglass package

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 ()
-}