-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Core primitive Tezos types.

module Tezos.Core
  (
    -- * Mutez
    Mutez (unMutez)
  , mkMutez
  , mkMutez'
  , unsafeMkMutez
  , toMutez
  , addMutez
  , unsafeAddMutez
  , subMutez
  , unsafeSubMutez
  , mulMutez
  , divModMutez
  , divModMutezInt
  , zeroMutez
  , oneMutez

    -- * Timestamp
  , Timestamp (..)
  , timestampToSeconds
  , timestampFromSeconds
  , timestampFromUTCTime
  , timestampToUTCTime
  , timestampPlusSeconds
  , formatTimestamp
  , parseTimestamp
  , timestampQuote
  , getCurrentTime
  , farFuture
  , farPast

    -- * ChainId
  , ChainId (..)
  , mkChainId
  , mkChainIdUnsafe
  , dummyChainId
  , formatChainId
  , mformatChainId
  , parseChainId
  , chainIdLength
  ) where

import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson as Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Data.Time.LocalTime (utc, utcToZonedTime)
import Data.Time.RFC3339 (formatTimeRFC3339)
import Fmt (Buildable(build), fmt, hexF, pretty)
import qualified Language.Haskell.TH.Quote as TH
import Language.Haskell.TH.Syntax (liftData)
import qualified Options.Applicative as Opt

import Michelson.Text
import Tezos.Crypto
import Util.Aeson
import Util.CLI
import Util.Num

----------------------------------------------------------------------------
-- Mutez
----------------------------------------------------------------------------

-- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).
newtype Mutez = Mutez
  { unMutez :: Word64
  } deriving stock (Show, Eq, Ord, Data, Generic)
    deriving newtype Enum

instance Buildable Mutez where
  build (Mutez w) = build w <> " μꜩ"

instance Bounded Mutez where
  minBound = Mutez 0
  -- 2⁶³ - 1
  -- This value was checked against the reference implementation.
  maxBound = Mutez 9223372036854775807

instance HasCLReader Mutez where
  getReader = maybe (readerError "Invalid mutez") pure . mkMutez =<< Opt.auto
  getMetavar = "MUTEZ"

instance NFData Mutez

