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

module Bcc.CLI.Cole.Legacy (
      LegacyDelegateKey(..)
    , encodeLegacyDelegateKey
    , decodeLegacyDelegateKey
    ) where

import           Bcc.Prelude hiding (option)

import qualified Codec.CBOR.Decoding as D
import qualified Codec.CBOR.Encoding as E

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

-- | 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/The-Blockchain-Company/bcc-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 :: Decoder s XPrv
decodeXPrv =
  Either String XPrv -> Decoder s XPrv
forall e a s. Buildable e => Either e a -> Decoder s a
toCborError (Either String XPrv -> Decoder s XPrv)
-> (ByteString -> Either String XPrv)
-> ByteString
-> Decoder s XPrv
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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: bcc-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 :: 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 (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: bcc-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 :: 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
$
    Text -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (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 b. (Show a, ConvertText String b) => a -> b
show 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 b. (Show a, ConvertText String b) => a -> b
show Int
actualSize)

-- | Encoder for a Cole/Classic signing key.
--   Lifted from bcc-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 Cole/Classic signing key.
--   Lifted from bcc-sl legacy codebase.
decodeLegacyDelegateKey :: D.Decoder s LegacyDelegateKey
decodeLegacyDelegateKey :: 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 (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