Time.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Gogol.Data.Time
-- Copyright   : (c) 2015-2022 Brendan Hay <brendan.g.hay@gmail.com>
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Gogol.Data.Time
  ( Time (..),
    Date (..),
    DateTime (..),
    Duration (..),
    _Time,
    _Date,
    _DateTime,
    _Duration,
  )
where

import Control.Lens
import Data.Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Attoparsec.Text
import Data.Bifunctor (first, second)
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Scientific (Scientific)
import Data.Scientific qualified as Sci
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as LText
import Data.Text.Lazy.Builder qualified as Build
import Data.Text.Lazy.Builder.Scientific qualified as Sci
import Data.Time
import GHC.Generics
import Web.HttpApiData
  ( FromHttpApiData (..),
    ToHttpApiData (..),
  )

-- | This SHOULD be a time in the format of hh:mm:ss.  It is
-- recommended that you use the "date-time" format instead of "time"
-- unless you need to transfer only the time part.
newtype Time = Time {fromTime :: TimeOfDay}
  deriving (Eq, Ord, Show, Read, Generic)

_Time :: Iso' Time TimeOfDay
_Time = iso fromTime Time

instance ToHttpApiData Time where
  toQueryParam = Text.pack . show . fromTime

instance FromHttpApiData Time where
  parseQueryParam = second Time . parseText timeParser

-- | This SHOULD be a date in the format of YYYY-MM-DD.  It is
-- recommended that you use the "date-time" format instead of "date"
-- unless you need to transfer only the date part.
newtype Date = Date {unDate :: Day}
  deriving (Eq, Ord, Show, Read, Generic, ToHttpApiData, FromHttpApiData)

_Date :: Iso' Date Day
_Date = iso unDate Date

-- | This SHOULD be a date in ISO 8601 format of YYYY-MM-
-- DDThh:mm:ssZ in UTC time. This is the recommended form of date/timestamp.
newtype DateTime = DateTime {unDateTime :: UTCTime}
  deriving (Eq, Ord, Show, Read, Generic, ToHttpApiData, FromHttpApiData)

_DateTime :: Iso' DateTime UTCTime
_DateTime = iso unDateTime DateTime

-- | A duration in seconds with up to nine fractional digits, terminated by 's'.
--
-- /Example/: @"3.5s"@.
newtype Duration = Duration {unDuration :: Scientific}
  deriving (Eq, Ord, Show, Read, Generic)

_Duration :: Iso' Duration Scientific
_Duration = iso unDuration Duration

instance ToHttpApiData Duration where
  toQueryParam =
    LText.toStrict
      . (\seconds -> Build.toLazyText seconds <> "s")
      . Sci.formatScientificBuilder Sci.Fixed (Just 9)
      . unDuration

instance FromHttpApiData Duration where
  parseQueryParam = second Duration . parseText durationParser

instance ToJSON Time where toJSON = String . toQueryParam

instance ToJSON Date where toJSON = String . toQueryParam

instance ToJSON DateTime where toJSON = toJSON . unDateTime

instance ToJSON Duration where toJSON = String . toQueryParam

instance FromJSON Time where
  parseJSON = fmap Time . withText "Time" (run timeParser)

instance FromJSON Date where
  parseJSON = fmap Date . withText "Date" (run dayParser)

instance FromJSON DateTime where
  parseJSON = fmap DateTime . parseJSON

instance FromJSON Duration where
  parseJSON = fmap Duration . withText "Duration" (run durationParser)

parseText :: Parser a -> Text -> Either Text a
parseText p = first Text.pack . parseOnly p

-- | Parse a time of the form @HH:MM:SS@.
timeParser :: Parser TimeOfDay
timeParser = do
  h <- twoDigits <* char ':'
  m <- twoDigits <* char ':'
  s <- twoDigits <&> fromIntegral
  if h < 24 && m < 60 && s < 61
    then pure (TimeOfDay h m s)
    else fail "invalid time"

-- | Parse a date of the form @YYYY-MM-DD@.
dayParser :: Parser Day
dayParser = do
  y <- decimal <* char '-'
  m <- twoDigits <* char '-'
  d <- twoDigits
  maybe (fail "invalid date") pure (fromGregorianValid y m d)

durationParser :: Parser Scientific
durationParser = Sci.fromFloatDigits <$> (double <* char 's')

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: Parser Int
twoDigits = do
  a <- digit
  b <- digit
  let c2d c = ord c .&. 15
  pure $! c2d a * 10 + c2d b

-- | Run an attoparsec parser as an aeson parser.
run :: Parser a -> Text -> Aeson.Parser a
run p t =
  case parseOnly (p <* endOfInput) t of
    Left err -> fail $ "could not parse date: " ++ err
    Right r -> pure r