graphql-engine/server/src-lib/Data/Time/Clock/Units.hs

{-# LANGUAGE NumDecimals #-}

-- | Types for time intervals of various units. Each newtype wraps 'DiffTime',
-- but they have different 'Num' instances. The intent is to use the record
-- selectors to write literals with particular units, like this:
--
-- @
-- >>> 'milliseconds' 500
-- 0.5s
-- >>> 'hours' 3
-- 10800s
-- >>> 'minutes' 1.5 + 'seconds' 30
-- 120s
-- @
--
-- You can also go the other way using the constructors rather than the selectors:
--
-- @
-- >>> 'toRational' '$' 'Minutes' ('seconds' 17)
-- 17 % 60
-- >>> 'realToFrac' ('Days' ('hours' 12)) :: 'Double'
-- 0.5
-- @
--
-- NOTE: the 'Real' and 'Fractional' instances just essentially add or strip the
-- unit label (as  above), so you can't use 'realToFrac' to convert between the
-- units types here. Instead try  'convertDuration' which is less of a foot-gun.
--
-- The 'Read' instances for these types mirror the behavior of the 'RealFrac'
-- instance wrt numeric literals for convenient serialization (e.g. when working
-- with env vars):
--
-- @
-- >>> read "1.2" :: Milliseconds
-- Milliseconds {milliseconds = 0.0012s}
-- @
--
-- Generally, if you need to pass around a duration between functions you should
-- use 'DiffTime' directly. However if storing a duration in a type that will be
-- serialized, e.g. one having a 'ToJSON' instance, it is better to use one of
-- these explicit wrapper types so that it's  obvious what units will be used.
module Data.Time.Clock.Units
  ( Days (..),
    Hours (..),
    Minutes (..),
    Seconds (..),
    Milliseconds (..),
    Microseconds (..),
    Nanoseconds (..),

    -- * Converting between units
    Duration (..),
    convertDuration,

    -- * Reexports

    -- | We use 'DiffTime' as the standard type for unit-agnostic duration in our
    -- code. You'll need to convert to a 'NominalDiffTime'  (with 'convertDuration') in
    -- order to do anything useful with 'UTCTime' with these durations.
    --
    -- NOTE: some care must be taken especially when 'NominalDiffTime' interacts
    -- with 'UTCTime':
    --
    --  - a 'DiffTime' or 'NominalDiffTime' may be negative
    --  - 'addUTCTime' and 'diffUTCTime' do not attempt to handle leap seconds
    DiffTime,
    diffTimeToMicroSeconds,
  )
where

import Control.Applicative ((<|>))
import Control.Arrow (first)
import Data.Aeson
import Data.Hashable
import Data.Proxy
import Data.Text (unpack)
import Data.Time.Clock
import GHC.TypeLits
import Numeric (readFloat)
import Text.Read qualified as TR
import Prelude

newtype Seconds = Seconds {seconds :: DiffTime}
  -- NOTE: we want Show to give a pastable data structure string, even
  -- though Read is custom.
  deriving (Duration, Show, Eq, Ord, ToJSON, FromJSON)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 1))

-- TODO if needed: deriving (ToJSON, FromJSON) via (TimeUnit ..) making sure
--      to copy Aeson instances (with withBoundedScientific), and e.g.
--         toJSON (5 :: Minutes) == Number 5
newtype Days = Days {days :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 86400))

newtype Hours = Hours {hours :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 3600))

newtype Minutes = Minutes {minutes :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 60))

newtype Milliseconds = Milliseconds {milliseconds :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000000000)

-- TODO: Has an alternative string representation instead of a numberic one here
-- in order to clarify what's going on.
-- Rounding is also problematic, but should be ok for now...
instance ToJSON Milliseconds where
  toJSON = toJSON . flip div 1e9 . diffTimeToPicoseconds . milliseconds

instance FromJSON Milliseconds where
  parseJSON v =
    withScientific "Milliseconds Number" (pure . Milliseconds . picosecondsToDiffTime . (* 1e9) . ceiling) v
      <|> withText "Milliseconds String" (either (fail . show) pure . TR.readEither . unpack) v

newtype Microseconds = Microseconds {microseconds :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000000)

newtype Nanoseconds = Nanoseconds {nanoseconds :: DiffTime}
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000)

-- Internal for deriving via
newtype TimeUnit (picosPerUnit :: Nat) = TimeUnit DiffTime
  deriving (Show, Eq, Ord)

type SecondsP n = n GHC.TypeLits.* 1000000000000

natNum :: forall n a. (KnownNat n, Num a) => a
natNum = fromInteger $ natVal (Proxy @n)

instance (KnownNat picosPerUnit) => Num (TimeUnit picosPerUnit) where
  TimeUnit a + TimeUnit b = TimeUnit $ a + b
  TimeUnit a - TimeUnit b = TimeUnit $ a - b
  TimeUnit a * TimeUnit b =
    TimeUnit . picosecondsToDiffTime $
      diffTimeToPicoseconds a * diffTimeToPicoseconds b `div` natNum @picosPerUnit
  negate (TimeUnit a) = TimeUnit $ negate a
  abs (TimeUnit a) = TimeUnit $ abs a
  signum (TimeUnit a) = TimeUnit $ signum a
  fromInteger a = TimeUnit . picosecondsToDiffTime $ a * natNum @picosPerUnit

instance (KnownNat picosPerUnit) => Read (TimeUnit picosPerUnit) where
  readsPrec _ = map (first fromRational) . readFloat

instance (KnownNat picosPerUnit) => Fractional (TimeUnit picosPerUnit) where
  TimeUnit a / TimeUnit b =
    TimeUnit . picosecondsToDiffTime $
      diffTimeToPicoseconds a * natNum @picosPerUnit `div` diffTimeToPicoseconds b
  fromRational a = TimeUnit . picosecondsToDiffTime $ round (a * natNum @picosPerUnit)

instance (KnownNat picosPerUnit) => Real (TimeUnit picosPerUnit) where
  toRational (TimeUnit a) = toRational (diffTimeToPicoseconds a) / natNum @picosPerUnit

instance (KnownNat picosPerUnit) => RealFrac (TimeUnit picosPerUnit) where
  properFraction a = (i, a - fromIntegral i)
    where
      i = truncate a
  truncate = truncate . toRational
  round = round . toRational
  ceiling = ceiling . toRational
  floor = floor . toRational

-- we can ignore unit:
instance Hashable (TimeUnit a) where
  hashWithSalt salt (TimeUnit dt) =
    hashWithSalt salt $
      (realToFrac :: DiffTime -> Double) dt

-- | Duration types isomorphic to 'DiffTime', powering 'convertDuration'.
class Duration d where
  fromDiffTime :: DiffTime -> d
  toDiffTime :: d -> DiffTime

instance Duration DiffTime where
  fromDiffTime = id
  toDiffTime = id

instance Duration NominalDiffTime where
  fromDiffTime = realToFrac
  toDiffTime = realToFrac

-- | Safe conversion between duration units.
convertDuration :: (Duration x, Duration y) => x -> y
convertDuration = fromDiffTime . toDiffTime

diffTimeToMicroSeconds :: DiffTime -> Integer
diffTimeToMicroSeconds = (`div` 1000000) . diffTimeToPicoseconds