{-# LANGUAGE OverloadedStrings #-}
module NetSpider.Timestamp
(
Timestamp(..),
fromEpochMillisecond,
now,
addSec,
parseTimestamp,
fromS,
fromZonedTime,
fromUTCTime,
fromSystemTime,
fromLocalTime,
toTime,
toSystemTime,
showTimestamp,
showEpochTime
) where
import Control.Applicative ((<$>), (<*>), (<*), (*>), optional, empty)
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.Char (isDigit)
import Data.Int (Int64)
import Data.List (sortOn)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text
import Data.Time.Calendar (Day, fromGregorian)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (utcToSystemTime, SystemTime(..), systemToUTCTime)
import qualified Data.Time.Format as DTFormat
import Data.Time.LocalTime
( TimeZone(..), getZonedTime, ZonedTime(..), zonedTimeToUTC, LocalTime(LocalTime), localTimeToUTC,
TimeOfDay(TimeOfDay), utcToLocalTime, utcToZonedTime
)
import qualified Data.Time.LocalTime as LocalTime
import qualified Text.ParserCombinators.ReadP as P
import Text.Read (readEither)
import Text.Printf (printf)
import NetSpider.GraphML.Attribute
( ToAttributes(..),
AttributeValue(..)
)
data Timestamp =
Timestamp
{ epochTime :: Int64,
timeZone :: Maybe TimeZone
}
deriving (Show,Eq)
instance Ord Timestamp where
compare l r = compare (epochTime l) (epochTime r)
instance FromJSON Timestamp where
parseJSON (String t) = maybe (fail err_msg) return $ parseTimestamp ts
where
ts = unpack t
err_msg = "Invalid Timestamp string: " ++ ts
parseJSON (Object o) = Timestamp <$> (o .: "epoch_time") <*> parseTZ o
where
parseTZ ob = optional $ TimeZone
<$> (ob .: "tz_offset_min")
<*> (ob .: "tz_summer_only")
<*> (ob .: "tz_name")
parseJSON _ = empty
instance ToJSON Timestamp where
toJSON t = Aeson.object $
[ "epoch_time" .= epochTime t
]
++ tz_fields
where
tz_fields = (fmap . fmap) toJSON $ map fixKeyPrefix $ toAttributes $ timeZone t
fixKeyPrefix (k, v) = (Text.tail k, v)
instance ToAttributes Timestamp where
toAttributes t =
[ ("@timestamp", AttrLong $ toInteger $ epochTime t),
("@timestamp_str", AttrString $ showTimestamp t)
] ++ timezone_attrs
where
timezone_attrs = maybe [] toAttributes $ timeZone t
fromEpochMillisecond :: Int64 -> Timestamp
fromEpochMillisecond msec = Timestamp msec Nothing
showTimestamp :: Timestamp -> Text
showTimestamp = pack . either simpleFormat formatZT . toTime
where
dtFormat :: DTFormat.FormatTime t => String -> t -> String
dtFormat = DTFormat.formatTime DTFormat.defaultTimeLocale
simpleFormat :: DTFormat.FormatTime t => t -> String
simpleFormat = dtFormat "%Y-%m-%dT%H:%M:%S.%03q"
formatZT zt = simpleFormat zt <> formatZone (zonedTimeZone zt)
formatZone z = if timeZoneName z == ""
then formatOffset $ timeZoneMinutes z
else if z == LocalTime.utc
then "Z"
else dtFormat "%Z" z
formatOffset o = sign <> hour <> ":" <> minute
where
sign = if o < 0 then "-" else "+"
abo = abs o
hour = printf "%02d" (abo `div` 60)
minute = printf "%02d" (abo `mod` 60)
showEpochTime :: Timestamp -> Text
showEpochTime = pack . show . epochTime
toTime :: Timestamp -> Either LocalTime ZonedTime
toTime ts = maybe (Left localtime) (Right . toZT) $ timeZone ts
where
utctime = systemToUTCTime $ toSystemTime ts
localtime = utcToLocalTime LocalTime.utc utctime
toZT tz = utcToZonedTime tz utctime
toSystemTime :: Timestamp -> SystemTime
toSystemTime ts = MkSystemTime sec nsec
where
epoch_time = epochTime ts
sec = epoch_time `div` 1000
nsec = fromIntegral (epoch_time `mod` 1000) * 1000000
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