-- | Safely create 'Mutez' checking for overflow.
mkMutez :: Word64 -> Maybe Mutez
mkMutez n
  | n <= unMutez maxBound = Just (Mutez n)
  | otherwise = Nothing
{-# INLINE mkMutez #-}

-- | Version of 'mkMutez' that accepts a number of any type.
mkMutez' :: Integral i => i -> Either Text Mutez
mkMutez' i = do
  w :: Word64 <- fromIntegralChecked i
  mkMutez w
    & maybeToRight "Mutez overflow"

-- | Partial function for 'Mutez' creation, it's pre-condition is that
-- the argument must not exceed the maximal 'Mutez' value.
unsafeMkMutez :: HasCallStack => Word64 -> Mutez
unsafeMkMutez n =
  fromMaybe (error $ "mkMutez: overflow (" <> show n <> ")") (mkMutez n)
{-# INLINE unsafeMkMutez #-}

-- | Safely create 'Mutez'.
--
-- This is recommended way to create @Mutez@ from a numeric literal;
-- you can't construct all valid @Mutez@ values using this function
-- but for small values it works neat.
--
-- Warnings displayed when trying to construct invalid 'Natural' or 'Word'
-- literal are hardcoded for these types in GHC implementation, so we can only
-- exploit these existing rules.
toMutez :: Word32 -> Mutez
toMutez = unsafeMkMutez . fromIntegral
{-# INLINE toMutez #-}

-- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow.
addMutez :: Mutez -> Mutez -> Maybe Mutez
addMutez (unMutez -> a) (unMutez -> b) =
  mkMutez (a + b) -- (a + b) can't overflow if 'Mutez' values are valid
{-# INLINE addMutez #-}

-- | Partial addition of 'Mutez', should be used only if you're
-- sure there'll be no overflow.
unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez
unsafeAddMutez = fromMaybe (error "unsafeAddMutez: overflow") ... addMutez

-- | Subtraction of 'Mutez' values. Returns 'Nothing' when the
-- subtrahend is greater than the minuend, and 'Just' otherwise.
subMutez :: Mutez -> Mutez -> Maybe Mutez
subMutez (unMutez -> a) (unMutez -> b)
  | a >= b = Just (Mutez (a - b))
  | otherwise = Nothing
{-# INLINE subMutez #-}

-- | Partial subtraction of 'Mutez', should be used only if you're
-- sure there'll be no underflow.
unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez
unsafeSubMutez = fromMaybe (error "unsafeSubMutez: underflow") ... subMutez

-- | Multiplication of 'Mutez' and an integral number. Returns
-- 'Nothing' in case of overflow.
mulMutez :: Integral a => Mutez -> a -> Maybe Mutez
mulMutez (unMutez -> a) b
    | res <= toInteger (unMutez maxBound) = Just (Mutez (fromInteger res))
    | otherwise = Nothing
  where
    res = toInteger a * toInteger b
{-# INLINE mulMutez #-}

-- | Euclidian division of two 'Mutez' values.
divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)
divModMutez a (unMutez -> b) = first unMutez <$> divModMutezInt a b

-- | Euclidian division of  'Mutez' and a number.
divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)
divModMutezInt (toInteger . unMutez -> a) (toInteger -> b)
  | b <= 0 = Nothing
  | otherwise = Just $ bimap toMutez' toMutez' (a `divMod` b)
  where
    toMutez' :: Integer -> Mutez
    toMutez' = Mutez . fromInteger

zeroMutez :: Mutez
zeroMutez = Mutez minBound

oneMutez :: Mutez
oneMutez = Mutez 1

----------------------------------------------------------------------------
-- Timestamp
----------------------------------------------------------------------------

-- | Time in the real world.
-- Use the functions below to convert it to/from Unix time in seconds.
newtype Timestamp = Timestamp
  { unTimestamp :: POSIXTime
  } deriving stock (Show, Eq, Ord, Data, Generic)

instance NFData Timestamp

timestampToSeconds :: Integral a => Timestamp -> a
timestampToSeconds = round . unTimestamp
{-# INLINE timestampToSeconds #-}

timestampFromSeconds :: Integer -> Timestamp
timestampFromSeconds = Timestamp . fromIntegral
{-# INLINE timestampFromSeconds #-}

timestampFromUTCTime :: UTCTime -> Timestamp
timestampFromUTCTime = Timestamp . utcTimeToPOSIXSeconds
{-# INLINE timestampFromUTCTime #-}

timestampToUTCTime :: Timestamp -> UTCTime
timestampToUTCTime = posixSecondsToUTCTime . unTimestamp
{-# INLINE timestampToUTCTime #-}

-- | Add given amount of seconds to a 'Timestamp'.
timestampPlusSeconds :: Timestamp -> Integer -> Timestamp
timestampPlusSeconds ts sec = timestampFromSeconds (timestampToSeconds ts + sec)

-- | Display timestamp in human-readable way as used by Michelson.
-- Uses UTC timezone, though maybe we should take it as an argument.
--
-- NB: this will render timestamp with up to seconds precision.
formatTimestamp :: Timestamp -> Text
formatTimestamp =
  formatTimeRFC3339 . utcToZonedTime utc . posixSecondsToUTCTime . unTimestamp

instance Buildable Timestamp where
  build = build . formatTimestamp

-- | Parse textual representation of 'Timestamp'.
parseTimestamp :: Text -> Maybe Timestamp
parseTimestamp t
  -- `parseTimeM` does not allow to match on a single whitespace exclusively
  | T.isInfixOf "  " t = Nothing
  | otherwise = fmap timestampFromUTCTime . asum $ map parse formatsRFC3339
  where
    parse :: Text -> Maybe UTCTime
    parse frmt = parseTimeM False defaultTimeLocale (toString frmt) (toString t)

    formatsRFC3339 :: [Text]
    formatsRFC3339 = do
      divider <- ["T", " "]
      fraction <- ["%Q", ""]
      zone <- ["Z", "%z"]
      return $ "%-Y-%m-%d" <> divider <> "%T" <> fraction <> zone

-- | Quote a value of type 'Timestamp' in @yyyy-mm-ddThh:mm:ss[.sss]Z@ format.
--
-- >>> formatTimestamp [timestampQuote| 2019-02-21T16:54:12.2344523Z |]
-- "2019-02-21T16:54:12Z"
--
-- Inspired by 'time-quote' library.
timestampQuote :: TH.QuasiQuoter
timestampQuote =
  TH.QuasiQuoter
  { quoteExp = \str ->
      case parseTimestamp . T.strip $ toText str of
        Nothing -> fail "Invalid timestamp, \
                        \example of valid value: `2019-02-21T16:54:12.2344523Z`"
        Just ts -> liftData ts
  , quotePat = \_ -> fail "timestampQuote: cannot quote pattern!"
  , quoteType = \_ -> fail "timestampQuote: cannot quote type!"
  , quoteDec = \_ -> fail "timestampQuote: cannot quote declaration!"
  }

-- | Return current time as 'Timestamp'.
getCurrentTime :: IO Timestamp
getCurrentTime = Timestamp <$> getPOSIXTime

-- | Timestamp which is always greater than result of 'getCurrentTime'.
farFuture :: Timestamp
farFuture = timestampFromSeconds 1e12  -- 33658-09-27T01:46:40Z

-- | Timestamp which is always less than result of 'getCurrentTime'.
farPast :: Timestamp
farPast = timestampFromSeconds 0

----------------------------------------------------------------------------
-- Chain ID
----------------------------------------------------------------------------

{- Chain id in Tezos sources:
* https://gitlab.com/tezos/tezos/blob/de5c80b360aa396114be92a3a2e2ff2087190a61/src/lib_crypto/chain_id.ml
-}

-- | Identifier of a network (babylonnet, mainnet, test network or other).
-- Evaluated as hash of the genesis block.
--
-- The only operation supported for this type is packing.
-- Use case: multisig contract, for instance, now includes chain ID into
-- signed data "in order to add extra replay protection between the main
-- chain and the test chain".
newtype ChainId = ChainIdUnsafe { unChainId :: ByteString }
  deriving stock (Show, Eq, Generic)

instance NFData ChainId

-- | Construct chain ID from raw bytes.
mkChainId :: ByteString -> Maybe ChainId
mkChainId bs =
  guard (length bs == chainIdLength) $> ChainIdUnsafe bs

-- | Construct chain ID from raw bytes or fail otherwise.
-- Expects exactly 4 bytes.
mkChainIdUnsafe :: HasCallStack => ByteString -> ChainId
mkChainIdUnsafe = fromMaybe (error "Bad chain id") . mkChainId

-- | Identifier of a pseudo network.
dummyChainId :: ChainId
dummyChainId = ChainIdUnsafe "\0\0\0\0"

-- | Pretty print 'ChainId' as it is displayed e.g. in @./babylonnet.sh head@ call.
--
-- Example of produced value: "NetXUdfLh6Gm88t".
formatChainId :: ChainId -> Text
formatChainId (unChainId -> bs) = encodeBase58Check (chainIdPrefix <> bs)

mformatChainId :: ChainId -> MText
mformatChainId = mkMTextUnsafe . formatChainId

instance Buildable ChainId where
  build = build . formatChainId

data ParseChainIdError
  = ParseChainIdWrongBase58Check
  | ParseChainIdWrongTag ByteString
  | ParseChainIdWrongSize Int
  deriving stock (Show, Eq)

instance Buildable ParseChainIdError where
  build =
    \case
      ParseChainIdWrongBase58Check ->
        "Wrong base58check format"
      ParseChainIdWrongTag tag ->
        "Wrong tag for a chain id: " <> fmt (hexF tag)
      ParseChainIdWrongSize s ->
        "Wrong size for a chain id: " <> build s

instance Exception ParseChainIdError where
  displayException = pretty

parseChainId :: Text -> Either ParseChainIdError ChainId
parseChainId text =
  case decodeBase58CheckWithPrefix chainIdPrefix text of
    Left (B58CheckWithPrefixWrongPrefix prefix) ->
      Left (ParseChainIdWrongTag prefix)
    Left B58CheckWithPrefixWrongEncoding ->
      Left ParseChainIdWrongBase58Check
    Right bs -> case mkChainId bs of
      Just ci -> Right ci
      Nothing -> Left $ ParseChainIdWrongSize (length bs)

chainIdLength :: Int
chainIdLength = 4

-- | It's a magic constant used by Tezos to encode a chain ID.
-- Corresponds to "Net" part.
chainIdPrefix :: ByteString
chainIdPrefix = "\87\82\0"

----------------------------------------------------------------------------
-- JSON
----------------------------------------------------------------------------

deriveJSON morleyAesonOptions ''Mutez
deriveJSON morleyAesonOptions ''Timestamp

instance ToJSON ChainId where
  toJSON = Aeson.String . formatChainId
instance FromJSON ChainId where
  parseJSON = Aeson.withText "chain id" $
    either (fail . pretty) pure . parseChainId