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

{- | Timelock puzzle algorithms implementation.

__WARNING__: the timelock mechanism described and implemented here is
vulnerable. At the time of writing, no details were released, but creation of
smart contracts using this functionality is disabled since Lima.

This module follows the reference implementation for the most part,
which you can find in the
[tezos repository](https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml).

For a more high-level overview of the concepts, refer to the [timelock
documentation page](http://tezos.gitlab.io/011/timelock.html).

The general idea is built upon [Rivest, Shamir, Wagner "Time-lock puzzles and
timed-release Crypto"](http://www.hashcash.org/papers/time-lock.pdf), there
are however some differences from the paper:

* The paper suggests using RC5 cipher, which Tezos implementation
eschews in favor of NaCl's "secret box".
* The paper suggest generating the symmetric secret key \(K\) directly, then
encrypting it with a randomly chosen value \(a\) as \(C_K = K + a^{2^t} \pmod n\).
Tezos implementation instead randomly generates only \(a\), and then produces
the secret key using BLAKE2b KDF with a fixed key from \(a^{2^t} \pmod n\).
* Since the secret key is determined only by the "unlocked" value, the
time-locked value representation also differs. In the paper it's represented as
\((n,a,t,C_K,C_M)\), i.e. the tuple of modulus, "locked" value, time,
encrypted key and encrypted message. In Tezos implementation it's instead
\((a,n,C_M)\), and \(t\) is treated as a separate argument.
* Likely to guard the protocol from guessing attacks, additional "proof"
verification is added, described in
[Boneh, Bünz, Fisch "A Survey of Two Verifiable Delay Functions"](https://eprint.iacr.org/2018/712.pdf)
-}
module Morley.Tezos.Crypto.Timelock
  ( TLTime(.., TLTime)
  , Chest(..)
  , ChestKey(..)
  , Ciphertext(..)
  , OpeningResult(..)
  , createChestAndChestKey
  , createChestKey
  , chestBytes
  , chestKeyBytes
  , chestFromBytes
  , chestKeyFromBytes
  , openChest
  , mkTLTime
  , toTLTime
  -- * Internal, not safe for cryptography
  , createChestAndChestKeyFromSeed
  ) where

import Control.Monad.Random (evalRand, genByteString, getRandomR, liftRand, mkStdGen)
import Crypto.Number.ModArithmetic (expFast)
import Crypto.Number.Prime (findPrimeFrom)
import Crypto.Number.Serialize.LE (i2osp, os2ip)
import Crypto.Sodium.Encrypt.Symmetric qualified as Box (Key, Nonce, decrypt, encrypt)
import Crypto.Sodium.Hash (blake2bWithKey)
import Crypto.Sodium.Nonce qualified as Nonce (generate)
import Crypto.Sodium.Random qualified as Random (generate)
import Data.Binary qualified as Bi (Binary(..), decodeOrFail, encode)
import Data.Binary.Get qualified as Bi (getByteString)
import Data.Binary.Put qualified as Bi (putBuilder)
import Data.Bits (shiftL)
import Data.ByteArray.Sized (SizedByteArray, sizedByteArray, unSizedByteArray)
import Data.ByteString qualified as BS (intercalate, length, replicate)
import Data.ByteString.Lazy qualified as LBS (fromStrict, toStrict)
import Fmt (Buildable(..))
import GHC.TypeNats (Div, type (+))
import Options.Applicative qualified as Opt

import Morley.Micheline.Binary.Internal
import Morley.Util.CLI

-- | RSA-inspired prime factors, which produce (literally) the 'PublicModulus'.
--
-- This value should be kept secret.
data RSAFactors = RSAFactors { RSAFactors -> Integer
rsaP :: Integer, RSAFactors -> Integer
rsaQ :: Integer }
  deriving stock Int -> RSAFactors -> ShowS
[RSAFactors] -> ShowS
RSAFactors -> String
(Int -> RSAFactors -> ShowS)
-> (RSAFactors -> String)
-> ([RSAFactors] -> ShowS)
-> Show RSAFactors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RSAFactors -> ShowS
showsPrec :: Int -> RSAFactors -> ShowS
$cshow :: RSAFactors -> String
show :: RSAFactors -> String
$cshowList :: [RSAFactors] -> ShowS
showList :: [RSAFactors] -> ShowS
Show

-- | RSA-inspired semi-prime modulus.
newtype PublicModulus = PublicModulus { PublicModulus -> Integer
unPublicModulus :: Integer }
  deriving stock (Int -> PublicModulus -> ShowS
[PublicModulus] -> ShowS
PublicModulus -> String
(Int -> PublicModulus -> ShowS)
-> (PublicModulus -> String)
-> ([PublicModulus] -> ShowS)
-> Show PublicModulus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublicModulus -> ShowS
showsPrec :: Int -> PublicModulus -> ShowS
$cshow :: PublicModulus -> String
show :: PublicModulus -> String
$cshowList :: [PublicModulus] -> ShowS
showList :: [PublicModulus] -> ShowS
Show, PublicModulus -> PublicModulus -> Bool
(PublicModulus -> PublicModulus -> Bool)
-> (PublicModulus -> PublicModulus -> Bool) -> Eq PublicModulus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublicModulus -> PublicModulus -> Bool
== :: PublicModulus -> PublicModulus -> Bool
$c/= :: PublicModulus -> PublicModulus -> Bool
/= :: PublicModulus -> PublicModulus -> Bool
Eq)
  deriving newtype PublicModulus -> ()
(PublicModulus -> ()) -> NFData PublicModulus
forall a. (a -> ()) -> NFData a
$crnf :: PublicModulus -> ()
rnf :: PublicModulus -> ()
NFData

-- | The "locked" value. Essentially a random integer between 0 and
-- 'PublicModulus' (exclusive).
newtype Locked = Locked { Locked -> Integer
unLocked :: Integer }
  deriving stock (Int -> Locked -> ShowS
[Locked] -> ShowS
Locked -> String
(Int -> Locked -> ShowS)
-> (Locked -> String) -> ([Locked] -> ShowS) -> Show Locked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Locked -> ShowS
showsPrec :: Int -> Locked -> ShowS
$cshow :: Locked -> String
show :: Locked -> String
$cshowList :: [Locked] -> ShowS
showList :: [Locked] -> ShowS
Show, Locked -> Locked -> Bool
(Locked -> Locked -> Bool)
-> (Locked -> Locked -> Bool) -> Eq Locked
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Locked -> Locked -> Bool
== :: Locked -> Locked -> Bool
$c/= :: Locked -> Locked -> Bool
/= :: Locked -> Locked -> Bool
Eq)
  deriving newtype Locked -> ()
(Locked -> ()) -> NFData Locked
forall a. (a -> ()) -> NFData a
$crnf :: Locked -> ()
rnf :: Locked -> ()
NFData

-- | The "unlocked" value, i.e. \(a^{2^t} \pmod n\), where \(a\) is 'Locked'
-- value, \(t\) is t'TLTime' and \(n\) is 'PublicModulus'.
newtype Unlocked = Unlocked { Unlocked -> Integer
unUnlocked :: Integer }
  deriving stock (Int -> Unlocked -> ShowS
[Unlocked] -> ShowS
Unlocked -> String
(Int -> Unlocked -> ShowS)
-> (Unlocked -> String) -> ([Unlocked] -> ShowS) -> Show Unlocked
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Unlocked -> ShowS
showsPrec :: Int -> Unlocked -> ShowS
$cshow :: Unlocked -> String
show :: Unlocked -> String
$cshowList :: [Unlocked] -> ShowS
showList :: [Unlocked] -> ShowS
Show, Unlocked -> Unlocked -> Bool
(Unlocked -> Unlocked -> Bool)
-> (Unlocked -> Unlocked -> Bool) -> Eq Unlocked
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Unlocked -> Unlocked -> Bool
== :: Unlocked -> Unlocked -> Bool
$c/= :: Unlocked -> Unlocked -> Bool
/= :: Unlocked -> Unlocked -> Bool
Eq)
  deriving newtype Unlocked -> ()
(Unlocked -> ()) -> NFData Unlocked
forall a. (a -> ()) -> NFData a
$crnf :: Unlocked -> ()
rnf :: Unlocked -> ()
NFData

-- | The key for the symmetric encryption, \(K\).
newtype SymmetricKey = SymmetricKey (Box.Key ByteString)
  deriving stock Int -> SymmetricKey -> ShowS
[SymmetricKey] -> ShowS
SymmetricKey -> String
(Int -> SymmetricKey -> ShowS)
-> (SymmetricKey -> String)
-> ([SymmetricKey] -> ShowS)
-> Show SymmetricKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SymmetricKey -> ShowS
showsPrec :: Int -> SymmetricKey -> ShowS
$cshow :: SymmetricKey -> String
show :: SymmetricKey -> String
$cshowList :: [SymmetricKey] -> ShowS
showList :: [SymmetricKey] -> ShowS
Show

{- | A "proof" that the chest was opened fairly, i.e. the key wasn't just
guessed.

The proof is verified by checking that

\[
  a ^ (2 ^ t) = (p ^ l) (a ^ r) \pmod n
\]

which is equivalent to

\[
  2 ^ t = (((2 ^ t) / l) * l) + (2 ^ t \mod l) \pmod {\phi(n)}
\]

where \(a\) is a 'Locked' value, \(t\) is t'TLTime', \(p\) is 'Proof', \(n\) is
'PublicModulus', \(l\) is a prime, chosen deterministically from the hash
of the puzzle, and \(r = 2^t \pmod l\)

What this essentially boils down to, is that we can compute the "proof" either
as

\[
  p = a^{2^t / l \mod {\phi(n)}} \pmod n
\]

if we know the modulo factorization, or

\[
  p = a^{2^t / l} \pmod n
\]

if we don't.

See https://eprint.iacr.org/2018/712.pdf section 3.2.
-}
newtype Proof = Proof { Proof -> Integer
unProof :: Integer }
  deriving stock (Int -> Proof -> ShowS
[Proof] -> ShowS
Proof -> String
(Int -> Proof -> ShowS)
-> (Proof -> String) -> ([Proof] -> ShowS) -> Show Proof
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Proof -> ShowS
showsPrec :: Int -> Proof -> ShowS
$cshow :: Proof -> String
show :: Proof -> String
$cshowList :: [Proof] -> ShowS
showList :: [Proof] -> ShowS
Show, Proof -> Proof -> Bool
(Proof -> Proof -> Bool) -> (Proof -> Proof -> Bool) -> Eq Proof
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Proof -> Proof -> Bool
== :: Proof -> Proof -> Bool
$c/= :: Proof -> Proof -> Bool
/= :: Proof -> Proof -> Bool
Eq)
  deriving newtype Proof -> ()
(Proof -> ()) -> NFData Proof
forall a. (a -> ()) -> NFData a
$crnf :: Proof -> ()
rnf :: Proof -> ()
NFData

-- | Number of steps a timelock needs to be opened without knowing a "secret",
-- i.e. modulo factorization.
--
-- The reference implementation uses OCaml @int@, and it can only be positive,
-- so on 64-bit architecture it's actually a 62-bit natural. We use 'Word62'
-- to represent it.
--
-- The constructor is marked "Unsafe" since GHC does not warn on overflowing
-- literals (exceeding custom 'Word62' type bounds), thus the resultant
-- t'TLTime' value may get truncated silently.
--
-- >>> UnsafeTLTime 4611686018427387906
-- UnsafeTLTime {unTLTime = 2}
newtype TLTime = UnsafeTLTime { TLTime -> Word62
unTLTime :: Word62 }
  deriving stock (Int -> TLTime -> ShowS
[TLTime] -> ShowS
TLTime -> String
(Int -> TLTime -> ShowS)
-> (TLTime -> String) -> ([TLTime] -> ShowS) -> Show TLTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TLTime -> ShowS
showsPrec :: Int -> TLTime -> ShowS
$cshow :: TLTime -> String
show :: TLTime -> String
$cshowList :: [TLTime] -> ShowS
showList :: [TLTime] -> ShowS
Show, TLTime -> TLTime -> Bool
(TLTime -> TLTime -> Bool)
-> (TLTime -> TLTime -> Bool) -> Eq TLTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TLTime -> TLTime -> Bool
== :: TLTime -> TLTime -> Bool
$c/= :: TLTime -> TLTime -> Bool
/= :: TLTime -> TLTime -> Bool
Eq)
  deriving newtype TLTime
TLTime -> TLTime -> Bounded TLTime
forall a. a -> a -> Bounded a
$cminBound :: TLTime
minBound :: TLTime
$cmaxBound :: TLTime
maxBound :: TLTime
Bounded

pattern TLTime :: Word62 -> TLTime
pattern $mTLTime :: forall {r}. TLTime -> (Word62 -> r) -> ((# #) -> r) -> r
TLTime x <- UnsafeTLTime x
{-# COMPLETE TLTime #-}

instance HasCLReader TLTime where
  getReader :: ReadM TLTime
getReader = (Text -> ReadM TLTime)
-> (TLTime -> ReadM TLTime) -> Either Text TLTime -> ReadM TLTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ReadM TLTime
forall a. String -> ReadM a
readerError (String -> ReadM TLTime)
-> (Text -> String) -> Text -> ReadM TLTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) TLTime -> ReadM TLTime
forall a. a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text TLTime -> ReadM TLTime)
-> (Word64 -> Either Text TLTime) -> Word64 -> ReadM TLTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => i -> Either Text TLTime
mkTLTime @Word64 (Word64 -> ReadM TLTime) -> ReadM Word64 -> ReadM TLTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReadM Word64
forall a. Read a => ReadM a
Opt.auto
  getMetavar :: String
getMetavar = String
"TIME"

instance Buildable TLTime where
  build :: TLTime -> Doc
build = Word62 -> Doc
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Word62 -> Doc) -> (TLTime -> Word62) -> TLTime -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLTime -> Word62
unTLTime

-- | Safely creates t'TLTime' checking for
-- overflow and underflow. Accepts a number of any type.
mkTLTime :: Integral i => i -> Either Text TLTime
mkTLTime :: forall i. Integral i => i -> Either Text TLTime
mkTLTime = (ArithException -> Text)
-> (Word62 -> TLTime)
-> Either ArithException Word62
-> Either Text TLTime
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text)
-> (ArithException -> String) -> ArithException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArithException -> String
forall e. Exception e => e -> String
displayException) Word62 -> TLTime
UnsafeTLTime (Either ArithException Word62 -> Either Text TLTime)
-> (i -> Either ArithException Word62) -> i -> Either Text TLTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Either ArithException Word62
forall a b.
(Integral a, Integral b) =>
a -> Either ArithException b
fromIntegralNoOverflow

-- | Safely creates t'TLTime'.
--
-- This is the recommended way to create t'TLTime' values.
--
-- When constructing literals, you'll need to specify the type of the literal.
-- Bear in mind that GHC will check for literal overflow on builtin types like
-- 'Word16' and 'Word32', but not on 'Word62', so be aware that 'toTLTime' from
-- 'Word62' will overflow silently. Prefer using builtin types when possible.
--
-- >>> unTLTime $ toTLTime (4611686018427387903 :: Word62)
-- 4611686018427387903
-- >>> unTLTime $ toTLTime (4611686018427387904 :: Word62)
-- 0
toTLTime :: (Integral a, CheckIntSubType a Word62) => a -> TLTime
toTLTime :: forall a. (Integral a, CheckIntSubType a Word62) => a -> TLTime
toTLTime = Word62 -> TLTime
UnsafeTLTime (Word62 -> TLTime) -> (a -> Word62) -> a -> TLTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word62
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral

-- | A nonce for symmetric encryption.
newtype Nonce = Nonce { Nonce -> Nonce ByteString
unNonce :: Box.Nonce ByteString }
  deriving stock (Int -> Nonce -> ShowS
[Nonce] -> ShowS
Nonce -> String
(Int -> Nonce -> ShowS)
-> (Nonce -> String) -> ([Nonce] -> ShowS) -> Show Nonce
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Nonce -> ShowS
showsPrec :: Int -> Nonce -> ShowS
$cshow :: Nonce -> String
show :: Nonce -> String
$cshowList :: [Nonce] -> ShowS
showList :: [Nonce] -> ShowS
Show, Nonce -> Nonce -> Bool
(Nonce -> Nonce -> Bool) -> (Nonce -> Nonce -> Bool) -> Eq Nonce
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Nonce -> Nonce -> Bool
== :: Nonce -> Nonce -> Bool
$c/= :: Nonce -> Nonce -> Bool
/= :: Nonce -> Nonce -> Bool
Eq)

instance NFData Nonce where
  rnf :: Nonce -> ()
rnf (Nonce Nonce ByteString
x) = ByteString -> ()
forall a. NFData a => a -> ()
rnf (ByteString -> ()) -> ByteString -> ()
forall a b. (a -> b) -> a -> b
$ Nonce ByteString -> ByteString
forall (n :: Nat) ba. SizedByteArray n ba -> ba
unSizedByteArray Nonce ByteString
x

-- | Ciphertext with nonce.
data Ciphertext = Ciphertext
  { Ciphertext -> Nonce
ctNonce :: Nonce
  , Ciphertext -> ByteString
ctPayload :: ByteString
  } deriving stock (Int -> Ciphertext -> ShowS
[Ciphertext] -> ShowS
Ciphertext -> String
(Int -> Ciphertext -> ShowS)
-> (Ciphertext -> String)
-> ([Ciphertext] -> ShowS)
-> Show Ciphertext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ciphertext -> ShowS
showsPrec :: Int -> Ciphertext -> ShowS
$cshow :: Ciphertext -> String
show :: Ciphertext -> String
$cshowList :: [Ciphertext] -> ShowS
showList :: [Ciphertext] -> ShowS
Show, Ciphertext -> Ciphertext -> Bool
(Ciphertext -> Ciphertext -> Bool)
-> (Ciphertext -> Ciphertext -> Bool) -> Eq Ciphertext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ciphertext -> Ciphertext -> Bool
== :: Ciphertext -> Ciphertext -> Bool
$c/= :: Ciphertext -> Ciphertext -> Bool
/= :: Ciphertext -> Ciphertext -> Bool
Eq, (forall x. Ciphertext -> Rep Ciphertext x)
-> (forall x. Rep Ciphertext x -> Ciphertext) -> Generic Ciphertext
forall x. Rep Ciphertext x -> Ciphertext
forall x. Ciphertext -> Rep Ciphertext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Ciphertext -> Rep Ciphertext x
from :: forall x. Ciphertext -> Rep Ciphertext x
$cto :: forall x. Rep Ciphertext x -> Ciphertext
to :: forall x. Rep Ciphertext x -> Ciphertext
Generic)
    deriving anyclass Ciphertext -> ()
(Ciphertext -> ()) -> NFData Ciphertext
forall a. (a -> ()) -> NFData a
$crnf :: Ciphertext -> ()
rnf :: Ciphertext -> ()
NFData

instance Bi.Binary Ciphertext where
  put :: Ciphertext -> Put
put Ciphertext{ByteString
Nonce
ctNonce :: Ciphertext -> Nonce
ctPayload :: Ciphertext -> ByteString
ctNonce :: Nonce
ctPayload :: ByteString
..} = Builder -> Put
Bi.putBuilder (Builder -> Put) -> Builder -> Put
forall a b. (a -> b) -> a -> b
$
      ByteString -> Builder
buildByteString (Nonce ByteString -> ByteString
forall (n :: Nat) ba. SizedByteArray n ba -> ba
unSizedByteArray (Nonce ByteString -> ByteString) -> Nonce ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Nonce -> Nonce ByteString
unNonce Nonce
ctNonce)
   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Builder) -> DynamicSize ByteString -> Builder
forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic ByteString -> Builder
buildByteString (ByteString -> DynamicSize ByteString
forall a. a -> DynamicSize a
DynamicSize ByteString
ctPayload)
  get :: Get Ciphertext
get = do
    Maybe (Nonce ByteString)
mbNonce <- ByteString -> Maybe (Nonce ByteString)
forall (n :: Nat) ba.
(KnownNat n, ByteArrayAccess ba) =>
ba -> Maybe (SizedByteArray n ba)
sizedByteArray (ByteString -> Maybe (Nonce ByteString))
-> Get ByteString -> Get (Maybe (Nonce ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
Bi.getByteString Int
24
    Nonce
ctNonce <- case Maybe (Nonce ByteString)
mbNonce of
      Just Nonce ByteString
sza -> Nonce -> Get Nonce
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nonce -> Get Nonce) -> Nonce -> Get Nonce
forall a b. (a -> b) -> a -> b
$ Nonce ByteString -> Nonce
Nonce Nonce ByteString
sza
      Maybe (Nonce ByteString)
Nothing -> String -> Get Nonce
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Incorrect nonce size"
        -- NB: this shouldn't happen unless NaCl box changes nonce size
    DynamicSize ByteString
ctPayload <- Get ByteString -> Get (DynamicSize ByteString)
forall a. Get a -> Get (DynamicSize a)
getDynamic Get ByteString
getByteString
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
ctPayload Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
secretBoxTagBytes) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Ciphertext size <= 0"
    pure $ Ciphertext{ByteString
Nonce
ctNonce :: Nonce
ctPayload :: ByteString
ctNonce :: Nonce
ctPayload :: ByteString
..}
    where
      -- This is hard-coded in the reference implementation,
      -- https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_hacl_glue/unix/hacl.ml#L183
      -- but essentially this is the length of a NaCl box ciphertext with
      -- empty payload
      secretBoxTagBytes :: Int
