{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides the 'Timestamp' data type.
module Charon.Data.Timestamp
  ( Timestamp (..),
    toText,
    fromText,
    toTextSpace,
  )
where

import Charon.Class.Serial (Serial (DecodeExtra, decode, encode))
import Charon.Prelude
import Codec.Serialise (Serialise)
import Codec.Serialise qualified as Serialise
import Data.Aeson (FromJSON, ToJSON)
import Data.Text qualified as T
import Data.Time (Day (ModifiedJulianDay), TimeOfDay (TimeOfDay))
import Data.Time.Format qualified as Format
import Data.Time.LocalTime (LocalTime (LocalTime))

-- NOTE: We currently do not include any timezone information. We started
-- out doing so at first but then realized timezone parsing is unsatisfactory.
-- Parsing requires a locale, and the only one provided by the time package
-- (Format.defaultTimeLocale) is restricted to American timezones. The
-- time-conv package ostensibly fixes this, however it does not handle
-- daylight savings time i.e. parsing will fail on e.g. EDT, NZDT. Ideally we
-- would fix this upstream, though in the meantime we leave out timezone info
-- altogether.

-- | Represents a point in time.
newtype Timestamp = MkTimestamp
  { Timestamp -> LocalTime
unTimestamp :: LocalTime
  }
  deriving stock (Timestamp -> Timestamp -> Bool
(Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool) -> Eq Timestamp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timestamp -> Timestamp -> Bool
== :: Timestamp -> Timestamp -> Bool
$c/= :: Timestamp -> Timestamp -> Bool
/= :: Timestamp -> Timestamp -> Bool
Eq, (forall x. Timestamp -> Rep Timestamp x)
-> (forall x. Rep Timestamp x -> Timestamp) -> Generic Timestamp
forall x. Rep Timestamp x -> Timestamp
forall x. Timestamp -> Rep Timestamp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Timestamp -> Rep Timestamp x
from :: forall x. Timestamp -> Rep Timestamp x
$cto :: forall x. Rep Timestamp x -> Timestamp
to :: forall x. Rep Timestamp x -> Timestamp
Generic, Eq Timestamp
Eq Timestamp =>
(Timestamp -> Timestamp -> Ordering)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Bool)
-> (Timestamp -> Timestamp -> Timestamp)
-> (Timestamp -> Timestamp -> Timestamp)
-> Ord Timestamp
Timestamp -> Timestamp -> Bool
Timestamp -> Timestamp -> Ordering
Timestamp -> Timestamp -> Timestamp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Timestamp -> Timestamp -> Ordering
compare :: Timestamp -> Timestamp -> Ordering
$c< :: Timestamp -> Timestamp -> Bool
< :: Timestamp -> Timestamp -> Bool
$c<= :: Timestamp -> Timestamp -> Bool
<= :: Timestamp -> Timestamp -> Bool
$c> :: Timestamp -> Timestamp -> Bool
> :: Timestamp -> Timestamp -> Bool
$c>= :: Timestamp -> Timestamp -> Bool
>= :: Timestamp -> Timestamp -> Bool
$cmax :: Timestamp -> Timestamp -> Timestamp
max :: Timestamp -> Timestamp -> Timestamp
$cmin :: Timestamp -> Timestamp -> Timestamp
min :: Timestamp -> Timestamp -> Timestamp
Ord, Int -> Timestamp -> ShowS
[Timestamp] -> ShowS
Timestamp -> String
(Int -> Timestamp -> ShowS)
-> (Timestamp -> String)
-> ([Timestamp] -> ShowS)
-> Show Timestamp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Timestamp -> ShowS
showsPrec :: Int -> Timestamp -> ShowS
$cshow :: Timestamp -> String
show :: Timestamp -> String
$cshowList :: [Timestamp] -> ShowS
showList :: [Timestamp] -> ShowS
Show)
  deriving anyclass (Timestamp -> ()
(Timestamp -> ()) -> NFData Timestamp
forall a. (a -> ()) -> NFData a
$crnf :: Timestamp -> ()
rnf :: Timestamp -> ()
NFData)
  deriving (Value -> Parser [Timestamp]
Value -> Parser Timestamp
(Value -> Parser Timestamp)
-> (Value -> Parser [Timestamp]) -> FromJSON Timestamp
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Timestamp
parseJSON :: Value -> Parser Timestamp
$cparseJSONList :: Value -> Parser [Timestamp]
parseJSONList :: Value -> Parser [Timestamp]
FromJSON, Eq Timestamp
Eq Timestamp =>
(Int -> Timestamp -> Int)
-> (Timestamp -> Int) -> Hashable Timestamp
Int -> Timestamp -> Int
Timestamp -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Timestamp -> Int
hashWithSalt :: Int -> Timestamp -> Int
$chash :: Timestamp -> Int
hash :: Timestamp -> Int
Hashable, [Timestamp] -> Value
[Timestamp] -> Encoding
Timestamp -> Value
Timestamp -> Encoding
(Timestamp -> Value)
-> (Timestamp -> Encoding)
-> ([Timestamp] -> Value)
-> ([Timestamp] -> Encoding)
-> ToJSON Timestamp
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Timestamp -> Value
toJSON :: Timestamp -> Value
$ctoEncoding :: Timestamp -> Encoding
toEncoding :: Timestamp -> Encoding
$ctoJSONList :: [Timestamp] -> Value
toJSONList :: [Timestamp] -> Value
$ctoEncodingList :: [Timestamp] -> Encoding
toEncodingList :: [Timestamp] -> Encoding
ToJSON) via LocalTime

