module NetSpider.Timestamp
(
Timestamp(..),
fromEpochMillisecond,
now,
addSec,
parseTimestamp,
fromS,
fromZonedTime,
fromUTCTime,
fromSystemTime,
fromLocalTime,
showEpochTime
) where
import Control.Applicative ((<$>), (<*>), (<*), (*>), optional)
import Data.Char (isDigit)
import Data.Int (Int64)
import Data.List (sortOn)
import Data.Text (Text, pack)
import Data.Time.Calendar (Day, fromGregorian)
import Data.Time.LocalTime
( TimeZone(..), getZonedTime, ZonedTime(..), zonedTimeToUTC, LocalTime(LocalTime), localTimeToUTC,
TimeOfDay(TimeOfDay)
)
import qualified Data.Time.LocalTime as LocalTime
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (utcToSystemTime, SystemTime(..))
import qualified Text.ParserCombinators.ReadP as P
import Text.Read (readEither)
data Timestamp =
Timestamp
{ epochTime :: !Int64,
timeZone :: !(Maybe TimeZone)
}
deriving (Show,Eq)
instance Ord Timestamp where
compare l r = compare (epochTime l) (epochTime r)
fromEpochMillisecond :: Int64 -> Timestamp
fromEpochMillisecond msec = Timestamp msec Nothing
showEpochTime :: Timestamp -> Text
showEpochTime = pack . show . epochTime
now :: IO Timestamp
now = fmap fromZonedTime $ getZonedTime
fromZonedTime :: ZonedTime -> Timestamp
fromZonedTime zt =
(fromUTCTime $ zonedTimeToUTC zt) { timeZone = Just $ zonedTimeZone zt }
fromUTCTime :: UTCTime -> Timestamp
fromUTCTime ut = (fromSystemTime $ utcToSystemTime ut) { timeZone = Just LocalTime.utc }
fromSystemTime :: SystemTime -> Timestamp
fromSystemTime stime = Timestamp { epochTime = epoch_time,
timeZone = Nothing
}
where
epoch_time = (systemSeconds stime * 1000)
+ fromIntegral (systemNanoseconds stime `div` 1000000)
fromLocalTime :: LocalTime -> Timestamp
fromLocalTime lt = (fromUTCTime $ localTimeToUTC LocalTime.utc lt) { timeZone = Nothing }
addSec :: Int64 -> Timestamp -> Timestamp
addSec diff ts = ts { epochTime = (+ (diff * 1000)) $ epochTime ts }
fromS :: String -> Timestamp
fromS s = maybe (error msg) id $ parseTimestamp s
where
msg = "Fail to parse " ++ s
parseTimestamp :: String -> Maybe Timestamp
parseTimestamp s = toTs $ sortByLeftover $ P.readP_to_S parserTimestamp s
where
sortByLeftover = sortOn $ \(_, leftover) -> length leftover
toTs ((ret, _) : _) = Just ret
toTs [] = Nothing
parserTimestamp :: P.ReadP Timestamp
parserTimestamp = do
day <- parserDay <* delim
time <- parserTime
mtz <- optional (parserUTC P.+++ parserOffset)
let ltime = LocalTime day time
case mtz of
Nothing -> return $ fromLocalTime ltime
Just tz -> return $ fromZonedTime $ ZonedTime ltime tz
where
delim = P.choice $ map P.char " T"
parserRead :: Read a => String -> P.ReadP a
parserRead input = either fail return $ readEither input
parserDec :: Read a => P.ReadP a
parserDec = parserRead =<< P.munch1 isDigit
parserFracDec :: Read a => P.ReadP a
parserFracDec = do
int <- P.munch1 isDigit
frac <- fmap (maybe "" id) $ optional ((:) <$> P.char '.' <*> P.munch1 isDigit)
return $ read (int ++ frac)
parserDay :: P.ReadP Day
parserDay = fromGregorian
<$> (parserDec <* delim)
<*> (parserDec <* delim)
<*> parserDec
where
delim = P.choice $ map P.char "-/"
parserTime :: P.ReadP TimeOfDay
parserTime = TimeOfDay
<$> parserDec
<*> (delim *> parserDec)
<*> ((delim *> parserFracDec) P.<++ pure 0)
where
delim = P.char ':'
parserUTC :: P.ReadP TimeZone
parserUTC = do
s <- P.get
case s of
'Z' -> return LocalTime.utc
c -> fail ("Not a UTC symbol: " ++ show c)
data OffsetSign = OffsetPlus
| OffsetMinus
deriving (Show,Eq,Ord,Enum,Bounded)
parserOffset :: P.ReadP TimeZone
parserOffset = offsetToTz <$> osign <*> (parserDec <* delim) <*> parserDec
where
osign = do
s <- P.get
case s of
'+' -> return OffsetPlus
'-' -> return OffsetMinus
c -> fail ("Not a sign symbol: " ++ show c)
delim = optional $ P.char ':'
offsetToTz :: OffsetSign -> Int -> Int -> TimeZone
offsetToTz osign h m = TimeZone { timeZoneMinutes = intsign * (h * 60 + m),
timeZoneSummerOnly = False,
timeZoneName = ""
}
where
intsign = case osign of
OffsetPlus -> 1
OffsetMinus -> -1