Core.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Core primitive Tezos types.

module Morley.Tezos.Core
  (
    -- * Mutez
    Mutez (..)
  , tz
  , mkMutez
  , toMutez
  , addMutez
  , unsafeAddMutez
  , subMutez
  , unsafeSubMutez
  , mulMutez
  , unsafeMulMutez
  , divModMutez
  , divModMutezInt
  , zeroMutez
  , oneMutez
  , prettyTez

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

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

import Prelude hiding (lift)

import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Aeson qualified as Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.Scientific
  (FPFormat(Fixed), Scientific, floatingOrInteger, formatScientific, isFloating, scientificP,
  toBoundedInteger)
import Data.Text qualified 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 Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax (liftData)
import Options.Applicative qualified as Opt
import Text.ParserCombinators.ReadP (ReadP, eof, readP_to_S, skipSpaces, string, (+++))
import Unsafe qualified (unsafeM)

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

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

-- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).
--
-- The constructor is marked "Unsafe" since GHC does not warn on overflowing
-- literals (exceeding custom 'Word63' type bounds), thus the resultant
-- 'Mutez' value may get truncated silently.
--
-- >>> UnsafeMutez 9223372036854775809
-- UnsafeMutez {unMutez = 1}
newtype Mutez = UnsafeMutez
  { unMutez :: Word63
  } deriving stock (Show, Eq, Ord, Generic)
    deriving newtype (Enum, Bounded)

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

instance NFData Mutez where
  rnf (UnsafeMutez !_) = ()

instance HasCLReader Mutez where
  getReader = either (readerError . toString) pure . mkMutez @Word64 =<< Opt.auto
  getMetavar = "MUTEZ"

{- | Quotes a 'Mutez' value.

The value is in XTZ, i.e. 1e6 'Mutez', with optional suffix representing
a unit:

* @k@, @kilo@ -- 1000 XTZ
* @M@, @Mega@, @mega@ -- 1000000 XTZ
* @m@, @milli@ -- 0.001 XTZ
* @u@, @μ@, @micro@ -- 0.000001 XTZ

This is the safest and recommended way to create 'Mutez' from a numeric literal.

The suffix can be separated from the number by whitespace.
You can also use underscores as a delimiter (those will be ignored), and
scientific notation, e.g. @123.456e6@. Note that if the scientific notation
represents a mutez fraction, that is a compile-time error.

>>> [tz|123|]
UnsafeMutez {unMutez = 123000000}

>>> [tz|123k|]
UnsafeMutez {unMutez = 123000000000}

>>> [tz|123 kilo|]
UnsafeMutez {unMutez = 123000000000}

>>> [tz|123M|]
UnsafeMutez {unMutez = 123000000000000}

>>> [tz|123 Mega|]
UnsafeMutez {unMutez = 123000000000000}

>>> [tz|123 mega|]
UnsafeMutez {unMutez = 123000000000000}

>>> [tz|123e6|]
UnsafeMutez {unMutez = 123000000000000}

>>> [tz|123m|]
UnsafeMutez {unMutez = 123000}

>>> [tz|123 milli|]
UnsafeMutez {unMutez = 123000}

>>> [tz|123u|]
UnsafeMutez {unMutez = 123}

>>> [tz|123μ|]
UnsafeMutez {unMutez = 123}

>>> [tz|123 micro|]
UnsafeMutez {unMutez = 123}

>>> [tz| 123.456_789 |]
UnsafeMutez {unMutez = 123456789}

>>> [tz|123.456u|]
...
... error:
...  • The number is a mutez fraction. The smallest possible subdivision is 0.000001 XTZ
...

>>> [tz|0.012_345_6|]
...
... error:
...  • The number is a mutez fraction. The smallest possible subdivision is 0.000001 XTZ
...

>>> [tz| 9223372.036854775807 M |]
UnsafeMutez {unMutez = 9223372036854775807}

>>> [tz| 9223372.036854775808 M |]
...
... error:
...  • The number is out of mutez bounds. It must be between 0 and 9223372036854.775807 XTZ (inclusive).
...

>>> [tz| -1 |]
...
... error:
...  • The number is out of mutez bounds. It must be between 0 and 9223372036854.775807 XTZ (inclusive).
...
-}
tz :: TH.QuasiQuoter
tz = TH.QuasiQuoter
  { quoteExp = \inp -> do
      val <- parseTez @Word64 inp
      [| UnsafeMutez val |]
  , quotePat = \inp -> do
      val <- parseTez @Integer inp
      [p| UnsafeMutez $(pure $ TH.LitP $ TH.IntegerL val) |]
  , quoteType = const $ fail "Cannot be used as type"
  , quoteDec = const $ fail "Cannot be used as dec"
  }
  where
    parseTez :: forall t m. (CheckIntSubType Word63 t, Integral t, MonadFail m) => String -> m t
    parseTez inp = fromIntegral <$>
      case readP_to_S (skipSpaces *> parser) $ filter (/= '_') inp of
        [(val, "")] -> unsafeM . maybeToRight (oobErr val) $ toBoundedInteger @Word63 val
        _ -> fail "no parse"
    parser = (*) <$> (scientificP <* skipSpaces) <*> (unit <* skipSpaces) <* eof
    oobErr :: Scientific -> String
    oobErr val
      | isFloating val = "The number is a mutez fraction. \
          \The smallest possible subdivision is 0.000001 XTZ"
      | otherwise = "The number is out of mutez bounds. \
          \It must be between 0 and 9223372036854.775807 XTZ (inclusive)."
    unit :: ReadP Scientific
    unit = (string "M" +++ string "Mega" +++ string "mega" $> 1e12)
       +++ (string "k" +++ string "kilo" $> 1e9)
       +++ (string "m" +++ string "milli" $> 1e3)
       +++ (string "u" +++ string "μ" +++ string "micro" $> 1)
       +++ (pure 1e6)