secretBoxTagBytes = Int
16

-- | A chest "key" with proof that it was indeed opened fairly.
data ChestKey = ChestKey
  { ChestKey -> Unlocked
ckUnlockedVal :: Unlocked
  , ChestKey -> Proof
ckProof :: Proof
  } deriving stock (Int -> ChestKey -> ShowS
[ChestKey] -> ShowS
ChestKey -> String
(Int -> ChestKey -> ShowS)
-> (ChestKey -> String) -> ([ChestKey] -> ShowS) -> Show ChestKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChestKey -> ShowS
showsPrec :: Int -> ChestKey -> ShowS
$cshow :: ChestKey -> String
show :: ChestKey -> String
$cshowList :: [ChestKey] -> ShowS
showList :: [ChestKey] -> ShowS
Show, ChestKey -> ChestKey -> Bool
(ChestKey -> ChestKey -> Bool)
-> (ChestKey -> ChestKey -> Bool) -> Eq ChestKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChestKey -> ChestKey -> Bool
== :: ChestKey -> ChestKey -> Bool
$c/= :: ChestKey -> ChestKey -> Bool
/= :: ChestKey -> ChestKey -> Bool
Eq, (forall x. ChestKey -> Rep ChestKey x)
-> (forall x. Rep ChestKey x -> ChestKey) -> Generic ChestKey
forall x. Rep ChestKey x -> ChestKey
forall x. ChestKey -> Rep ChestKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChestKey -> Rep ChestKey x
from :: forall x. ChestKey -> Rep ChestKey x
$cto :: forall x. Rep ChestKey x -> ChestKey
to :: forall x. Rep ChestKey x -> ChestKey
Generic)
    deriving anyclass ChestKey -> ()
