{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.IndexUtils.Timestamp
-- Copyright   :  (c) 2016 Herbert Valerio Riedel
-- License     :  BSD3
--
-- Timestamp type used in package indexes

module Distribution.Client.IndexUtils.Timestamp
    ( Timestamp
    , nullTimestamp
    , epochTimeToTimestamp
    , timestampToUTCTime
    , utcTimeToTimestamp
    , maximumTimestamp

    , IndexState(..)
    ) where

import Distribution.Client.Compat.Prelude

-- read is needed for Text instance
import Prelude (read)

import qualified Codec.Archive.Tar.Entry    as Tar
import           Data.Time                  (UTCTime (..), fromGregorianValid,
                                             makeTimeOfDayValid, showGregorian,
                                             timeOfDayToTime, timeToTimeOfDay)
import           Data.Time.Clock.POSIX      (posixSecondsToUTCTime,
                                             utcTimeToPOSIXSeconds)
import qualified Distribution.Deprecated.ReadP  as ReadP
import           Distribution.Deprecated.Text
import qualified Text.PrettyPrint           as Disp

-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
                  deriving (Eq,Ord,Enum,NFData,Show,Generic)

epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp
epochTimeToTimestamp et
  | ts == nullTimestamp  = Nothing
  | otherwise            = Just ts
  where
    ts = TS et

timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime (TS t)
  | t == minBound  = Nothing
  | otherwise      = Just $ posixSecondsToUTCTime (fromIntegral t)

utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp utct
  | minTime <= t, t <= maxTime  = Just (TS (fromIntegral t))
  | otherwise                   = Nothing
  where
    maxTime = toInteger (maxBound :: Int64)
    minTime = toInteger (succ minBound :: Int64)
    t :: Integer
    t = round . utcTimeToPOSIXSeconds $ utct

-- | Compute the maximum 'Timestamp' value
--
-- Returns 'nullTimestamp' for the empty list.  Also note that
-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp'
-- values.
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp [] = nullTimestamp
maximumTimestamp xs@(_:_) = maximum xs

-- returns 'Nothing' if not representable as 'Timestamp'
posixSecondsToTimestamp :: Integer -> Maybe Timestamp
posixSecondsToTimestamp pt
  | minTs <= pt, pt <= maxTs  = Just (TS (fromInteger pt))
  | otherwise                 = Nothing
  where
    maxTs = toInteger (maxBound :: Int64)
    minTs = toInteger (succ minBound :: Int64)

-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format
-- (e.g. @"2017-12-31T23:59:59Z"@)
--
-- Returns empty string for 'nullTimestamp' in order for
--
-- > null (display nullTimestamp) == True
--
-- to hold.
showTimestamp :: Timestamp -> String
showTimestamp ts = case timestampToUTCTime ts of
    Nothing          -> ""
    -- Note: we don't use 'formatTime' here to avoid incurring a
    -- dependency on 'old-locale' for older `time` libs
    Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"
  where
    showTOD = show . timeToTimeOfDay

instance Binary Timestamp
instance Structured Timestamp

instance Text Timestamp where
    disp = Disp.text . showTimestamp

    parse = parsePosix ReadP.+++ parseUTC
      where
        -- | Parses unix timestamps, e.g. @"\@1474626019"@
        parsePosix = do
            _ <- ReadP.char '@'
            t <- parseInteger
            maybe ReadP.pfail return $ posixSecondsToTimestamp t

        -- | Parses ISO8601/RFC3339-style UTC timestamps,
        -- e.g. @"2017-12-31T23:59:59Z"@
        --
        -- TODO: support numeric tz offsets; allow to leave off seconds
        parseUTC = do
            -- Note: we don't use 'Data.Time.Format.parseTime' here since
            -- we want more control over the accepted formats.

            ye <- parseYear
            _ <- ReadP.char '-'
            mo   <- parseTwoDigits
            _ <- ReadP.char '-'
            da   <- parseTwoDigits
            _ <- ReadP.char 'T'

            utctDay <- maybe ReadP.pfail return $
                       fromGregorianValid ye mo da

            ho   <- parseTwoDigits
            _ <- ReadP.char ':'
            mi   <- parseTwoDigits
            _ <- ReadP.char ':'
            se   <- parseTwoDigits
            _ <- ReadP.char 'Z'

            utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $
                           makeTimeOfDayValid ho mi (realToFrac (se::Int))

            maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..})

        parseTwoDigits = do
            d1 <- ReadP.satisfy isDigit
            d2 <- ReadP.satisfy isDigit
            return (read [d1,d2])

        -- A year must have at least 4 digits; e.g. "0097" is fine,
        -- while "97" is not c.f. RFC3339 which
        -- deprecates 2-digit years
        parseYear = do
            sign <- ReadP.option ' ' (ReadP.char '-')
            ds <- ReadP.munch1 isDigit
            when (length ds < 4) ReadP.pfail
            return (read (sign:ds))

        parseInteger = do
            sign <- ReadP.option ' ' (ReadP.char '-')
            ds <- ReadP.munch1 isDigit
            return (read (sign:ds) :: Integer)

-- | Special timestamp value to be used when 'timestamp' is
-- missing/unknown/invalid
nullTimestamp :: Timestamp
nullTimestamp = TS minBound

----------------------------------------------------------------------------
-- defined here for now to avoid import cycles

-- | Specification of the state of a specific repo package index
data IndexState = IndexStateHead -- ^ Use all available entries
                | IndexStateTime !Timestamp -- ^ Use all entries that existed at
                                            -- the specified time
                deriving (Eq,Generic,Show)

instance Binary IndexState
instance Structured IndexState
instance NFData IndexState

instance Text IndexState where
    disp IndexStateHead = Disp.text "HEAD"
    disp (IndexStateTime ts) = disp ts

    parse = parseHead ReadP.+++ parseTime
      where
        parseHead = do
            _ <- ReadP.string "HEAD"
            return IndexStateHead

        parseTime = IndexStateTime `fmap` parse