{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

-- | SLIP-0032 is an extended serialization format
-- for [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
-- wallets.
--
-- This implementation is based on
-- the [draft SLIP-0032 spec](https://github.com/satoshilabs/slips/blob/71a3549388022820e77aa1f44c80d0f412e5529f/slip-0032.md).
--
-- Please refer to the "BIP32" module from
-- the [bip32 library](https://hackage.haskell.org/package/bip32) to
-- find more about 'A.Index' and 'A.Chain'.
--
-- Please refer to the "Bitcoin.Keys" module from
-- the [bitcoin-keys library](https://hackage.haskell.org/package/bitcoin-keys) to
-- find more about 'K.Pub' and 'K.Prv'.
module SLIP32
  ( -- * Parsing
    parse
  , parseXPub
  , parseXPrv

    -- ** Text
  , parseText
  , parseXPubText
  , parseXPrvText

    -- * Rendering
  , renderXPub
  , renderXPrv
    -- ** Text
  , renderXPubText
  , renderXPrvText

    -- * Public key
  , XPub(..)

    -- * Private key
  , XPrv(..)

    -- * Path
  , Path
  , path
  , unPath
  ) where

import qualified BIP32 as A
import qualified Bitcoin.Keys as K
import Control.Applicative
import Control.Monad
import qualified Codec.Binary.Bech32 as Bech32
import qualified Data.Binary.Get as Bin
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word

--------------------------------------------------------------------------------

-- | Extended public key.
data XPub = XPub !Path !A.Chain !K.Pub
  deriving (XPub -> XPub -> Bool
(XPub -> XPub -> Bool) -> (XPub -> XPub -> Bool) -> Eq XPub
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XPub -> XPub -> Bool
$c/= :: XPub -> XPub -> Bool
== :: XPub -> XPub -> Bool
$c== :: XPub -> XPub -> Bool
Eq, Int -> XPub -> ShowS
[XPub] -> ShowS
XPub -> String
(Int -> XPub -> ShowS)
-> (XPub -> String) -> ([XPub] -> ShowS) -> Show XPub
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XPub] -> ShowS
$cshowList :: [XPub] -> ShowS
show :: XPub -> String
$cshow :: XPub -> String
showsPrec :: Int -> XPub -> ShowS
$cshowsPrec :: Int -> XPub -> ShowS
Show)

-- | Extended private key.
data XPrv = XPrv !Path !A.Chain !K.Prv
  deriving (XPrv -> XPrv -> Bool
(XPrv -> XPrv -> Bool) -> (XPrv -> XPrv -> Bool) -> Eq XPrv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XPrv -> XPrv -> Bool
$c/= :: XPrv -> XPrv -> Bool
== :: XPrv -> XPrv -> Bool
$c== :: XPrv -> XPrv -> Bool
Eq, Int -> XPrv -> ShowS
[XPrv] -> ShowS
XPrv -> String
(Int -> XPrv -> ShowS)
-> (XPrv -> String) -> ([XPrv] -> ShowS) -> Show XPrv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XPrv] -> ShowS
$cshowList :: [XPrv] -> ShowS
show :: XPrv -> String
$cshow :: XPrv -> String
showsPrec :: Int -> XPrv -> ShowS
$cshowsPrec :: Int -> XPrv -> ShowS
Show)

-- | Derivation path.
--
-- Construct with 'path'.
data Path = Path !Word8 ![A.Index]
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)

-- | Obtains the derivation path as a list of up to 255 elements.
unPath :: Path -> [A.Index]
unPath :: Path -> [Index]
unPath (Path _ x :: [Index]
x) = [Index]
x

-- | Construct a derivation 'Path'.
--
-- Hardened keys start from \(2^{31}\).
--
-- @
-- m            = 'path' []
-- m\/0          = 'path' [0]
-- m\/0'         = 'path' [0 + 2^31]
-- m\/1          = 'path' [1]
-- m\/1'         = 'path' [1 + 2^31]
-- m\/0'\/1'\/2'\/2 = 'path' [0 + 2^31, 1 + 2^31, 2 + 2^31, 2]
-- @
--
-- See Bitcoin's [BIP-0032](https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki)
-- for details.
--
-- Returns 'Nothing' if the list length is more than 255.
path :: [A.Index] -> Maybe Path
{-# INLINE path #-}
path :: [Index] -> Maybe Path
path x :: [Index]
x | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 256 = Path -> Maybe Path
forall a. a -> Maybe a
Just (Word8 -> [Index] -> Path
Path (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) [Index]
x)
       | Bool
otherwise = Maybe Path
forall a. Maybe a
Nothing
       where l :: Int
l = [Index] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index]
x

--------------------------------------------------------------------------------

-- | Parse an 'XPub' from its SLIP-0032 representation.
parseXPub :: B.ByteString -> Maybe XPub
{-# INLINE parseXPub #-}
parseXPub :: ByteString -> Maybe XPub
parseXPub = Text -> Maybe XPub
parseXPubText (Text -> Maybe XPub)
-> (ByteString -> Maybe Text) -> ByteString -> Maybe XPub
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'

-- | Parse an 'XPrv' from its SLIP-0032 representation.
parseXPrv :: B.ByteString -> Maybe XPrv
{-# INLINE parseXPrv #-}
parseXPrv :: ByteString -> Maybe XPrv
parseXPrv = Text -> Maybe XPrv
parseXPrvText (Text -> Maybe XPrv)
-> (ByteString -> Maybe Text) -> ByteString -> Maybe XPrv
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'

-- | Parse either an 'XPub' or an 'XPrv' from its SLIP-0032 representation.
parse :: B.ByteString -> Maybe (Either XPub XPrv)
{-# INLINE parse #-}
parse :: ByteString -> Maybe (Either XPub XPrv)
parse = Text -> Maybe (Either XPub XPrv)
parseText (Text -> Maybe (Either XPub XPrv))
-> (ByteString -> Maybe Text)
-> ByteString
-> Maybe (Either XPub XPrv)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either UnicodeException Text -> Maybe Text
forall a b. Either a b -> Maybe b
hush (Either UnicodeException Text -> Maybe Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'

--------------------------------------------------------------------------------

-- | Parse an 'XPub' from its SLIP-0032 representation.
--
-- Like 'parseXPub', but takes 'T.Text'.
parseXPubText :: T.Text -> Maybe XPub
{-# INLINE parseXPubText #-}
parseXPubText :: Text -> Maybe XPub
parseXPubText = (XPub -> Maybe XPub)
-> (XPrv -> Maybe XPub) -> Either XPub XPrv -> Maybe XPub
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either XPub -> Maybe XPub
forall a. a -> Maybe a
Just (\_ -> Maybe XPub
forall a. Maybe a
Nothing) (Either XPub XPrv -> Maybe XPub)
-> (Text -> Maybe (Either XPub XPrv)) -> Text -> Maybe XPub
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Maybe (Either XPub XPrv)
parseText

-- | Parse an 'XPrv' from its SLIP-0032 representation.
--
-- Like 'parseXPrv', but takes 'T.Text'.
parseXPrvText :: T.Text -> Maybe XPrv
{-# INLINE parseXPrvText #-}
parseXPrvText :: Text -> Maybe XPrv
parseXPrvText = (XPub -> Maybe XPrv)
-> (XPrv -> Maybe XPrv) -> Either XPub XPrv -> Maybe XPrv
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\_ -> Maybe XPrv
forall a. Maybe a
Nothing) XPrv -> Maybe XPrv
forall a. a -> Maybe a
Just (Either XPub XPrv -> Maybe XPrv)
-> (Text -> Maybe (Either XPub XPrv)) -> Text -> Maybe XPrv
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Maybe (Either XPub XPrv)
parseText

-- | Parse either an 'XPub' or an 'XPrv' from its SLIP-0032 representation.
--
-- Like 'parse', but takes 'T.Text'.
parseText :: T.Text -> Maybe (Either XPub XPrv)
parseText :: Text -> Maybe (Either XPub XPrv)
parseText = \t0 :: Text
t0 -> do
  (hrp :: HumanReadablePart
hrp, dp :: DataPart
dp) <- Either DecodingError (HumanReadablePart, DataPart)
-> Maybe (HumanReadablePart, DataPart)
forall a b. Either a b -> Maybe b
hush (Either DecodingError (HumanReadablePart, DataPart)
 -> Maybe (HumanReadablePart, DataPart))
-> Either DecodingError (HumanReadablePart, DataPart)
-> Maybe (HumanReadablePart, DataPart)
forall a b. (a -> b) -> a -> b
$ Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient Text
t0
  ByteString
raw <- DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dp
  case Get (Either XPub XPrv)
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, Either XPub XPrv)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Bin.runGetOrFail Get (Either XPub XPrv)
getRawSLIP32 (ByteString -> ByteString
BL.fromStrict ByteString
raw) of
    Right (lo :: ByteString
lo, _, out :: Either XPub XPrv
out@(Left  _)) | ByteString -> Bool
BL.null ByteString
lo Bool -> Bool -> Bool
&& HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
hrpXPub -> Either XPub XPrv -> Maybe (Either XPub XPrv)
forall a. a -> Maybe a
Just Either XPub XPrv
out
    Right (lo :: ByteString
lo, _, out :: Either XPub XPrv
out@(Right _)) | ByteString -> Bool
BL.null ByteString
lo Bool -> Bool -> Bool
&& HumanReadablePart
hrp HumanReadablePart -> HumanReadablePart -> Bool
forall a. Eq a => a -> a -> Bool
== HumanReadablePart
hrpXPrv -> Either XPub XPrv -> Maybe (Either XPub XPrv)
forall a. a -> Maybe a
Just Either XPub XPrv
out
    _ -> Maybe (Either XPub XPrv)
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

getRawSLIP32 :: Bin.Get (Either XPub XPrv)
getRawSLIP32 :: Get (Either XPub XPrv)
getRawSLIP32 = do
  Path
pa <- Get Path
getPath
  Chain
cc <- Get Chain
getChain
  (Pub -> Either XPub XPrv) -> Get Pub -> Get (Either XPub XPrv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPub -> Either XPub XPrv
forall a b. a -> Either a b
Left (XPub -> Either XPub XPrv)
-> (Pub -> XPub) -> Pub -> Either XPub XPrv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Chain -> Pub -> XPub
XPub Path
pa Chain
cc) Get Pub
getPub Get (Either XPub XPrv)
-> Get (Either XPub XPrv) -> Get (Either XPub XPrv)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Prv -> Either XPub XPrv) -> Get Prv -> Get (Either XPub XPrv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPrv -> Either XPub XPrv
forall a b. b -> Either a b
Right (XPrv -> Either XPub XPrv)
-> (Prv -> XPrv) -> Prv -> Either XPub XPrv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Chain -> Prv -> XPrv
XPrv Path
pa Chain
cc) Get Prv
getPrv

getPath :: Bin.Get Path
{-# INLINE getPath #-}
getPath :: Get Path
getPath = do
  Word8
depth <- Get Word8
Bin.getWord8
  Word8 -> [Index] -> Path
Path Word8
depth ([Index] -> Path) -> Get [Index] -> Get Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Index -> Get [Index]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
depth) Get Index
getIndex

getIndex :: Bin.Get A.Index
{-# INLINE getIndex #-}
getIndex :: Get Index
getIndex = Word32 -> Index
A.Index (Word32 -> Index) -> Get Word32 -> Get Index
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Bin.getWord32be

getChain :: Bin.Get A.Chain
{-# INLINE getChain #-}
getChain :: Get Chain
getChain = do
  ByteString
a <- Int -> Get ByteString
Bin.getByteString 32
  case ByteString -> Maybe Chain
A.chain ByteString
a of
     Just b :: Chain
b -> Chain -> Get Chain
forall (f :: * -> *) a. Applicative f => a -> f a
pure Chain
b
     Nothing -> String -> Get Chain
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Bad chain code"

getPrv :: Bin.Get K.Prv
{-# INLINE getPrv #-}
getPrv :: Get Prv
getPrv = do
  Word8
0 <- Get Word8
Bin.getWord8
  ByteString
a <- Int -> Get ByteString
Bin.getByteString 32
  case ByteString -> Maybe Prv
K.parsePrv ByteString
a of
    Just b :: Prv
b -> Prv -> Get Prv
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prv
b
    Nothing -> String -> Get Prv
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Bad private key"

getPub :: Bin.Get K.Pub
{-# INLINE getPub #-}
getPub :: Get Pub
getPub = do
  ByteString
a <- Int -> Get ByteString
Bin.getByteString 33
  case ByteString -> Maybe Pub
K.parsePub ByteString
a of
    Just b :: Pub
b -> Pub -> Get Pub
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pub
b
    Nothing -> String -> Get Pub
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Bad public key"

--------------------------------------------------------------------------------

-- | Render an 'XPub' using the SLIP-0032 encoding.
renderXPub :: XPub -> B.ByteString
{-# INLINE renderXPub #-}
renderXPub :: XPub -> ByteString
renderXPub = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (XPub -> Text) -> XPub -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPub -> Text
renderXPubText

-- | Render an 'XPub' using the SLIP-0032 encoding.
renderXPrv :: XPrv -> B.ByteString
{-# INLINE renderXPrv #-}
renderXPrv :: XPrv -> ByteString
renderXPrv = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (XPrv -> Text) -> XPrv -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPrv -> Text
renderXPrvText

--------------------------------------------------------------------------------

-- | Render an 'XPub' using the SLIP-0032 encoding.
--
-- The rendered 'T.Text' is ASCII compatible.
renderXPubText :: XPub -> T.Text
{-# INLINE renderXPubText #-}
renderXPubText :: XPub -> Text
renderXPubText = \(XPub p :: Path
p c :: Chain
c k :: Pub
k) -> HumanReadablePart -> Path -> Chain -> Key -> Text
renderText HumanReadablePart
hrpXPub Path
p Chain
c (Pub -> Key
keyPub Pub
k)

-- | Render an 'XPub' using the SLIP-0032 encoding.
--
-- The rendered 'T.Text' is ASCII compatible.
renderXPrvText :: XPrv -> T.Text
{-# INLINE renderXPrvText #-}
renderXPrvText :: XPrv -> Text
renderXPrvText = \(XPrv p :: Path
p c :: Chain
c k :: Prv
k) -> HumanReadablePart -> Path -> Chain -> Key -> Text
renderText HumanReadablePart
hrpXPrv Path
p Chain
c (Prv -> Key
keyPrv Prv
k)

--------------------------------------------------------------------------------

-- | The 33-byte serialized contents of either 'K.Pub' or 'K.Prv'.
newtype Key = Key B.ByteString

keyPub :: K.Pub -> Key
{-# INLINE keyPub #-}
keyPub :: Pub -> Key
keyPub = ByteString -> Key
Key (ByteString -> Key) -> (Pub -> ByteString) -> Pub -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pub -> ByteString
K.pubCompressed

keyPrv :: K.Prv -> Key
{-# INLINE keyPrv #-}
keyPrv :: Prv -> Key
keyPrv = ByteString -> Key
Key (ByteString -> Key) -> (Prv -> ByteString) -> Prv -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> ByteString
B.cons 0 (ByteString -> ByteString)
-> (Prv -> ByteString) -> Prv -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prv -> ByteString
K.prvRaw

--------------------------------------------------------------------------------

-- | Render either an 'XPub' or an 'XPrv' using the SLIP-0032 encoding.
--
-- The rendered 'T.Text' is ASCII compatible.
renderText :: Bech32.HumanReadablePart -> Path -> A.Chain -> Key -> T.Text
renderText :: HumanReadablePart -> Path -> Chain -> Key -> Text
renderText hrp :: HumanReadablePart
hrp (Path pl :: Word8
pl p :: [Index]
p) c :: Chain
c (Key k :: ByteString
k)
  = HumanReadablePart -> DataPart -> Text
Bech32.encodeLenient HumanReadablePart
hrp
  (DataPart -> Text) -> DataPart -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> DataPart
Bech32.dataPartFromBytes
  (ByteString -> DataPart) -> ByteString -> DataPart
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict
  (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString
  (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Word8 -> Builder
BB.word8 Word8
pl
            , (Word32 -> Builder) -> [Word32] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word32 -> Builder
BB.word32BE ((Index -> Word32) -> [Index] -> [Word32]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(A.Index w :: Word32
w) -> Word32
w) [Index]
p)
            , ByteString -> Builder
BB.byteString (Chain -> ByteString
A.unChain Chain
c)
            , ByteString -> Builder
BB.byteString ByteString
k ]


--------------------------------------------------------------------------------

hrpXPub :: Bech32.HumanReadablePart
Right hrpXPub :: HumanReadablePart
hrpXPub = Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText "xpub"

hrpXPrv :: Bech32.HumanReadablePart
Right hrpXPrv :: HumanReadablePart
hrpXPrv = Text -> Either HumanReadablePartError HumanReadablePart
Bech32.humanReadablePartFromText "xprv"

--------------------------------------------------------------------------------

hush :: Either a b -> Maybe b
{-# INLINE hush #-}
hush :: Either a b -> Maybe b
hush = (a -> Maybe b) -> (b -> Maybe b) -> Either a b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\_ -> Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just