makeFieldLabelsNoPrefix ''Timestamp

instance Pretty Timestamp where
  pretty :: forall ann. Timestamp -> Doc ann
pretty = String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> Doc ann)
-> (Timestamp -> String) -> Timestamp -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> String
formatLocalTimeSpace (LocalTime -> String)
-> (Timestamp -> LocalTime) -> Timestamp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso NoIx Timestamp LocalTime -> Timestamp -> LocalTime
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx Timestamp LocalTime
#unTimestamp

instance Serialise Timestamp where
  encode :: Timestamp -> Encoding
encode (MkTimestamp (LocalTime (ModifiedJulianDay Integer
d) (TimeOfDay Int
h Int
m Pico
s))) =
    [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Integer -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Integer
d,
        Int -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Int
h,
        Int -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Int
m,
        Pico -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode Pico
s
      ]
  decode :: forall s. Decoder s Timestamp
decode =
    (\Integer
d Int
h Int
m Pico
s -> LocalTime -> Timestamp
MkTimestamp (LocalTime -> Timestamp) -> LocalTime -> Timestamp
forall a b. (a -> b) -> a -> b
$ Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> Day
ModifiedJulianDay Integer
d) (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m Pico
s))
      (Integer -> Int -> Int -> Pico -> Timestamp)
-> Decoder s Integer -> Decoder s (Int -> Int -> Pico -> Timestamp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. Serialise a => Decoder s a
Serialise.decode
      Decoder s (Int -> Int -> Pico -> Timestamp)
-> Decoder s Int -> Decoder s (Int -> Pico -> Timestamp)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
Serialise.decode
      Decoder s (Int -> Pico -> Timestamp)
-> Decoder s Int -> Decoder s (Pico -> Timestamp)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
Serialise.decode
      Decoder s (Pico -> Timestamp)
-> Decoder s Pico -> Decoder s Timestamp
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s Pico
forall s. Decoder s Pico
forall a s. Serialise a => Decoder s a
Serialise.decode

-- This instance instance exists for backends that need a general "serialize
-- this timestamp" function without having any particular format. For instance,
-- fdo backend needs to write timestamps to a string, but cbor/json will have
-- their own strategies.
instance Serial Timestamp where
  type DecodeExtra Timestamp = ()
  encode :: Timestamp -> Either String ByteString
encode = ByteString -> Either String ByteString
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String ByteString)
-> (Timestamp -> ByteString)
-> Timestamp
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Timestamp -> Text) -> Timestamp -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> Text
toText
  decode :: DecodeExtra Timestamp -> ByteString -> Either String Timestamp
