{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

module Haskoin.Crypto.Keys.Extended.Internal
  ( Fingerprint (..),
    fingerprintToText,
    textToFingerprint,
  )
where

import Control.DeepSeq (NFData)
import Control.Monad ((>=>))
import Data.Aeson
  ( FromJSON (parseJSON),
    ToJSON (toEncoding, toJSON),
    withText,
  )
import Data.Aeson.Encoding (text)
import Data.Binary (Binary (..))
import Data.Bytes.Get (getWord32be)
import Data.Bytes.Put (putWord32be)
import Data.Bytes.Serial (Serial (..))
import Data.Either (fromRight)
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.Serialize (Serialize (..))
import Data.Serialize qualified as S
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import Data.Word (Word32)
import GHC.Generics (Generic)
import Haskoin.Util.Helpers (decodeHex, encodeHex)
import Text.Read (readEither, readPrec)

-- | Fingerprint of parent
newtype Fingerprint = Fingerprint {Fingerprint -> Word32
get :: Word32}
  deriving (Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
/= :: Fingerprint -> Fingerprint -> Bool
Eq, Eq Fingerprint
Eq Fingerprint
-> (Fingerprint -> Fingerprint -> Ordering)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> (Fingerprint -> Fingerprint -> Fingerprint)
-> Ord Fingerprint
Fingerprint -> Fingerprint -> Bool
Fingerprint -> Fingerprint -> Ordering
Fingerprint -> Fingerprint -> Fingerprint
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fingerprint -> Fingerprint -> Ordering
compare :: Fingerprint -> Fingerprint -> Ordering
$c< :: Fingerprint -> Fingerprint -> Bool
< :: Fingerprint -> Fingerprint -> Bool
$c<= :: Fingerprint -> Fingerprint -> Bool
<= :: Fingerprint -> Fingerprint -> Bool
$c> :: Fingerprint -> Fingerprint -> Bool
> :: Fingerprint -> Fingerprint -> Bool
$c>= :: Fingerprint -> Fingerprint -> Bool
>= :: Fingerprint -> Fingerprint -> Bool
$cmax :: Fingerprint -> Fingerprint -> Fingerprint
max :: Fingerprint -> Fingerprint -> Fingerprint
$cmin :: Fingerprint -> Fingerprint -> Fingerprint
min :: Fingerprint -> Fingerprint -> Fingerprint
Ord, Eq Fingerprint
Eq Fingerprint
-> (Int -> Fingerprint -> Int)
-> (Fingerprint -> Int)
-> Hashable Fingerprint
Int -> Fingerprint -> Int
Fingerprint -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Fingerprint -> Int
hashWithSalt :: Int -> Fingerprint -> Int
$chash :: Fingerprint -> Int
hash :: Fingerprint -> Int
Hashable, Typeable, (forall x. Fingerprint -> Rep Fingerprint x)
-> (forall x. Rep Fingerprint x -> Fingerprint)
-> Generic Fingerprint
forall x. Rep Fingerprint x -> Fingerprint
forall x. Fingerprint -> Rep Fingerprint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Fingerprint -> Rep Fingerprint x
from :: forall x. Fingerprint -> Rep Fingerprint x
$cto :: forall x. Rep Fingerprint x -> Fingerprint
to :: forall x. Rep Fingerprint x -> Fingerprint
Generic, Fingerprint -> ()
(Fingerprint -> ()) -> NFData Fingerprint
forall a. (a -> ()) -> NFData a
$crnf :: Fingerprint -> ()
rnf :: Fingerprint -> ()
NFData)

fingerprintToText :: Fingerprint -> Text
fingerprintToText :: Fingerprint -> Text
fingerprintToText = ByteString -> Text
encodeHex (ByteString -> Text)
-> (Fingerprint -> ByteString) -> Fingerprint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> ByteString
forall a. Serialize a => a -> ByteString
S.encode

textToFingerprint :: Text -> Either String Fingerprint
textToFingerprint :: Text -> Either String Fingerprint
textToFingerprint =
  Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Fingerprint: invalid hex") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> (Text -> Maybe ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex (Text -> Either String ByteString)
-> (ByteString -> Either String Fingerprint)
-> Text
-> Either String Fingerprint
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Either String Fingerprint
forall a. Serialize a => ByteString -> Either String a
S.decode

instance Show Fingerprint where
  show :: Fingerprint -> String
show = ShowS
forall a. Show a => a -> String
show ShowS -> (Fingerprint -> String) -> Fingerprint -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Fingerprint -> Text) -> Fingerprint -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeHex (ByteString -> Text)
-> (Fingerprint -> ByteString) -> Fingerprint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> ByteString
forall a. Serialize a => a -> ByteString
S.encode

instance Read Fingerprint where
  readPrec :: ReadPrec Fingerprint
