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 @@
+{-# 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 ()
+-}