(ChestKey -> ()) -> NFData ChestKey
forall a. (a -> ()) -> NFData a
$crnf :: ChestKey -> ()
rnf :: ChestKey -> ()
NFData

instance Bi.Binary ChestKey where
  put :: ChestKey -> Put
put ChestKey{Proof
Unlocked
ckUnlockedVal :: ChestKey -> Unlocked
ckProof :: ChestKey -> Proof
ckUnlockedVal :: Unlocked
ckProof :: Proof
..} = Builder -> Put
Bi.putBuilder (Builder -> Put) -> Builder -> Put
forall a b. (a -> b) -> a -> b
$
    Integer -> Builder
buildNatural (Unlocked -> Integer
unUnlocked Unlocked
ckUnlockedVal) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
buildNatural (Proof -> Integer
unProof Proof
ckProof)
  get :: Get ChestKey
get = Unlocked -> Proof -> ChestKey
ChestKey (Unlocked -> Proof -> ChestKey)
-> Get Unlocked -> Get (Proof -> ChestKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Unlocked
Unlocked (Integer -> Unlocked) -> Get Integer -> Get Unlocked
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
getNatural) Get (Proof -> ChestKey) -> Get Proof -> Get ChestKey
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Integer -> Proof
Proof (Integer -> Proof) -> Get Integer -> Get Proof
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
getNatural)

-- | A locked chest
data Chest = Chest
  { Chest -> Locked
chestLockedVal :: Locked
  , Chest -> PublicModulus
chestPublicModulus :: PublicModulus
  , Chest -> Ciphertext
chestCiphertext :: Ciphertext
  } deriving stock (Int -> Chest -> ShowS
[Chest] -> ShowS
Chest -> String
(Int -> Chest -> ShowS)
-> (Chest -> String) -> ([Chest] -> ShowS) -> Show Chest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Chest -> ShowS
showsPrec :: Int -> Chest -> ShowS
$cshow :: Chest -> String
show :: Chest -> String
$cshowList :: [Chest] -> ShowS
showList :: [Chest] -> ShowS
Show, Chest -> Chest -> Bool
(Chest -> Chest -> Bool) -> (Chest -> Chest -> Bool) -> Eq Chest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Chest -> Chest -> Bool
== :: Chest -> Chest -> Bool
$c/= :: Chest -> Chest -> Bool
/= :: Chest -> Chest -> Bool
Eq, (forall x. Chest -> Rep Chest x)
-> (forall x. Rep Chest x -> Chest) -> Generic Chest
forall x. Rep Chest x -> Chest
forall x. Chest -> Rep Chest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Chest -> Rep Chest x
from :: forall x. Chest -> Rep Chest x
$cto :: forall x. Rep Chest x -> Chest
to :: forall x. Rep Chest x -> Chest
Generic)
    deriving anyclass Chest -> ()
(Chest -> ()) -> NFData Chest
forall a. (a -> ()) -> NFData a
$crnf :: Chest -> ()
rnf :: Chest -> ()
NFData

instance Bi.Binary Chest where
  put :: Chest -> Put
put Chest{Ciphertext
Locked
PublicModulus
chestLockedVal :: Chest -> Locked
chestPublicModulus :: Chest -> PublicModulus
chestCiphertext :: Chest -> Ciphertext
chestLockedVal :: Locked
chestPublicModulus :: PublicModulus
chestCiphertext :: Ciphertext
..} = do
    Builder -> Put
Bi.putBuilder (Builder -> Put) -> Builder -> Put
forall a b. (a -> b) -> a -> b
$ Integer -> Builder
buildNatural (Locked -> Integer
unLocked Locked
chestLockedVal)
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
buildNatural (PublicModulus -> Integer
unPublicModulus PublicModulus
chestPublicModulus)
    Ciphertext -> Put
forall t. Binary t => t -> Put
Bi.put Ciphertext
chestCiphertext

  get :: Get Chest