-- | Safely creates 'Mutez' checking for
-- overflow and underflow. Accepts a number of any type.
mkMutez :: Integral i => i -> Either Text Mutez
mkMutez = bimap (fromString . displayException) UnsafeMutez . fromIntegralNoOverflow

-- | Safely create 'Mutez'.
--
-- When constructing literals, you'll need to specify the type of the literal.
-- GHC will check for literal overflow on builtin types like 'Word16' and
-- 'Word32', but not on 'Word62' or 'Word63', so those can overflow silently.
--
-- It's recommended to use 'tz' quasiquote for literals instead.
toMutez :: (Integral a, CheckIntSubType a Word63) => a -> Mutez
toMutez = UnsafeMutez . fromIntegral
{-# INLINE toMutez #-}

-- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow.
addMutez :: Mutez -> Mutez -> Maybe Mutez
addMutez (unMutez -> a) (unMutez -> b) =
  rightToMaybe $ mkMutez @Word64 $
    -- NB: plain @a + b@ might overflow and
    -- thus we widen the operands (and the sum)
    -- to 'Word64'
    fromIntegral a + fromIntegral b
{-# 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 (UnsafeMutez (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 (UnsafeMutez (fromInteger res))
    | otherwise = Nothing
  where
    res = toInteger a * toInteger b
{-# INLINE mulMutez #-}

-- | Partial multiplication of 'Mutez' and an Natural number.
-- Should be used only if you're sure there'll be no overflow.
unsafeMulMutez :: Mutez -> Natural -> Mutez
unsafeMulMutez = fromMaybe (error "unsafeMulMutez: overflow") ... mulMutez

-- | Euclidian division of two 'Mutez' values.
divModMutez :: Mutez -> Mutez -> Maybe (Word63, 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' = UnsafeMutez . fromInteger

zeroMutez :: Mutez
zeroMutez = UnsafeMutez minBound

oneMutez :: Mutez
oneMutez = UnsafeMutez 1

-- |
-- >>> putTextLn $ prettyTez [tz|420u|]
-- 0.00042 ꜩ
--
-- >>> putTextLn $ prettyTez [tz|42|]
-- 42 ꜩ
prettyTez :: Mutez -> Text
prettyTez ((/ 1000000) . fromIntegralToRealFrac . unMutez -> s) =
  case floatingOrInteger s of
    Left (_ :: Float)    -> toText $ formatScientific Fixed Nothing s
    Right (n :: Integer) -> pretty n
  <> " ꜩ"

----------------------------------------------------------------------------
-- 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 . fromIntegralToRealFrac
{-# 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 = UnsafeChainId { unChainId :: ByteString }
  deriving stock (Show, Eq, Ord, Generic)

instance NFData ChainId

-- | Construct chain ID from raw bytes.
mkChainId :: ByteString -> Either ParseChainIdError ChainId
mkChainId bs =
  if length bs == chainIdLength
  then Right $ UnsafeChainId bs
  else Left . ParseChainIdWrongSize $ length bs

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

-- | Pretty print 'ChainId' as it is displayed e.g. in
-- @octez-client rpc get /chains/main/chain_id@ call.
--
-- Example of produced value: @NetXUdfLh6Gm88t@.
formatChainId :: ChainId -> Text
formatChainId (unChainId -> bs) = encodeBase58Check (chainIdPrefix <> bs)

mformatChainId :: ChainId -> MText
mformatChainId = unsafe . mkMText . 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 -> mkChainId 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
----------------------------------------------------------------------------

instance FromJSON Mutez where
  parseJSON v = do
    i <- parseJSON @Int64 v
    Unsafe.unsafeM $ mkMutez i

instance ToJSON Mutez where
  toJSON (UnsafeMutez a) = toJSON $ fromIntegral @Word63 @Word64 a

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