{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Byron.Legacy
  ( LegacyDelegateKey (..)
  , encodeLegacyDelegateKey
  , decodeLegacyDelegateKey
  )
where

import           Cardano.Api (textShow)

import           Cardano.Crypto.Signing (SigningKey (..))
import qualified Cardano.Crypto.Wallet as Wallet

import qualified Codec.CBOR.Decoding as D
import qualified Codec.CBOR.Encoding as E
import           Control.Monad (when)
import           Data.Text (Text)
import           Formatting (build, formatToString)

-- | LegacyDelegateKey is a subset of the UserSecret's from the legacy codebase:
-- 1. the VSS keypair must be present
-- 2. the signing key must be present
-- 3. the rest must be absent (Nothing)
--
-- Legacy reference: https://github.com/input-output-hk/cardano-sl/blob/release/3.0.1/lib/src/Pos/Util/UserSecret.hs#L189
newtype LegacyDelegateKey = LegacyDelegateKey {LegacyDelegateKey -> SigningKey
lrkSigningKey :: SigningKey}

encodeXPrv :: Wallet.XPrv -> E.Encoding
encodeXPrv :: XPrv -> Encoding
encodeXPrv XPrv
a = ByteString -> Encoding
E.encodeBytes (ByteString -> Encoding) -> ByteString -> Encoding
forall a b. (a -> b) -> a -> b
$ XPrv -> ByteString
Wallet.unXPrv XPrv
a

decodeXPrv :: D.Decoder s Wallet.XPrv
decodeXPrv :: forall s. Decoder s XPrv
decodeXPrv =
  (String -> Decoder s XPrv)
-> (XPrv -> Decoder s XPrv) -> Either String XPrv -> Decoder s XPrv
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Decoder s XPrv
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s XPrv)
-> (String -> String) -> String -> Decoder s XPrv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format String (String -> String) -> String -> String
forall a. Format String a -> a
formatToString Format String (String -> String)
forall a r. Buildable a => Format r (a -> r)
build) XPrv -> Decoder s XPrv
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String XPrv -> Decoder s XPrv)
-> (ByteString -> Either String XPrv)
-> ByteString
-> Decoder s XPrv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String XPrv
forall bin. ByteArrayAccess bin => bin -> Either String XPrv
Wallet.xprv (ByteString -> Decoder s XPrv)
-> Decoder s ByteString -> Decoder s XPrv
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
D.decodeBytesCanonical

-- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs

-- | Enforces that the input size is the same as the decoded one, failing in
-- case it's not.
enforceSize :: Text -> Int -> D.Decoder s ()
enforceSize :: forall s. Text -> Int -> Decoder s ()
enforceSize Text
lbl Int
requestedSize = Decoder s Int
forall s. Decoder s Int
D.decodeListLenCanonical Decoder s Int -> (Int -> Decoder s ()) -> Decoder s ()
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Text -> Int -> Decoder s ()
forall s. Int -> Text -> Int -> Decoder s ()
matchSize Int
requestedSize Text
lbl

-- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs

-- | Compare two sizes, failing if they are not equal.
matchSize :: Int -> Text -> Int -> D.Decoder s ()
matchSize :: forall s. Int -> Text -> Int -> Decoder s ()
matchSize Int
requestedSize Text
lbl Int
actualSize =
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actualSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
requestedSize) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s ()) -> String -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      Format String (Text -> String) -> Text -> String
forall a. Format String a -> a
formatToString
        Format String (Text -> String)
forall a r. Buildable a => Format r (a -> r)
build
        ( Text
lbl
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed the size check. Expected "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
textShow Int
requestedSize
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", found "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
textShow Int
actualSize
        )

-- | Encoder for a Byron/Classic signing key.
--   Lifted from cardano-sl legacy codebase.
encodeLegacyDelegateKey :: LegacyDelegateKey -> E.Encoding
encodeLegacyDelegateKey :: LegacyDelegateKey -> Encoding
encodeLegacyDelegateKey (LegacyDelegateKey (SigningKey XPrv
sk)) =
  Word -> Encoding
E.encodeListLen Word
4
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
E.encodeListLen Word
1
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
E.encodeBytes ByteString
"vss deprecated"
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
E.encodeListLen Word
1
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> XPrv -> Encoding
encodeXPrv XPrv
sk
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
E.encodeListLenIndef
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
E.encodeBreak
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
E.encodeListLen Word
0

-- | Decoder for a Byron/Classic signing key.
--   Lifted from cardano-sl legacy codebase.
decodeLegacyDelegateKey :: D.Decoder s LegacyDelegateKey
decodeLegacyDelegateKey :: forall s. Decoder s LegacyDelegateKey
decodeLegacyDelegateKey = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"UserSecret" Int
4
  ByteString
_ <- do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"vss" Int
1
    Decoder s ByteString
forall s. Decoder s ByteString
D.decodeBytes
  SigningKey
pkey <- do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"pkey" Int
1
    XPrv -> SigningKey
SigningKey (XPrv -> SigningKey) -> Decoder s XPrv -> Decoder s SigningKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s XPrv
forall s. Decoder s XPrv
decodeXPrv
  [()]
_ <- do
    Decoder s ()
forall s. Decoder s ()
D.decodeListLenIndef
    ([()] -> () -> [()])
-> [()] -> ([()] -> [()]) -> Decoder s () -> Decoder s [()]
forall r a r' s.
(r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r'
D.decodeSequenceLenIndef ((() -> [()] -> [()]) -> [()] -> () -> [()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] [()] -> [()]
forall a. [a] -> [a]
reverse Decoder s ()
forall s. Decoder s ()
D.decodeNull
  ()
_ <- do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"wallet" Int
0
  LegacyDelegateKey -> Decoder s LegacyDelegateKey
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LegacyDelegateKey -> Decoder s LegacyDelegateKey)
-> LegacyDelegateKey -> Decoder s LegacyDelegateKey
forall a b. (a -> b) -> a -> b
$ SigningKey -> LegacyDelegateKey
LegacyDelegateKey SigningKey
pkey