get = do
    Locked
chestLockedVal <- Integer -> Locked
Locked (Integer -> Locked) -> Get Integer -> Get Locked
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
getNatural
    PublicModulus
chestPublicModulus <- Integer -> PublicModulus
PublicModulus (Integer -> PublicModulus) -> Get Integer -> Get PublicModulus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Integer
getNatural
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Locked -> Integer
unLocked Locked
chestLockedVal Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= PublicModulus -> Integer
unPublicModulus PublicModulus
chestPublicModulus) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"locked value is not in the rsa group"
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PublicModulus -> Integer
unPublicModulus PublicModulus
chestPublicModulus Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
minPublicModulus) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"public modulus is too small"
    Ciphertext
chestCiphertext <- Get Ciphertext
forall t. Binary t => Get t
Bi.get
    pure Chest{Ciphertext
Locked
PublicModulus
chestLockedVal :: Locked
chestPublicModulus :: PublicModulus
chestCiphertext :: Ciphertext
chestLockedVal :: Locked
chestPublicModulus :: PublicModulus
chestCiphertext :: Ciphertext
..}
    where
      -- hard-coded in the reference implementation
      -- https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml#L193
      minPublicModulus :: Integer
minPublicModulus = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
2 Int
2000

type SizeModulus = 256 -- bytes, i.e. 2048 bits
type HalfModulus = Div SizeModulus 2 -- bytes, i.e. 1024 bits

randomInt :: forall n. (KnownNat n) => IO Integer
randomInt :: forall (n :: Nat). KnownNat n => IO Integer
randomInt = SizedByteArray n ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (SizedByteArray n ByteString -> Integer)
-> IO (SizedByteArray n ByteString) -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ba (n :: Nat).
(ByteArray ba, KnownNat n) =>
IO (SizedByteArray n ba)
Random.generate @ByteString @n

randomPrime :: forall n. (KnownNat n) => IO Integer
randomPrime :: forall (n :: Nat). KnownNat n => IO Integer
randomPrime = Integer -> Integer
findPrimeFrom (Integer -> Integer) -> IO Integer -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat). KnownNat n => IO Integer
randomInt @n

unlockedValueToSymmetricKey :: Unlocked -> SymmetricKey
unlockedValueToSymmetricKey :: Unlocked -> SymmetricKey
unlockedValueToSymmetricKey (Unlocked Integer
value) =
  -- "Tezoskdftimelockv0" is hard-coded in the reference implementation
  -- see https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml#L47
  let ByteString
key :: ByteString = ByteString
"Tezoskdftimelockv0"
      ByteString
str :: ByteString = Integer -> ByteString
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Integer
value
  in SizedByteArray 32 ByteString -> SymmetricKey
SymmetricKey (SizedByteArray 32 ByteString -> SymmetricKey)
-> SizedByteArray 32 ByteString -> SymmetricKey
forall a b. (a -> b) -> a -> b
$ forall (len :: Nat) hashBytes pt key.
(ByteArrayAccess pt, ByteArrayAccess key, ByteArray hashBytes,
 KnownNat len, CRYPTO_GENERICHASH_BYTES_MIN <= len,
 len <= CRYPTO_GENERICHASH_BYTES_MAX) =>
key -> pt -> HashBlake2b len hashBytes
blake2bWithKey @32 @ByteString ByteString
key ByteString
str

genRSAFactors :: IO (PublicModulus, RSAFactors)
genRSAFactors :: IO (PublicModulus, RSAFactors)
genRSAFactors = do
  Integer
p <- forall (n :: Nat). KnownNat n => IO Integer
randomPrime @HalfModulus
  Integer
q <- forall (n :: Nat). KnownNat n => IO Integer
randomPrime @HalfModulus
  pure (Integer -> PublicModulus
PublicModulus (Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
q), Integer -> Integer -> RSAFactors
RSAFactors Integer
p Integer
q)

genLockedValue :: PublicModulus -> IO Locked
genLockedValue :: PublicModulus -> IO Locked
genLockedValue (PublicModulus Integer
pub) = do
  Integer
z <- forall (n :: Nat). KnownNat n => IO Integer
randomInt @(SizeModulus + 16)
  Locked -> IO Locked
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Locked -> IO Locked)
-> (Integer -> Locked) -> Integer -> IO Locked
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Locked
Locked (Integer -> IO Locked) -> Integer -> IO Locked
forall a b. (a -> b) -> a -> b
$ Integer
z Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
pub

hashToPrime :: PublicModulus -> TLTime -> Locked -> Unlocked -> Integer
hashToPrime :: PublicModulus -> TLTime -> Locked -> Unlocked -> Integer
hashToPrime (PublicModulus Integer
pub) (TLTime Word62
time) (Locked Integer
locked) (Unlocked Integer
unlocked) =
  -- "\32" and "\xff\x00\xff\x00\xff\x00\xff\x00" are hard-coded in the reference implementation
  -- see https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml#L78
  -- and https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml#L81
  let ByteString
personalization :: ByteString = ByteString
"\32"
      s :: ByteString
s = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\xff\x00\xff\x00\xff\x00\xff\x00" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
        Word62 -> ByteString
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Word62
time ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Integer -> ByteString) -> [Integer] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
pad (ByteString -> ByteString)
-> (Integer -> ByteString) -> Integer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp) [Integer
pub, Integer
locked, Integer
unlocked]
      SizedByteArray 32 ByteString
hash_result :: SizedByteArray 32 ByteString = ByteString -> ByteString -> SizedByteArray 32 ByteString
forall (len :: Nat) hashBytes pt key.
(ByteArrayAccess pt, ByteArrayAccess key, ByteArray hashBytes,
 KnownNat len, CRYPTO_GENERICHASH_BYTES_MIN <= len,
 len <= CRYPTO_GENERICHASH_BYTES_MAX) =>
key -> pt -> HashBlake2b len hashBytes
blake2bWithKey ByteString
personalization ByteString
s
  in Integer -> Integer
findPrimeFrom (SizedByteArray 32 ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip SizedByteArray 32 ByteString
hash_result)
  where
    -- pads right with zero bytes so that length is multiple of 8
    -- this is needed due to a quirk of how @Z.to_bits@ works in OCaml
    pad :: ByteString -> ByteString
pad ByteString
bs =
      let len :: Int
len = ByteString -> Int
forall i a.
(Integral i, Container a,
 DefaultToInt (IsIntSubType Length i) i) =>
a -> i
length ByteString
bs
          newlen :: Int
newlen = Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegralOverflowing Int
len :: Rational) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
          diff :: Int
diff = Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len
      in ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate Int
diff Word8
0

proveWithoutSecret :: PublicModulus -> TLTime -> Locked -> Unlocked -> Proof
proveWithoutSecret :: PublicModulus -> TLTime -> Locked -> Unlocked -> Proof
proveWithoutSecret (PublicModulus Integer
pub) TLTime
time (Locked Integer
locked) (Unlocked Integer
unlocked) =
  let l :: Integer