decode DecodeExtra Timestamp
_ ByteString
bs = case ByteString -> Either UnicodeException Text
decodeUtf8 ByteString
bs of
    Left UnicodeException
err -> String -> Either String Timestamp
forall a b. a -> Either a b
Left (String -> Either String Timestamp)
-> String -> Either String Timestamp
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
err
    Right Text
timeStr -> case String -> Maybe LocalTime
forall (f :: * -> *). MonadFail f => String -> f LocalTime
parseLocalTime (Text -> String
T.unpack Text
timeStr) of
      Maybe LocalTime
Nothing -> String -> Either String Timestamp
forall a b. a -> Either a b
Left (String -> Either String Timestamp)
-> String -> Either String Timestamp
forall a b. (a -> b) -> a -> b
$ String
"Could not read time: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
timeStr
      Just LocalTime
t -> Timestamp -> Either String Timestamp
forall a b. b -> Either a b
Right (Timestamp -> Either String Timestamp)
-> Timestamp -> Either String Timestamp
forall a b. (a -> b) -> a -> b
$ LocalTime -> Timestamp
MkTimestamp LocalTime
t

-- | Formats the time.
toText :: Timestamp -> Text
toText :: Timestamp -> Text
toText = String -> Text
T.pack (String -> Text) -> (Timestamp -> String) -> Timestamp -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> String
formatLocalTime (LocalTime -> String)
-> (Timestamp -> LocalTime) -> Timestamp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso NoIx Timestamp LocalTime -> Timestamp -> LocalTime
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx Timestamp LocalTime
#unTimestamp

fromText :: (MonadFail f) => Text -> f Timestamp
fromText :: forall (f :: * -> *). MonadFail f => Text -> f Timestamp
fromText = (LocalTime -> Timestamp) -> f LocalTime -> f Timestamp
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTime -> Timestamp
MkTimestamp (f LocalTime -> f Timestamp)
-> (Text -> f LocalTime) -> Text -> f Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> f LocalTime
forall (f :: * -> *). MonadFail f => String -> f LocalTime
parseLocalTime (String -> f LocalTime) -> (Text -> String) -> Text -> f LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

formatLocalTime :: LocalTime -> String
formatLocalTime :: LocalTime -> String
formatLocalTime = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Format.formatTime TimeLocale
Format.defaultTimeLocale String
localTimeFormat

parseLocalTime :: (MonadFail f) => String -> f LocalTime
parseLocalTime :: forall (f :: * -> *). MonadFail f => String -> f LocalTime
parseLocalTime =
  Bool -> TimeLocale -> String -> String -> f LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
Format.parseTimeM
    Bool
True
    TimeLocale
Format.defaultTimeLocale
    String
localTimeFormat

localTimeFormat :: String
localTimeFormat :: String
localTimeFormat = String
"%0Y-%m-%dT%H:%M:%S"

-- | Like 'toText' except adds a space between date and time. Used for
-- pretty-printing.
toTextSpace :: Timestamp -> Text
toTextSpace :: Timestamp -> Text
toTextSpace = String -> Text
T.pack (String -> Text) -> (Timestamp -> String) -> Timestamp -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> String
formatLocalTimeSpace (LocalTime -> String)
-> (Timestamp -> LocalTime) -> Timestamp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' An_Iso NoIx Timestamp LocalTime -> Timestamp -> LocalTime
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx Timestamp LocalTime
#unTimestamp

-- | Like 'toText' except adds a space between date and time. Used for
-- pretty-printing.
formatLocalTimeSpace :: LocalTime -> String
formatLocalTimeSpace :: LocalTime -> String
formatLocalTimeSpace =
  TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Format.formatTime TimeLocale
Format.defaultTimeLocale String
localTimeFormatSpace

localTimeFormatSpace :: String
localTimeFormatSpace :: String
localTimeFormatSpace = String
"%0Y-%m-%d %H:%M:%S"