module Tezos.Core
(
Mutez (unMutez)
, mkMutez
, unsafeMkMutez
, toMutez
, addMutez
, unsafeAddMutez
, subMutez
, unsafeSubMutez
, mulMutez
, divModMutez
, divModMutezInt
, Timestamp (..)
, timestampToSeconds
, timestampFromSeconds
, timestampFromUTCTime
, timestampPlusSeconds
, formatTimestamp
, parseTimestamp
, timestampQuote
, getCurrentTime
, farFuture
, farPast
, ChainId (..)
, mkChainId
, mkChainIdUnsafe
, dummyChainId
, formatChainId
, mformatChainId
, parseChainId
, chainIdLength
) where
import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson as Aeson
import Data.Aeson.TH (defaultOptions, deriveJSON)
import qualified Data.ByteString as BS
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 (fmt, hexF, pretty)
import Formatting.Buildable (Buildable(build))
import qualified Language.Haskell.TH.Quote as TH
import Language.Haskell.TH.Syntax (liftData)
import Test.QuickCheck (Arbitrary(..), vector)
import Michelson.Text
import Tezos.Crypto
newtype Mutez = Mutez
{ unMutez :: Word64
} deriving stock (Show, Eq, Ord, Data, Generic)
deriving newtype (Enum, Buildable)
instance Bounded Mutez where
minBound = Mutez 0
maxBound = Mutez 9223372036854775807
mkMutez :: Word64 -> Maybe Mutez
mkMutez n
| n <= unMutez maxBound = Just (Mutez n)
| otherwise = Nothing
{-# INLINE mkMutez #-}
unsafeMkMutez :: HasCallStack => Word64 -> Mutez
unsafeMkMutez n =
fromMaybe (error $ "mkMutez: overflow (" <> show n <> ")") (mkMutez n)
{-# INLINE unsafeMkMutez #-}
toMutez :: Word32 -> Mutez
toMutez = unsafeMkMutez . fromIntegral
{-# INLINE toMutez #-}
addMutez :: Mutez -> Mutez -> Maybe Mutez
addMutez (unMutez -> a) (unMutez -> b) =
mkMutez (a + b)
{-# INLINE addMutez #-}
unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez
unsafeAddMutez = fromMaybe (error "unsafeAddMutez: overflow") ... addMutez
subMutez :: Mutez -> Mutez -> Maybe Mutez
subMutez (unMutez -> a) (unMutez -> b)
| a >= b = Just (Mutez (a - b))
| otherwise = Nothing
{-# INLINE subMutez #-}
unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez
unsafeSubMutez = fromMaybe (error "unsafeSubMutez: underflow") ... subMutez
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 #-}
divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)
divModMutez a (unMutez -> b) = first unMutez <$> divModMutezInt a b
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
newtype Timestamp = Timestamp
{ unTimestamp :: POSIXTime
} deriving stock (Show, Eq, Ord, Data, Generic)
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 #-}
timestampPlusSeconds :: Timestamp -> Integer -> Timestamp
timestampPlusSeconds ts sec = timestampFromSeconds (timestampToSeconds ts + sec)
formatTimestamp :: Timestamp -> Text
formatTimestamp =
formatTimeRFC3339 . utcToZonedTime utc . posixSecondsToUTCTime . unTimestamp
instance Buildable Timestamp where
build = build . formatTimestamp
parseTimestamp :: Text -> Maybe Timestamp
parseTimestamp t
| 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
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!"
}
getCurrentTime :: IO Timestamp
getCurrentTime = Timestamp <$> getPOSIXTime
farFuture :: Timestamp
farFuture = timestampFromSeconds 1e12
farPast :: Timestamp
farPast = timestampFromSeconds 0
newtype ChainId = ChainIdUnsafe { unChainId :: ByteString }
deriving stock (Show, Eq)
mkChainId :: ByteString -> Maybe ChainId
mkChainId bs =
guard (length bs == chainIdLength) $> ChainIdUnsafe bs
mkChainIdUnsafe :: HasCallStack => ByteString -> ChainId
mkChainIdUnsafe = fromMaybe (error "Bad chain id") . mkChainId
dummyChainId :: ChainId
dummyChainId = ChainIdUnsafe "\0\0\0\0"
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
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
chainIdPrefix :: ByteString
chainIdPrefix = "\87\82\0"
instance Arbitrary ChainId where
arbitrary = ChainIdUnsafe . BS.pack <$> (vector 4)
deriveJSON defaultOptions ''Mutez
deriveJSON defaultOptions ''Timestamp
instance ToJSON ChainId where
toJSON = Aeson.String . formatChainId
instance FromJSON ChainId where
parseJSON = Aeson.withText "chain id" $
either (fail . pretty) pure . parseChainId