readPrec =
    ReadPrec Text
forall a. Read a => ReadPrec a
readPrec
      ReadPrec Text
-> (Text -> ReadPrec ByteString) -> ReadPrec ByteString
forall a b. ReadPrec a -> (a -> ReadPrec b) -> ReadPrec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReadPrec ByteString
-> (ByteString -> ReadPrec ByteString)
-> Maybe ByteString
-> ReadPrec ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ReadPrec ByteString
forall a. String -> ReadPrec a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Fingerprint: invalid hex") ByteString -> ReadPrec ByteString
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> ReadPrec ByteString)
-> (Text -> Maybe ByteString) -> Text -> ReadPrec ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex
      ReadPrec ByteString
-> (ByteString -> ReadPrec Fingerprint) -> ReadPrec Fingerprint
forall a b. ReadPrec a -> (a -> ReadPrec b) -> ReadPrec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReadPrec Fingerprint)
-> (Fingerprint -> ReadPrec Fingerprint)
-> Either String Fingerprint
-> ReadPrec Fingerprint
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ReadPrec Fingerprint
forall a. String -> ReadPrec a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ReadPrec Fingerprint)
-> ShowS -> String -> ReadPrec Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Fingerprint: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) Fingerprint -> ReadPrec Fingerprint
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Fingerprint -> ReadPrec Fingerprint)
-> (ByteString -> Either String Fingerprint)
-> ByteString
-> ReadPrec Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Fingerprint
forall a. Serialize a => ByteString -> Either String a
S.decode

instance IsString Fingerprint where
  fromString :: String -> Fingerprint
fromString =
    Fingerprint -> Either String Fingerprint -> Fingerprint
forall b a. b -> Either a b -> b
fromRight Fingerprint
forall {a}. a
decodeError
      (Either String Fingerprint -> Fingerprint)
-> (String -> Either String Fingerprint) -> String -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Fingerprint
forall a. Serialize a => ByteString -> Either String a
S.decode
      (ByteString -> Either String Fingerprint)
-> (String -> ByteString) -> String -> Either String Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall {a}. a
hexError
      (Maybe ByteString -> ByteString)
-> (String -> Maybe ByteString) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex
      (Text -> Maybe ByteString)
-> (String -> Text) -> String -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    where
      decodeError :: a
decodeError = String -> a
forall a. HasCallStack => String -> a
error String
"Fingerprint literal: Unable to decode"
      hexError :: a
hexError = String -> a
forall a. HasCallStack => String -> a
error String
"Fingerprint literal: Invalid hex"

instance Serial Fingerprint where
  serialize :: forall (m :: * -> *). MonadPut m => Fingerprint -> m ()
serialize = Word32 -> m ()
forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32be (Word32 -> m ()) -> (Fingerprint -> Word32) -> Fingerprint -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.get)
  deserialize :: forall (m :: * -> *). MonadGet m => m Fingerprint
deserialize = Word32 -> Fingerprint
Fingerprint (Word32 -> Fingerprint) -> m Word32 -> m Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word32
forall (m :: * -> *). MonadGet m => m Word32
getWord32be

instance Binary Fingerprint where
  put :: Fingerprint -> Put
put = Fingerprint -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Fingerprint -> m ()
serialize
  get :: Get Fingerprint
get = Get Fingerprint
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m Fingerprint
deserialize

instance Serialize Fingerprint where
  put :: Putter Fingerprint
put = Putter Fingerprint
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Fingerprint -> m ()
serialize
  get :: Get Fingerprint
get = Get Fingerprint
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m Fingerprint
deserialize

instance FromJSON Fingerprint where
  parseJSON :: Value -> Parser Fingerprint
parseJSON = String
-> (Text -> Parser Fingerprint) -> Value -> Parser Fingerprint
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Fingerprint" ((Text -> Parser Fingerprint) -> Value -> Parser Fingerprint)
-> (Text -> Parser Fingerprint) -> Value -> Parser Fingerprint
forall a b. (a -> b) -> a -> b
$ (String -> Parser Fingerprint)
-> (Fingerprint -> Parser Fingerprint)
-> Either String Fingerprint
-> Parser Fingerprint
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Fingerprint
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Fingerprint -> Parser Fingerprint
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Fingerprint -> Parser Fingerprint)
-> (Text -> Either String Fingerprint)
-> Text
-> Parser Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Fingerprint
textToFingerprint

instance ToJSON Fingerprint where
  toJSON :: Fingerprint -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Fingerprint -> Text) -> Fingerprint -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> Text
fingerprintToText
  toEncoding :: Fingerprint -> Encoding
toEncoding = Text -> Encoding
forall a. Text -> Encoding' a
text (Text -> Encoding)
-> (Fingerprint -> Text) -> Fingerprint -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> Text
fingerprintToText