Use MonadThrow for inspecting addresses

Wrt IntersectMBO#46. Easier tracing of error causes.

command-line/cardano-addresses-cli.cabal

@@ -68,9 +68,11 @@ library
     , cardano-addresses
     , cardano-crypto
     , code-page
+    , exceptions
     , extra
     , optparse-applicative
     , safe
+    , mtl >= 2.2.2 && < 2.3
     , text
   if flag(release)
     ghc-options: -Werror

command-line/lib/Command/Address/Inspect.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_HADDOCK hide #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 
 module Command.Address.Inspect
     ( Cmd (..)
@@ -13,7 +17,7 @@ import Prelude hiding
     ( mod )
 
 import Cardano.Address
-    ( unsafeMkAddress )
+    ( Address, unsafeMkAddress )
 import Cardano.Address.Style.Byron
     ( inspectByronAddress )
 import Cardano.Address.Style.Icarus
@@ -24,6 +28,10 @@ import Cardano.Address.Style.Shelley
     ( inspectShelleyAddress )
 import Control.Applicative
     ( (<|>) )
+import Control.Exception
+import Control.Monad.Error.Class
+    ( Error )
+import Data.Bifunctor
 import Options.Applicative
     ( CommandFields, Mod, command, footerDoc, helper, info, progDesc )
 import Options.Applicative.Help.Pretty
@@ -33,6 +41,7 @@ import System.IO
 import System.IO.Extra
     ( hGetBytes, progName )
 
+import qualified Data.Aeson as Json
 import qualified Data.Aeson.Encode.Pretty as Json
 import qualified Data.ByteString.Lazy.Char8 as BL8
 
@@ -64,15 +73,26 @@ mod liftCmd = command "inspect" $
   where
     parser = pure Inspect
 
+
+-- used for 'inspect'
+instance Error SomeException
+
 run :: Cmd -> IO ()
 run Inspect = do
     bytes <- hGetBytes stdin
-    case inspect (unsafeMkAddress bytes) of
-        Nothing   -> fail "Unrecognized address on standard input"
-        Just json -> BL8.hPutStrLn stdout (Json.encodePretty json)
+    case first show $ inspect (unsafeMkAddress bytes) of
+      Right json -> BL8.hPutStrLn stdout (Json.encodePretty json)
+      Left  str  -> fail str
   where
-    inspect addr =
-        inspectByronAddress       addr <|>
-        inspectIcarusAddress      addr <|>
-        inspectJormungandrAddress addr <|>
-        inspectShelleyAddress     addr
+    -- We can't use IO here, because (<|>) in IO only catches IOException type,
+    -- but MonadThrow in IO doesn't specialize to IOException.
+    --
+    -- Luckily, there's an existing instance for:
+    --   instance (Error e) => Alternative (Either e)
+    inspect :: (e ~ SomeException) => Address -> Either e Json.Value
+    inspect addr = do
+      foldr1 (<|>)
+        [inspectByronAddress       addr
+        ,inspectIcarusAddress      addr
+        ,inspectJormungandrAddress addr
+        ,inspectShelleyAddress     addr]

command-line/test/Command/Address/InspectSpec.hs

@@ -42,17 +42,18 @@ spec = describeCmd [ "address", "inspect" ] $ do
     specInspectMalformed
         "💩"
 
-    specInspectInvalid
+    specInspectInvalid "ShWrongInputSize 28"
         "79467c69a9ac66280174d09d62575ba955748b21dec3b483a9469a65"
 
     -- 28-byte long script hash
-    specInspectInvalid
+    specInspectInvalid "ShUnknownAddrType"
         "addr1y9xup4n8cyckl7zw2u33pcn9ake3xvzy3vmtw9u79rw5r8ky\
         \6pru7d6jgn4t89vy3n3d68sx5uej906uwpp83dtefn6qv4hscd"
 
 specInspectAddress :: [String] -> String -> SpecWith ()
 specInspectAddress mustHave addr = it addr $ do
-    out <- cli [ "address", "inspect" ] addr
+    (out, err) <- cli [ "address", "inspect" ] addr
+    err `shouldBe` ""
     out `shouldContain` "address_style"
     out `shouldContain` "stake_reference"
     out `shouldContain` "network_tag"
@@ -64,8 +65,8 @@ specInspectMalformed str = it ("malformed: " <> str) $ do
     out `shouldBe` ""
     err `shouldContain` "Couldn't detect input encoding?"
 
-specInspectInvalid :: String -> SpecWith ()
-specInspectInvalid str = it ("invalid: " <> str) $ do
+specInspectInvalid :: String -> String -> SpecWith ()
+specInspectInvalid errstr str = it ("invalid: " <> str) $ do
     (out, err) <- cli [ "address", "inspect" ] str
     out `shouldBe` ""
-    err `shouldContain` "Unrecognized address on standard input"
+    err `shouldContain` errstr

core/cardano-addresses.cabal

@@ -33,6 +33,7 @@ library
   exposed-modules:
       Cardano.Address
       Cardano.Address.Derivation
+      Cardano.Address.Errors
       Cardano.Address.Style.Byron
       Cardano.Address.Style.Icarus
       Cardano.Address.Style.Jormungandr

core/lib/Cardano/Address/Errors.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- |
+-- Copyright: © 2020 IOHK
+-- License: Apache-2.0
+
+module Cardano.Address.Errors
+    ( -- $overview
+
+      -- * AddrError
+      ShelleyAddrError(..)
+    , ByronAddrError(..)
+    , IcarusAddrError(..)
+    , JormungandrAddrError(..)
+  ) where
+
+import Prelude
+
+import Control.Exception
+    ( Exception )
+
+-- $overview
+--
+-- This module provides error/exception types for Addresses.
+
+data ShelleyAddrError
+    = ShUnknownAddrType
+    | ShWrongInputSize Int -- the actual size
+    | ShPtrRetrieveError String -- human readable error of underlying operation
+
+deriving instance Show ShelleyAddrError
+
+instance Exception ShelleyAddrError
+
+
+data ByronAddrError
+    = BrInvalidDerivationPath
+    | forall e . (Exception e, Show e) => BrDeserialiseError e
+
+deriving instance Show ByronAddrError
+
+instance Exception ByronAddrError
+
+
+data IcarusAddrError
+    = IcInvalidDerivationPath
+    | forall e . (Exception e, Show e) => IcDeserialiseError e
+
+deriving instance Show IcarusAddrError
+
+instance Exception IcarusAddrError
+
+
+data JormungandrAddrError
+    = JoUnknownAddrType
+    | JoWrongInputSize Int -- the actual size
+
+deriving instance Show JormungandrAddrError
+
+instance Exception JormungandrAddrError

core/lib/Cardano/Address/Style/Byron.hs

@@ -75,6 +75,8 @@ import Cardano.Address.Derivation
     , toXPub
     , xpubToBytes
     )
