{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module SLIP32
(
parse
, parseXPub
, parseXPrv
, parseText
, parseXPubText
, parseXPrvText
, renderXPub
, renderXPrv
, renderXPubText
, renderXPrvText
, XPub(..)
, XPrv(..)
, Path
, path
, unPath
) where
import qualified BIP32 as A
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
data XPub = XPub !Path !A.Chain !A.Pub
deriving (Eq, Show)
data XPrv = XPrv !Path !A.Chain !A.Prv
deriving (Eq, Show)
data Path = Path !Word8 ![A.Index]
deriving (Eq, Show)
unPath :: Path -> [A.Index]
unPath (Path _ x) = x
path :: [A.Index] -> Maybe Path
{-# INLINE path #-}
path x | l < 256 = Just (Path (fromIntegral l) x)
| otherwise = Nothing
where l = length x
parseXPub :: B.ByteString -> Maybe XPub
{-# INLINE parseXPub #-}
parseXPub = parseXPubText <=< hush . T.decodeUtf8'
parseXPrv :: B.ByteString -> Maybe XPrv
{-# INLINE parseXPrv #-}
parseXPrv = parseXPrvText <=< hush . T.decodeUtf8'
parse :: B.ByteString -> Maybe (Either XPub XPrv)
{-# INLINE parse #-}
parse = parseText <=< hush . T.decodeUtf8'
parseXPubText :: T.Text -> Maybe XPub
{-# INLINE parseXPubText #-}
parseXPubText = either Just (\_ -> Nothing) <=< parseText
parseXPrvText :: T.Text -> Maybe XPrv
{-# INLINE parseXPrvText #-}
parseXPrvText = either (\_ -> Nothing) Just <=< parseText
parseText :: T.Text -> Maybe (Either XPub XPrv)
parseText = \t0 -> do
(hrp, dp) <- hush $ Bech32.decodeLenient t0
raw <- Bech32.dataPartToBytes dp
case Bin.runGetOrFail getRawSLIP32 (BL.fromStrict raw) of
Right (lo, _, out@(Left _)) | BL.null lo && hrp == hrpXPub -> Just out
Right (lo, _, out@(Right _)) | BL.null lo && hrp == hrpXPrv -> Just out
_ -> Nothing
getRawSLIP32 :: Bin.Get (Either XPub XPrv)
getRawSLIP32 = do
pa <- getPath
cc <- getChain
fmap (Left . XPub pa cc) getPub <|> fmap (Right . XPrv pa cc) getPrv
getPath :: Bin.Get Path
{-# INLINE getPath #-}
getPath = do
depth <- Bin.getWord8
Path depth <$> replicateM (fromIntegral depth) getIndex
getIndex :: Bin.Get A.Index
{-# INLINE getIndex #-}
getIndex = A.Index <$> Bin.getWord32be
getChain :: Bin.Get A.Chain
{-# INLINE getChain #-}
getChain = do
a <- Bin.getByteString 32
case A.chain a of
Just b -> pure b
Nothing -> fail "Bad chain code"
getPrv :: Bin.Get A.Prv
{-# INLINE getPrv #-}
getPrv = do
0 <- Bin.getWord8
a <- Bin.getByteString 32
case A.prv a of
Just b -> pure b
Nothing -> fail "Bad private key"
getPub :: Bin.Get A.Pub
{-# INLINE getPub #-}
getPub = do
a <- Bin.getByteString 33
case A.pub a of
Just b -> pure b
Nothing -> fail "Bad public key"
renderXPub :: XPub -> B.ByteString
{-# INLINE renderXPub #-}
renderXPub = T.encodeUtf8 . renderXPubText
renderXPrv :: XPrv -> B.ByteString
{-# INLINE renderXPrv #-}
renderXPrv = T.encodeUtf8 . renderXPrvText
renderXPubText :: XPub -> T.Text
{-# INLINE renderXPubText #-}
renderXPubText = \(XPub p c k) -> renderText hrpXPub p c (keyPub k)
renderXPrvText :: XPrv -> T.Text
{-# INLINE renderXPrvText #-}
renderXPrvText = \(XPrv p c k) -> renderText hrpXPrv p c (keyPrv k)
newtype Key = Key B.ByteString
keyPub :: A.Pub -> Key
{-# INLINE keyPub #-}
keyPub = Key . A.unPub
keyPrv :: A.Prv -> Key
{-# INLINE keyPrv #-}
keyPrv = Key . B.cons 0 . A.unPrv
renderText :: Bech32.HumanReadablePart -> Path -> A.Chain -> Key -> T.Text
renderText hrp (Path pl p) c (Key k)
= Bech32.encodeLenient hrp
$ Bech32.dataPartFromBytes
$ BL.toStrict
$ BB.toLazyByteString
$ mconcat [ BB.word8 pl
, foldMap BB.word32BE (fmap (\(A.Index w) -> w) p)
, BB.byteString (A.unChain c)
, BB.byteString k ]
hrpXPub :: Bech32.HumanReadablePart
Right hrpXPub = Bech32.humanReadablePartFromText "xpub"
hrpXPrv :: Bech32.HumanReadablePart
Right hrpXPrv = Bech32.humanReadablePartFromText "xprv"
hush :: Either a b -> Maybe b
{-# INLINE hush #-}
hush = either (\_ -> Nothing) Just