l = PublicModulus -> TLTime -> Locked -> Unlocked -> Integer
hashToPrime (Integer -> PublicModulus
PublicModulus Integer
pub) TLTime
time (Integer -> Locked
Locked Integer
locked) (Integer -> Unlocked
Unlocked Integer
unlocked)
      pow :: Integer
pow = (Integer
2 Integer -> Word62 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ TLTime -> Word62
unTLTime TLTime
time) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
l
  in Integer -> Proof
Proof (Integer -> Proof) -> Integer -> Proof
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> Integer
expFast Integer
locked Integer
pow Integer
pub

verifyTimeLock :: PublicModulus -> TLTime -> Locked -> Unlocked -> Proof -> Bool
verifyTimeLock :: PublicModulus -> TLTime -> Locked -> Unlocked -> Proof -> Bool
verifyTimeLock (PublicModulus Integer
pub) TLTime
time (Locked Integer
locked) (Unlocked Integer
unlocked) (Proof Integer
proof) =
  let l :: Integer
l = PublicModulus -> TLTime -> Locked -> Unlocked -> Integer
hashToPrime (Integer -> PublicModulus
PublicModulus Integer
pub) TLTime
time (Integer -> Locked
Locked Integer
locked) (Integer -> Unlocked
Unlocked Integer
unlocked)
      r :: Integer
r = Integer -> Integer -> Integer -> Integer
expFast Integer
2 (Word62 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word62 -> Integer) -> Word62 -> Integer
forall a b. (a -> b) -> a -> b
$ TLTime -> Word62
unTLTime TLTime
time) Integer
l
  in Integer
unlocked Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== (Integer -> Integer -> Integer -> Integer
expFast Integer
proof Integer
l Integer
pub Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer -> Integer -> Integer -> Integer
expFast Integer
locked Integer
r Integer
pub) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
pub

unlockAndProveWithSecret :: RSAFactors -> TLTime -> Locked -> (Unlocked, Proof)
unlockAndProveWithSecret :: RSAFactors -> TLTime -> Locked -> (Unlocked, Proof)
unlockAndProveWithSecret RSAFactors{Integer
rsaP :: RSAFactors -> Integer
rsaQ :: RSAFactors -> Integer
rsaP :: Integer
rsaQ :: Integer
..} TLTime
time (Locked Integer
locked) =
  (Integer -> Unlocked
Unlocked Integer
unlocked, Integer -> Proof
Proof Integer
proof)
  where
    phi :: Integer
phi = (Integer
rsaP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
rsaQ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
    pub :: Integer
pub = Integer
rsaP Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
rsaQ
    e :: Integer
e = Integer -> Integer -> Integer -> Integer
expFast Integer
2 (Word62 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word62 -> Integer) -> Word62 -> Integer
forall a b. (a -> b) -> a -> b
$ TLTime -> Word62
unTLTime TLTime
time) Integer
phi
    unlocked :: Integer
unlocked = Integer -> Integer -> Integer -> Integer
expFast Integer
locked Integer
e Integer
pub
    l :: Integer
l = PublicModulus -> TLTime -> Locked -> Unlocked -> Integer
hashToPrime (Integer -> PublicModulus
PublicModulus Integer
pub) TLTime
time (Integer -> Locked
Locked Integer
locked) (Integer -> Unlocked
Unlocked Integer
unlocked)
    pow :: Integer
pow = ((Integer
2 Integer -> Word62 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ TLTime -> Word62
unTLTime TLTime
time) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
l) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
phi
    proof :: Integer
proof = Integer -> Integer -> Integer -> Integer
expFast Integer
locked Integer
pow Integer
pub

unlockWithoutSecret :: PublicModulus -> TLTime -> Locked -> Unlocked
unlockWithoutSecret :: PublicModulus -> TLTime -> Locked -> Unlocked
unlockWithoutSecret (PublicModulus Integer
pub) (TLTime Word62
time) (Locked Integer
locked) =
  Integer -> Unlocked
Unlocked (Integer -> Unlocked) -> Integer -> Unlocked
forall a b. (a -> b) -> a -> b
$ Word62 -> Integer -> Integer
go Word62
time Integer
locked
  where
    go :: Word62 -> Integer -> Integer
go Word62
0 Integer
v = Integer
v
    go Word62
t Integer
v = Word62 -> Integer -> Integer
go (Word62 -> Word62
forall a. Enum a => a -> a
pred Word62
t) (Integer
v Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
v Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
pub)

encrypt :: SymmetricKey -> ByteString -> IO Ciphertext
encrypt :: SymmetricKey -> ByteString -> IO Ciphertext
encrypt (SymmetricKey SizedByteArray 32 ByteString
key) ByteString
plaintext = do
  Nonce ByteString
nonce <- IO (Nonce ByteString)
forall (n :: Nat). KnownNat n => IO (SizedByteArray n ByteString)
Nonce.generate
  let payload :: ByteString
payload = SizedByteArray 32 ByteString
-> Nonce ByteString -> ByteString -> ByteString
forall keyBytes nonceBytes ptBytes ctBytes.
(ByteArrayAccess keyBytes, ByteArrayAccess nonceBytes,
 ByteArrayAccess ptBytes, ByteArray ctBytes) =>
Key keyBytes -> Nonce nonceBytes -> ptBytes -> ctBytes
Box.encrypt SizedByteArray 32 ByteString
key Nonce ByteString
nonce ByteString
plaintext
  Ciphertext -> IO Ciphertext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ciphertext -> IO Ciphertext) -> Ciphertext -> IO Ciphertext
forall a b. (a -> b) -> a -> b
$ Nonce -> ByteString -> Ciphertext
Ciphertext (Nonce ByteString -> Nonce
Nonce Nonce ByteString
nonce) ByteString
payload

decrypt :: SymmetricKey -> Ciphertext -> Maybe ByteString
decrypt :: SymmetricKey -> Ciphertext -> Maybe ByteString
decrypt (SymmetricKey SizedByteArray 32 ByteString
key) Ciphertext{ctNonce :: Ciphertext -> Nonce
ctNonce = Nonce Nonce ByteString
nonce, ByteString
ctPayload :: Ciphertext -> ByteString
ctPayload :: ByteString
..}
  = SizedByteArray 32 ByteString
-> Nonce ByteString -> ByteString -> Maybe ByteString
forall keyBytes nonceBytes ptBytes ctBytes.
(ByteArrayAccess keyBytes, ByteArrayAccess nonceBytes,
 ByteArray ptBytes, ByteArrayAccess ctBytes) =>
Key keyBytes -> Nonce nonceBytes -> ctBytes -> Maybe ptBytes
Box.decrypt SizedByteArray 32 ByteString
key Nonce ByteString
nonce ByteString
ctPayload