+import Cardano.Address.Errors
+    ( ByronAddrError (..) )
 import Cardano.Mnemonic
     ( SomeMnemonic (..), entropyToBytes, mnemonicToEntropy )
 import Codec.Binary.Encoding
@@ -83,6 +85,8 @@ import Control.DeepSeq
     ( NFData )
 import Control.Exception.Base
     ( assert )
+import Control.Monad.Catch
+    ( MonadThrow, throwM )
 import Crypto.Hash
     ( hash )
 import Crypto.Hash.Algorithms
@@ -289,16 +293,20 @@ deriveAddressPrivateKey acctK =
 -- > "DdzFFzCqrhsq3KjLtT51mESbZ4RepiHPzLqEhamexVFTJpGbCXmh7qSxnHvaL88QmtVTD1E1sjx8Z1ZNDhYmcBV38ZjDST9kYVxSkhcw"
 
 -- | Analyze an 'Address' to know whether it's a Byron address or not.
--- Returns 'Nothing' if the address isn't a byron address, or return a
+-- Throws 'ByronAddrError' if the address isn't a byron address, or return a
 -- structured JSON that gives information about an address.
 --
 -- @since 2.0.0
-inspectByronAddress :: Address -> Maybe Json.Value
+inspectByronAddress :: MonadThrow m => Address -> m Json.Value
 inspectByronAddress addr = do
-    payload <- CBOR.deserialiseCbor CBOR.decodeAddressPayload bytes
-    (root, attrs) <- CBOR.deserialiseCbor decodePayload payload
-    path  <- find ((== 1) . fst) attrs
-    ntwrk <- CBOR.deserialiseCbor CBOR.decodeProtocolMagicAttr payload
+    payload <- either (throwM . BrDeserialiseError) pure
+      $ CBOR.deserialiseCbor CBOR.decodeAddressPayload bytes
+    (root, attrs) <- either (throwM . BrDeserialiseError) pure
+      $ CBOR.deserialiseCbor decodePayload payload
+    path  <- maybe (throwM BrInvalidDerivationPath) pure
+      $ find ((== 1) . fst) attrs
+    ntwrk <- either (throwM . BrDeserialiseError) pure
+      $ CBOR.deserialiseCbor CBOR.decodeProtocolMagicAttr payload
     pure $ Json.object
         [ "address_style"   .= Json.String "Byron"
         , "stake_reference" .= Json.String "none"

core/lib/Cardano/Address/Style/Icarus.hs

@@ -73,6 +73,8 @@ import Cardano.Address.Derivation
     , generateNew
     , xprvFromBytes
     )
+import Cardano.Address.Errors
+    ( IcarusAddrError (..) )
 import Cardano.Address.Style.Byron
     ( byronMainnet, byronStaging, byronTestnet )
 import Cardano.Mnemonic
@@ -85,8 +87,8 @@ import Control.DeepSeq
     ( NFData )
 import Control.Exception.Base
     ( assert )
-import Control.Monad
-    ( guard )
+import Control.Monad.Catch
+    ( MonadThrow, throwM )
 import Crypto.Hash.Algorithms
     ( SHA256 (..), SHA512 (..) )
 import Crypto.MAC.HMAC
