{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module TimeUtil
    ( now
    , IsTime(..)
    , fromTime
    , toUTC
    , parseRFC2822
    , printRFC2822
    , dateParser
    , IsUTC
    ) where

-- TODO: switch to hourglass package

import Data.Time.LocalTime
import Data.Time.Format
import Data.Time.Clock
import Data.Time.Clock.POSIX
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 ()
-}