-- | Create a timelock puzzle and a key.
createChestAndChestKey
  :: ByteString -- ^ Chest content
  -> TLTime -- ^ Time (in elementary actions) to open without key.
  -> IO (Chest, ChestKey)
createChestAndChestKey :: ByteString -> TLTime -> IO (Chest, ChestKey)
createChestAndChestKey ByteString
payload TLTime
time = do
  (PublicModulus
pub, RSAFactors
secret) <- IO (PublicModulus, RSAFactors)
genRSAFactors
  Locked
locked <- PublicModulus -> IO Locked
genLockedValue PublicModulus
pub
  let (Unlocked
unlocked, Proof
proof) = RSAFactors -> TLTime -> Locked -> (Unlocked, Proof)
unlockAndProveWithSecret RSAFactors
secret TLTime
time Locked
locked
      key :: SymmetricKey
key = Unlocked -> SymmetricKey
unlockedValueToSymmetricKey Unlocked
unlocked
  Ciphertext
ciphertext <- SymmetricKey -> ByteString -> IO Ciphertext
encrypt SymmetricKey
key ByteString
payload
  pure $ (Locked -> PublicModulus -> Ciphertext -> Chest
Chest Locked
locked PublicModulus
pub Ciphertext
ciphertext, Unlocked -> Proof -> ChestKey
ChestKey Unlocked
unlocked Proof
proof)

-- | Forge a chest key the hard way.
createChestKey :: Chest -> TLTime -> ChestKey
createChestKey :: Chest -> TLTime -> ChestKey
createChestKey Chest{Ciphertext
Locked
PublicModulus
chestLockedVal :: Chest -> Locked
chestPublicModulus :: Chest -> PublicModulus
chestCiphertext :: Chest -> Ciphertext
chestLockedVal :: Locked
chestPublicModulus :: PublicModulus
chestCiphertext :: Ciphertext
..} TLTime
time =
  let unlocked :: Unlocked
unlocked = PublicModulus -> TLTime -> Locked -> Unlocked
unlockWithoutSecret PublicModulus
chestPublicModulus TLTime
time Locked
chestLockedVal
      proof :: Proof
proof = PublicModulus -> TLTime -> Locked -> Unlocked -> Proof
proveWithoutSecret PublicModulus
chestPublicModulus TLTime
time Locked
chestLockedVal Unlocked
unlocked
  in Unlocked -> Proof -> ChestKey
ChestKey Unlocked
unlocked Proof
proof

-- | The result of opening the chest.
data OpeningResult
  = Correct ByteString -- ^ The chest was opened correctly.
  | BogusCipher -- ^ The chest was opened correctly, but the contents do not decode with
  -- the given symmetric key.
  | BogusOpening -- ^ The chest was not opened correctly, i.e. proof verification failed.
  deriving stock (Int -> OpeningResult -> ShowS
[OpeningResult] -> ShowS
OpeningResult -> String
(Int -> OpeningResult -> ShowS)
-> (OpeningResult -> String)
-> ([OpeningResult] -> ShowS)
-> Show OpeningResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpeningResult -> ShowS
showsPrec :: Int -> OpeningResult -> ShowS
$cshow :: OpeningResult -> String
show :: OpeningResult -> String
$cshowList :: [OpeningResult] -> ShowS
showList :: [OpeningResult] -> ShowS
Show, OpeningResult -> OpeningResult -> Bool
(OpeningResult -> OpeningResult -> Bool)
-> (OpeningResult -> OpeningResult -> Bool) -> Eq OpeningResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpeningResult -> OpeningResult -> Bool
== :: OpeningResult -> OpeningResult -> Bool
$c/= :: OpeningResult -> OpeningResult -> Bool
/= :: OpeningResult -> OpeningResult -> Bool
Eq)

-- | Try to (quickly) open a chest with the given key, verifying the proof.
openChest :: Chest -> ChestKey -> TLTime -> OpeningResult
openChest :: Chest -> ChestKey -> TLTime -> OpeningResult
openChest Chest{Ciphertext
Locked
PublicModulus
chestLockedVal :: Chest -> Locked
chestPublicModulus :: Chest -> PublicModulus
chestCiphertext :: Chest -> Ciphertext
chestLockedVal :: Locked
chestPublicModulus :: PublicModulus
chestCiphertext :: Ciphertext
..} ChestKey{Proof
Unlocked
ckUnlockedVal :: ChestKey -> Unlocked
ckProof :: ChestKey -> Proof
ckUnlockedVal :: Unlocked
ckProof :: Proof
..} TLTime
time
  | PublicModulus -> TLTime -> Locked -> Unlocked -> Proof -> Bool
verifyTimeLock PublicModulus
chestPublicModulus TLTime
time Locked
chestLockedVal Unlocked
ckUnlockedVal Proof
ckProof
  = OpeningResult
-> (ByteString -> OpeningResult)
-> Maybe ByteString
-> OpeningResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe OpeningResult
BogusCipher ByteString -> OpeningResult
Correct (Maybe ByteString -> OpeningResult)
-> Maybe ByteString -> OpeningResult
forall a b. (a -> b) -> a -> b
$
      SymmetricKey -> Ciphertext -> Maybe ByteString
decrypt (Unlocked -> SymmetricKey
unlockedValueToSymmetricKey Unlocked
ckUnlockedVal) Ciphertext
chestCiphertext
  | Bool
otherwise = OpeningResult
BogusOpening

-- | Convert a 'ChestKey' to binary representation, used by Tezos
chestKeyBytes :: ChestKey -> ByteString
chestKeyBytes :: ChestKey -> ByteString
chestKeyBytes = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (ChestKey -> ByteString) -> ChestKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChestKey -> ByteString
forall a. Binary a => a -> ByteString
Bi.encode

-- | Convert a 'Chest' to binary representation, used by Tezos
chestBytes :: Chest -> ByteString
chestBytes :: Chest -> ByteString
chestBytes = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Chest -> ByteString) -> Chest -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chest -> ByteString
forall a. Binary a => a -> ByteString
Bi.encode

-- | Read a 'Chest' from binary representation, used by Tezos
chestFromBytes :: ByteString -> Either Text Chest
chestFromBytes :: ByteString -> Either Text Chest
chestFromBytes ByteString
bs = case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Chest)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Bi.decodeOrFail (ByteString
 -> Either
      (ByteString, ByteOffset, String) (ByteString, ByteOffset, Chest))
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, Chest)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs of
  Right (ByteString
trail, ByteOffset
_, Chest
res)
    | ByteString -> Bool
forall t. Container t => t -> Bool
null ByteString
trail -> Chest -> Either Text Chest
forall a b. b -> Either a b
Right Chest
res
    | Bool
otherwise -> Text -> Either Text Chest
forall a b. a -> Either a b
Left Text
"trailing unconsumed bytes"
  Left (ByteString
_, ByteOffset
_, String
err) -> Text -> Either Text Chest
forall a b. a -> Either a b
Left (String -> Text
forall a. IsString a => String -> a
fromString String
err)