@@ -311,16 +313,21 @@ deriveAddressPublicKey =
 -- > "addr1vxpfffuj3zkp5g7ct6h4va89caxx9ayq2gvkyfvww48sdncxsce5t"
 --
 -- | Analyze an 'Address' to know whether it's an Icarus address or not.
--- Returns 'Nothing' if the address isn't a byron address, or return a
+-- Throws 'IcarusAddrError' if the address isn't a byron address, or return a
 -- structured JSON that gives information about an address.
 --
 -- @since 2.0.0
-inspectIcarusAddress :: Address -> Maybe Json.Value
+inspectIcarusAddress :: MonadThrow m => Address -> m Json.Value
 inspectIcarusAddress addr = do
-    payload <- CBOR.deserialiseCbor CBOR.decodeAddressPayload bytes
-    (root, attrs) <- CBOR.deserialiseCbor decodePayload payload
-    guard $ 1 `notElem` (fst <$> attrs)
-    ntwrk <- CBOR.deserialiseCbor CBOR.decodeProtocolMagicAttr payload
+    payload <- either (throwM . IcDeserialiseError) pure
+      $ CBOR.deserialiseCbor CBOR.decodeAddressPayload bytes
+    (root, attrs) <- either (throwM . IcDeserialiseError) pure
+      $ CBOR.deserialiseCbor decodePayload payload
+    _  <- if (notElem 1 . fmap fst) attrs
+             then pure ()
+             else throwM IcInvalidDerivationPath
+    ntwrk <- either (throwM . IcDeserialiseError) pure
+      $ CBOR.deserialiseCbor CBOR.decodeProtocolMagicAttr payload
     pure $ Json.object
         [ "address_style"   .= Json.String "Icarus"
         , "stake_reference" .= Json.String "none"

core/lib/Cardano/Address/Style/Jormungandr.hs

@@ -76,6 +76,8 @@ import Cardano.Address.Derivation
     , generateNew
     , xpubPublicKey
     )
+import Cardano.Address.Errors
+    ( JormungandrAddrError (..) )
 import Cardano.Mnemonic
     ( SomeMnemonic, someMnemonicToBytes )
 import Codec.Binary.Encoding
@@ -86,6 +88,8 @@ import Control.DeepSeq
     ( NFData )
 import Control.Exception.Base
     ( assert )
+import Control.Monad.Catch
+    ( MonadThrow, throwM )
 import Data.Aeson
     ( (.=) )
 import Data.Binary.Put
@@ -364,13 +368,13 @@ instance Internal.DelegationAddress Jormungandr where
 
 -- | Analyze an 'Address' to know whether it's a Jormungandr address or not.
 --
--- Returns 'Nothing' if it's not a valid Shelley address, or a ready-to-print
+-- Throws 'JormungandrAddrError' if it's not a valid Shelley address, or a ready-to-print
 -- string giving details about the 'Jormungandr'.
 --
 -- @since 2.0.0
-inspectJormungandrAddress :: Address -> Maybe Json.Value
+inspectJormungandrAddress :: MonadThrow m => Address -> m Json.Value
 inspectJormungandrAddress addr
-    | BS.length bytes < 1 + publicKeySize = Nothing
+    | BS.length bytes < 1 + publicKeySize = throwM (JoWrongInputSize (BS.length bytes))
     | otherwise =
         let
             (fstByte, rest) = first BS.head $ BS.splitAt 1 bytes
@@ -380,15 +384,15 @@ inspectJormungandrAddress addr
         in
             case addrType of
                 0x03 | BS.length rest == size ->
-                    Just $ Json.object
+                    pure $ Json.object
                     [ "address_style"   .= Json.String "Jormungandr"
                     , "address_type"    .= Json.String "single"
                     , "stake_reference" .= Json.String "none"
                     , "spending_key"    .= base16 (BS.take size rest)
                     , "network_tag"     .= network
                     ]
                 0x04 | BS.length rest == 2 * size ->
-                    Just $ Json.object
+                    pure $ Json.object
                     [ "address_style"   .= Json.String "Jormungandr"
                     , "address_type"    .= Json.String "group"
                     , "stake_reference" .= Json.String "by value"
@@ -397,23 +401,22 @@ inspectJormungandrAddress addr
                     , "network_tag"     .= network
                     ]
                 0x05 | BS.length rest == size ->
-                    Just $ Json.object
+                    pure $ Json.object
                     [ "address_style"   .= Json.String "Jormungandr"
                     , "address_type"    .= Json.String "account"
                     , "stake_reference" .= Json.String "none"
                     , "account_key"     .= base16 (BS.take size rest)
                     , "network_tag"     .= network
                     ]
                 0x06 | BS.length rest == size ->
-                    Just $ Json.object
+                    pure $ Json.object
                     [ "address_style"   .= Json.String "Jormungandr"
                     , "address_type"    .= Json.String "multisig"
                     , "stake_reference" .= Json.String "none"
                     , "merkle_root"     .= base16 (BS.take size rest)
                     , "network_tag"     .= network
                     ]
-                _ ->
-                    Nothing
+                _ -> throwM JoUnknownAddrType
   where
     bytes = unAddress addr
     base16 = T.unpack . T.decodeUtf8 . encode EBase16