-- | Read a 'ChestKey' from binary representation, used by Tezos
chestKeyFromBytes :: ByteString -> Either Text ChestKey
chestKeyFromBytes :: ByteString -> Either Text ChestKey
chestKeyFromBytes ByteString
bs = case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, ChestKey)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Bi.decodeOrFail (ByteString
 -> Either
      (ByteString, ByteOffset, String)
      (ByteString, ByteOffset, ChestKey))
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, ChestKey)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs of
  Right (ByteString
trail, ByteOffset
_, ChestKey
res)
    | ByteString -> Bool
forall t. Container t => t -> Bool
null ByteString
trail -> ChestKey -> Either Text ChestKey
forall a b. b -> Either a b
Right ChestKey
res
    | Bool
otherwise -> Text -> Either Text ChestKey
forall a b. a -> Either a b
Left Text
"trailing unconsumed bytes"
  Left (ByteString
_, ByteOffset
_, String
err) -> Text -> Either Text ChestKey
forall a b. a -> Either a b
Left (String -> Text
forall a. IsString a => String -> a
fromString String
err)

-- | Construct a chest purely based on a seed for pseudorandom generator.
-- This is not suitable for cryptography, used in tests.
createChestAndChestKeyFromSeed
  :: Int -- ^ Pseudo-random seed
  -> ByteString -- ^ Chest content
  -> TLTime -- ^ TLTime (in elementary actions) to open without key.
  -> (Chest, ChestKey)
createChestAndChestKeyFromSeed :: Int -> ByteString -> TLTime -> (Chest, ChestKey)
createChestAndChestKeyFromSeed Int
seed ByteString
payload TLTime
time = (Rand StdGen (Chest, ChestKey) -> StdGen -> (Chest, ChestKey))
-> StdGen -> Rand StdGen (Chest, ChestKey) -> (Chest, ChestKey)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rand StdGen (Chest, ChestKey) -> StdGen -> (Chest, ChestKey)
forall g a. Rand g a -> g -> a
evalRand (Int -> StdGen
mkStdGen Int
seed) do
  let rangeLow :: Integer
rangeLow = Integer
2 Integer -> Nat -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal @HalfModulus Proxy 128
Proxy HalfModulus
forall {k} (t :: k). Proxy t
Proxy Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
* Nat
8)
      rangeHigh :: Integer
rangeHigh = Integer
rangeLow Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      range :: (Integer, Integer)
range = (Integer
rangeLow, Integer
rangeHigh)
  Integer
p' <- (Integer, Integer) -> RandT StdGen Identity Integer
forall a. Random a => (a, a) -> RandT StdGen Identity a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Integer, Integer)
range
  Integer
q' <- (Integer, Integer) -> RandT StdGen Identity Integer
forall a. Random a => (a, a) -> RandT StdGen Identity a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Integer, Integer)
range
  let pub :: PublicModulus
pub = Integer -> PublicModulus
PublicModulus Integer
pub'
      pub' :: Integer
pub' = Integer
p Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
q
      p :: Integer
p = Integer -> Integer
findPrimeFrom Integer
p'
      q :: Integer
q = Integer -> Integer
findPrimeFrom Integer
q'
      secret :: RSAFactors
secret = Integer -> Integer -> RSAFactors
RSAFactors Integer
p Integer
q
      lockedMax :: Integer
lockedMax = Integer
2 Integer -> Nat -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal @SizeModulus Proxy SizeModulus
forall {k} (t :: k). Proxy t
Proxy Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
16) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
  Locked
locked <- Integer -> Locked
Locked (Integer -> Locked) -> (Integer -> Integer) -> Integer -> Locked
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
pub') (Integer -> Locked)
-> RandT StdGen Identity Integer -> RandT StdGen Identity Locked
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> RandT StdGen Identity Integer
forall a. Random a => (a, a) -> RandT StdGen Identity a
forall (m :: * -> *) a. (MonadRandom m, Random a) => (a, a) -> m a
getRandomR (Integer
0, Integer
lockedMax)
  let (Unlocked
unlocked, Proof
proof) = RSAFactors -> TLTime -> Locked -> (Unlocked, Proof)
unlockAndProveWithSecret RSAFactors
secret TLTime
time Locked
locked
      SymmetricKey SizedByteArray 32 ByteString
key = Unlocked -> SymmetricKey
unlockedValueToSymmetricKey Unlocked
unlocked
  Nonce ByteString
nonce <- Nonce ByteString -> Maybe (Nonce ByteString) -> Nonce ByteString
forall a. a -> Maybe a -> a
fromMaybe (Text -> Nonce ByteString
forall a. HasCallStack => Text -> a
error Text
"impossible") (Maybe (Nonce ByteString) -> Nonce ByteString)
-> (ByteString -> Maybe (Nonce ByteString))
-> ByteString
-> Nonce ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Nonce ByteString)
forall (n :: Nat) ba.
(KnownNat n, ByteArrayAccess ba) =>
ba -> Maybe (SizedByteArray n ba)
sizedByteArray (ByteString -> Nonce ByteString)
-> RandT StdGen Identity ByteString
-> RandT StdGen Identity (Nonce ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StdGen -> (ByteString, StdGen))
-> RandT StdGen Identity ByteString
forall g a. (g -> (a, g)) -> Rand g a
liftRand (Int -> StdGen -> (ByteString, StdGen)
forall g. RandomGen g => Int -> g -> (ByteString, g)
genByteString Int
24)
  let ciphertext :: Ciphertext
ciphertext = Nonce -> ByteString -> Ciphertext
Ciphertext (Nonce ByteString -> Nonce
Nonce Nonce ByteString
nonce) (ByteString -> Ciphertext) -> ByteString -> Ciphertext
forall a b. (a -> b) -> a -> b
$ SizedByteArray 32 ByteString
-> Nonce ByteString -> ByteString -> ByteString
forall keyBytes nonceBytes ptBytes ctBytes.
(ByteArrayAccess keyBytes, ByteArrayAccess nonceBytes,
 ByteArrayAccess ptBytes, ByteArray ctBytes) =>
Key keyBytes -> Nonce nonceBytes -> ptBytes -> ctBytes
Box.encrypt SizedByteArray 32 ByteString
key Nonce ByteString
nonce ByteString
payload
  (Chest, ChestKey) -> Rand StdGen (Chest, ChestKey)
forall a. a -> RandT StdGen Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Chest, ChestKey) -> Rand StdGen (Chest, ChestKey))
-> (Chest, ChestKey) -> Rand StdGen (Chest, ChestKey)
forall a b. (a -> b) -> a -> b
$ (Locked -> PublicModulus -> Ciphertext -> Chest
Chest Locked
locked PublicModulus
pub Ciphertext
ciphertext, Unlocked -> Proof -> ChestKey
ChestKey Unlocked
unlocked Proof
proof)