{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- XML Signature Syntax and Processing
--
-- <http://www.w3.org/TR/2008/REC-xmldsig-core-20080610/> (selected portions)
module SAML2.XML.Signature
  ( module SAML2.XML.Signature.Types
  , generateReference
  , SigningKey(..)
  , PublicKeys(..)
  , SignatureError (..)
  , signingKeySignatureAlgorithm
  , signBase64
  , verifyBase64
  , generateSignature
  , verifySignatureUnenvelopedSigs
  , applyCanonicalization
  , applyTransforms
  ) where

import GHC.Stack
import Control.Applicative ((<|>))
import Control.Exception (SomeException, handle)
import Control.Monad ((<=<))
import Control.Monad.Except
import Crypto.Number.Serialize (i2ospOf_, os2ip)
import Crypto.Hash (hashlazy, SHA1(..), SHA256(..), SHA512(..), RIPEMD160(..))
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.RSA.Types as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List.NonEmpty as NonEmpty
import Data.Either (isRight)
import Network.URI (URI(..))
import qualified Text.XML.HXT.Core as HXT
import qualified Text.XML.HXT.DOM.ShowXml as DOM
import qualified Text.XML.HXT.DOM.XmlNode as DOM
import qualified Text.XML.HXT.DOM.QualifiedName as DOM

import SAML2.XML
import SAML2.XML.Canonical
import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP
import SAML2.XML.Signature.Types

isDSElem :: HXT.ArrowXml a => String -> a HXT.XmlTree HXT.XmlTree
isDSElem :: forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
isDSElem String
n = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXT.isElem a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> QName -> a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => QName -> a XmlTree XmlTree
HXT.hasQName (Namespace -> String -> QName
mkNName Namespace
ns String
n)

getID :: HXT.ArrowXml a => String -> a HXT.XmlTree HXT.XmlTree
getID :: forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
getID = a XmlTree XmlTree -> a XmlTree XmlTree
forall (t :: * -> *) b c. Tree t => a (t b) c -> a (t b) c
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
HXT.deep (a XmlTree XmlTree -> a XmlTree XmlTree)
-> (String -> a XmlTree XmlTree) -> String -> a XmlTree XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String -> Bool) -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> (String -> Bool) -> a XmlTree XmlTree
HXT.hasAttrValue String
"ID" ((String -> Bool) -> a XmlTree XmlTree)
-> (String -> String -> Bool) -> String -> a XmlTree XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==)

applyCanonicalization :: CanonicalizationMethod -> Maybe String -> HXT.XmlTree -> IO BS.ByteString
applyCanonicalization :: CanonicalizationMethod -> Maybe String -> XmlTree -> IO ByteString
applyCanonicalization (CanonicalizationMethod (Identified CanonicalizationAlgorithm
a) Maybe InclusiveNamespaces
ins []) Maybe String
x XmlTree
y = CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces
-> Maybe String
-> XmlTree
-> IO ByteString
canonicalize CanonicalizationAlgorithm
a Maybe InclusiveNamespaces
ins Maybe String
x XmlTree
y
applyCanonicalization CanonicalizationMethod
m Maybe String
_ XmlTree
_ = String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"applyCanonicalization: unsupported " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CanonicalizationMethod -> String
forall a. Show a => a -> String
show CanonicalizationMethod
m

applyTransformsBytes :: [Transform] -> BSL.ByteString -> IO BSL.ByteString
applyTransformsBytes :: [Transform] -> ByteString -> IO ByteString
applyTransformsBytes [] ByteString
v = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
v
applyTransformsBytes (Transform
t : [Transform]
_) ByteString
_ = String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"applyTransforms: unsupported Signature " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Transform -> String
forall a. Show a => a -> String
show Transform
t)

applyTransformsXML :: [Transform] -> HXT.XmlTree -> IO BSL.ByteString
applyTransformsXML :: [Transform] -> XmlTree -> IO ByteString
applyTransformsXML (Transform (Identified (TransformCanonicalization CanonicalizationAlgorithm
a)) Maybe InclusiveNamespaces
ins [TransformElement]
x : [Transform]
tl) =
  [Transform] -> ByteString -> IO ByteString
applyTransformsBytes [Transform]
tl (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict
  (ByteString -> IO ByteString)
-> (XmlTree -> IO ByteString) -> XmlTree -> IO ByteString
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< CanonicalizationMethod -> Maybe String -> XmlTree -> IO ByteString
applyCanonicalization (Identified URI CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces -> [XmlTree] -> CanonicalizationMethod
CanonicalizationMethod (CanonicalizationAlgorithm
-> Identified URI CanonicalizationAlgorithm
forall b a. a -> Identified b a
Identified CanonicalizationAlgorithm
a) Maybe InclusiveNamespaces
ins ((TransformElement -> XmlTree) -> [TransformElement] -> [XmlTree]
forall a b. (a -> b) -> [a] -> [b]
map (PU TransformElement -> TransformElement -> XmlTree
forall a. PU a -> a -> XmlTree
XP.pickleDoc PU TransformElement
forall a. XmlPickler a => PU a
XP.xpickle) [TransformElement]
x)) Maybe String
forall a. Maybe a
Nothing
applyTransformsXML (Transform (Identified TransformAlgorithm
TransformEnvelopedSignature) Maybe InclusiveNamespaces
Nothing [] : [Transform]
tl) =
  -- XXX assumes "this" signature in top-level
  [Transform] -> XmlTree -> IO ByteString
applyTransformsXML [Transform]
tl
  (XmlTree -> IO ByteString)
-> (XmlTree -> XmlTree) -> XmlTree -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head ([XmlTree] -> XmlTree)
-> (XmlTree -> [XmlTree]) -> XmlTree -> XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
HXT.processChildren (LA XmlTree XmlTree -> LA XmlTree XmlTree)
-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
HXT.processChildren
    (LA XmlTree XmlTree -> LA XmlTree XmlTree)
-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ LA XmlTree XmlTree -> LA XmlTree XmlTree
forall b c. LA b c -> LA b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
HXT.neg (String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
isDSElem String
"Signature"))
applyTransformsXML [Transform]
tl = [Transform] -> ByteString -> IO ByteString
applyTransformsBytes [Transform]
tl (ByteString -> IO ByteString)
-> (XmlTree -> ByteString) -> XmlTree -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> ByteString
DOM.xshowBlob ([XmlTree] -> ByteString)
-> (XmlTree -> [XmlTree]) -> XmlTree -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> [XmlTree]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return

applyTransforms :: Maybe Transforms -> HXT.XmlTree -> IO BSL.ByteString
applyTransforms :: Maybe Transforms -> XmlTree -> IO ByteString
applyTransforms = [Transform] -> XmlTree -> IO ByteString
applyTransformsXML ([Transform] -> XmlTree -> IO ByteString)
-> (Maybe Transforms -> [Transform])
-> Maybe Transforms
-> XmlTree
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Transform]
-> (Transforms -> [Transform]) -> Maybe Transforms -> [Transform]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (NonEmpty Transform -> [Transform]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty Transform -> [Transform])
-> (Transforms -> NonEmpty Transform) -> Transforms -> [Transform]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transforms -> NonEmpty Transform
transforms)

applyDigest :: DigestMethod -> BSL.ByteString -> BS.ByteString
applyDigest :: DigestMethod -> ByteString -> ByteString
applyDigest (DigestMethod (Identified DigestAlgorithm
DigestSHA1) []) = Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA1 -> ByteString)
-> (ByteString -> Digest SHA1) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy @SHA1
applyDigest (DigestMethod (Identified DigestAlgorithm
DigestSHA256) []) = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA256 -> ByteString)
-> (ByteString -> Digest SHA256) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy @SHA256
applyDigest (DigestMethod (Identified DigestAlgorithm
DigestSHA512) []) = Digest SHA512 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA512 -> ByteString)
-> (ByteString -> Digest SHA512) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy @SHA512
applyDigest (DigestMethod (Identified DigestAlgorithm
DigestRIPEMD160) []) = Digest RIPEMD160 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest RIPEMD160 -> ByteString)
-> (ByteString -> Digest RIPEMD160) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy @RIPEMD160
applyDigest DigestMethod
d = String -> ByteString -> ByteString
forall a. HasCallStack => String -> a
error (String -> ByteString -> ByteString)
-> String -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"unsupported " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DigestMethod -> String
forall a. Show a => a -> String
show DigestMethod
d

generateReference :: Reference -> HXT.XmlTree -> IO Reference
generateReference :: Reference -> XmlTree -> IO Reference
generateReference Reference
r XmlTree
x = do
  ByteString
t <- Maybe Transforms -> XmlTree -> IO ByteString
applyTransforms (Reference -> Maybe Transforms
referenceTransforms Reference
r) XmlTree
x
  let d :: ByteString
d = DigestMethod -> ByteString -> ByteString
applyDigest (Reference -> DigestMethod
referenceDigestMethod Reference
r) ByteString
t
  Reference -> IO Reference
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Reference
r
    { referenceDigestValue = d }

-- | Re-compute the digest (after transforms) of a 'Reference'd subtree of an xml document and
-- compare it against the one given in the 'Reference'.  If it matches, return the xml ID;
-- otherwise, return an error string.
verifyReference :: HasCallStack => Reference -> HXT.XmlTree -> IO (Either String String)
verifyReference :: HasCallStack => Reference -> XmlTree -> IO (Either String String)
verifyReference Reference
r XmlTree
doc = case Reference -> Maybe URI
referenceURI Reference
r of
  Just URI{ uriScheme :: URI -> String
uriScheme = String
"", uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Maybe URIAuth
Nothing, uriPath :: URI -> String
uriPath = String
"", uriQuery :: URI -> String
uriQuery = String
"", uriFragment :: URI -> String
uriFragment = Char
'#':String
xid } ->
    case LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
getID String
xid) XmlTree
doc of
      x :: [XmlTree]
x@[XmlTree
_] -> do
        ByteString
t :: BSL.ByteString <- Maybe Transforms -> XmlTree -> IO ByteString
applyTransforms (Reference -> Maybe Transforms
referenceTransforms Reference
r) (XmlTree -> IO ByteString) -> XmlTree -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [XmlTree] -> [XmlTree] -> XmlTree
DOM.mkRoot [] [XmlTree]
x
        let have :: ByteString
have = DigestMethod -> ByteString -> ByteString
applyDigest (Reference -> DigestMethod
referenceDigestMethod Reference
r) ByteString
t
            want :: ByteString
want = Reference -> ByteString
referenceDigestValue Reference
r
        Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ if ByteString
have ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
want
          then String -> Either String String
forall a b. b -> Either a b
Right String
xid
          else String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"#" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": digest mismatch"
      [XmlTree]
bad -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
"#" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": has " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([XmlTree] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XmlTree]
bad) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" matches, should have 1."
  Maybe URI
bad -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. a -> Either a b
Left (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
"unexpected referenceURI: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe URI -> String
forall a. Show a => a -> String
show Maybe URI
bad

data SigningKey
  = SigningKeyDSA DSA.KeyPair
  | SigningKeyRSA RSA.KeyPair
  deriving (SigningKey -> SigningKey -> Bool
(SigningKey -> SigningKey -> Bool)
-> (SigningKey -> SigningKey -> Bool) -> Eq SigningKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SigningKey -> SigningKey -> Bool
== :: SigningKey -> SigningKey -> Bool
$c/= :: SigningKey -> SigningKey -> Bool
/= :: SigningKey -> SigningKey -> Bool
Eq, Int -> SigningKey -> String -> String
[SigningKey] -> String -> String
SigningKey -> String
(Int -> SigningKey -> String -> String)
-> (SigningKey -> String)
-> ([SigningKey] -> String -> String)
-> Show SigningKey
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SigningKey -> String -> String
showsPrec :: Int -> SigningKey -> String -> String
$cshow :: SigningKey -> String
show :: SigningKey -> String
$cshowList :: [SigningKey] -> String -> String
showList :: [SigningKey] -> String -> String
Show)

data PublicKeys = PublicKeys
  { PublicKeys -> Maybe PublicKey
publicKeyDSA :: Maybe DSA.PublicKey
  , PublicKeys -> Maybe PublicKey
publicKeyRSA :: Maybe RSA.PublicKey
  } deriving (PublicKeys -> PublicKeys -> Bool
(PublicKeys -> PublicKeys -> Bool)
-> (PublicKeys -> PublicKeys -> Bool) -> Eq PublicKeys
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublicKeys -> PublicKeys -> Bool
== :: PublicKeys -> PublicKeys -> Bool
$c/= :: PublicKeys -> PublicKeys -> Bool
/= :: PublicKeys -> PublicKeys -> Bool
Eq, Int -> PublicKeys -> String -> String
[PublicKeys] -> String -> String
PublicKeys -> String
(Int -> PublicKeys -> String -> String)
-> (PublicKeys -> String)
-> ([PublicKeys] -> String -> String)
-> Show PublicKeys
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PublicKeys -> String -> String
showsPrec :: Int -> PublicKeys -> String -> String
$cshow :: PublicKeys -> String
show :: PublicKeys -> String
$cshowList :: [PublicKeys] -> String -> String
showList :: [PublicKeys] -> String -> String
Show)

#if MIN_VERSION_base(4,11,0)
instance Semigroup PublicKeys where
  PublicKeys Maybe PublicKey
dsa1 Maybe PublicKey
rsa1 <> :: PublicKeys -> PublicKeys -> PublicKeys
<> PublicKeys Maybe PublicKey
dsa2 Maybe PublicKey
rsa2 =
    Maybe PublicKey -> Maybe PublicKey -> PublicKeys
PublicKeys (Maybe PublicKey
dsa1 Maybe PublicKey -> Maybe PublicKey -> Maybe PublicKey
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PublicKey
dsa2) (Maybe PublicKey
rsa1 Maybe PublicKey -> Maybe PublicKey -> Maybe PublicKey
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PublicKey
rsa2)
#endif
instance Monoid PublicKeys where
  mempty :: PublicKeys
mempty = Maybe PublicKey -> Maybe PublicKey -> PublicKeys
PublicKeys Maybe PublicKey
forall a. Maybe a
Nothing Maybe PublicKey
forall a. Maybe a
Nothing
  mappend :: PublicKeys -> PublicKeys -> PublicKeys
mappend = PublicKeys -> PublicKeys -> PublicKeys
forall a. Semigroup a => a -> a -> a
(<>)

signingKeySignatureAlgorithm :: SigningKey -> SignatureAlgorithm
signingKeySignatureAlgorithm :: SigningKey -> SignatureAlgorithm
signingKeySignatureAlgorithm (SigningKeyDSA KeyPair
_) = SignatureAlgorithm
SignatureDSA_SHA1
signingKeySignatureAlgorithm (SigningKeyRSA KeyPair
_) = SignatureAlgorithm
SignatureRSA_SHA1

signingKeyValue :: SigningKey -> KeyValue
signingKeyValue :: SigningKey -> KeyValue
signingKeyValue (SigningKeyDSA (KeyPair -> PublicKey
DSA.toPublicKey -> DSA.PublicKey Params
p PublicNumber
y)) = DSAKeyValue
  { dsaKeyValuePQ :: Maybe (PublicNumber, PublicNumber)
dsaKeyValuePQ = (PublicNumber, PublicNumber) -> Maybe (PublicNumber, PublicNumber)
forall a. a -> Maybe a
Just (Params -> PublicNumber
DSA.params_p Params
p, Params -> PublicNumber
DSA.params_q Params
p)
  , dsaKeyValueG :: Maybe PublicNumber
dsaKeyValueG = PublicNumber -> Maybe PublicNumber
forall a. a -> Maybe a
Just (Params -> PublicNumber
DSA.params_g Params
p)
  , dsaKeyValueY :: PublicNumber
dsaKeyValueY = PublicNumber
y
  , dsaKeyValueJ :: Maybe PublicNumber
dsaKeyValueJ = Maybe PublicNumber
forall a. Maybe a
Nothing
  , dsaKeyValueSeedPgenCounter :: Maybe (PublicNumber, PublicNumber)
dsaKeyValueSeedPgenCounter = Maybe (PublicNumber, PublicNumber)
forall a. Maybe a
Nothing
  }
signingKeyValue (SigningKeyRSA (KeyPair -> PublicKey
RSA.toPublicKey -> RSA.PublicKey Int
_ PublicNumber
n PublicNumber
e)) = RSAKeyValue
  { rsaKeyValueModulus :: PublicNumber
rsaKeyValueModulus = PublicNumber
n
  , rsaKeyValueExponent :: PublicNumber
rsaKeyValueExponent = PublicNumber
e
  }

signBytes :: SigningKey -> BS.ByteString -> IO BS.ByteString
signBytes :: SigningKey -> ByteString -> IO ByteString
signBytes (SigningKeyDSA KeyPair
k) ByteString
b = do
  Signature
s <- PrivateKey -> SHA1 -> ByteString -> IO Signature
forall msg hash (m :: * -> *).
(ByteArrayAccess msg, HashAlgorithm hash, MonadRandom m) =>
PrivateKey -> hash -> msg -> m Signature
DSA.sign (KeyPair -> PrivateKey
DSA.toPrivateKey KeyPair
k) SHA1
SHA1 ByteString
b
  ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> PublicNumber -> ByteString
forall ba. ByteArray ba => Int -> PublicNumber -> ba
i2ospOf_ Int
20 (Signature -> PublicNumber
DSA.sign_r Signature
s) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> PublicNumber -> ByteString
forall ba. ByteArray ba => Int -> PublicNumber -> ba
i2ospOf_ Int
20 (Signature -> PublicNumber
DSA.sign_s Signature
s)
signBytes (SigningKeyRSA KeyPair
k) ByteString
b =
  (Error -> IO ByteString)
-> (ByteString -> IO ByteString)
-> Either Error ByteString
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString)
-> (Error -> String) -> Error -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show) ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error ByteString -> IO ByteString)
-> IO (Either Error ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe SHA1
-> PrivateKey -> ByteString -> IO (Either Error ByteString)
forall hashAlg (m :: * -> *).
(HashAlgorithmASN1 hashAlg, MonadRandom m) =>
Maybe hashAlg
-> PrivateKey -> ByteString -> m (Either Error ByteString)
RSA.signSafer (SHA1 -> Maybe SHA1
forall a. a -> Maybe a
Just SHA1
SHA1) (KeyPair -> PrivateKey
RSA.toPrivateKey KeyPair
k) ByteString
b

-- | indicate verification result; return 'Nothing' if no matching key/alg pair is found
verifyBytes :: PublicKeys -> IdentifiedURI SignatureAlgorithm -> BS.ByteString -> BS.ByteString -> Maybe Bool
verifyBytes :: PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBytes PublicKeys{ publicKeyDSA :: PublicKeys -> Maybe PublicKey
publicKeyDSA = Just PublicKey
k } (Identified SignatureAlgorithm
SignatureDSA_SHA1) ByteString
sig ByteString
m = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
  ByteString -> Int
BS.length ByteString
sig Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40 Bool -> Bool -> Bool
&&
  SHA1 -> PublicKey -> Signature -> ByteString -> Bool
forall msg hash.
(ByteArrayAccess msg, HashAlgorithm hash) =>
hash -> PublicKey -> Signature -> msg -> Bool
DSA.verify SHA1
SHA1 PublicKey
k DSA.Signature{ sign_r :: PublicNumber
DSA.sign_r = ByteString -> PublicNumber
forall ba. ByteArrayAccess ba => ba -> PublicNumber
os2ip ByteString
r, sign_s :: PublicNumber
DSA.sign_s = ByteString -> PublicNumber
forall ba. ByteArrayAccess ba => ba -> PublicNumber
os2ip ByteString
s } ByteString
m
  where (ByteString
r, ByteString
s) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
20 ByteString
sig
verifyBytes PublicKeys{ publicKeyRSA :: PublicKeys -> Maybe PublicKey
publicKeyRSA = Just PublicKey
k } (Identified SignatureAlgorithm
SignatureRSA_SHA1) ByteString
sig ByteString
m = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
  Maybe SHA1 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
RSA.verify (SHA1 -> Maybe SHA1
forall a. a -> Maybe a
Just SHA1
SHA1) PublicKey
k ByteString
m ByteString
sig
verifyBytes PublicKeys{ publicKeyRSA :: PublicKeys -> Maybe PublicKey
publicKeyRSA = Just PublicKey
k } (Identified SignatureAlgorithm
SignatureRSA_SHA256) ByteString
sig ByteString
m = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
  Maybe SHA256 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
RSA.verify (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
SHA256) PublicKey
k ByteString
m ByteString
sig
verifyBytes PublicKeys
_ IdentifiedURI SignatureAlgorithm
_ ByteString
_ ByteString
_ = Maybe Bool
forall a. Maybe a
Nothing

signBase64 :: SigningKey -> BS.ByteString -> IO BS.ByteString
signBase64 :: SigningKey -> ByteString -> IO ByteString
signBase64 SigningKey
sk = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
Base64.encode (IO ByteString -> IO ByteString)
-> (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey -> ByteString -> IO ByteString
signBytes SigningKey
sk

verifyBase64 :: PublicKeys -> IdentifiedURI SignatureAlgorithm -> BS.ByteString -> BS.ByteString -> Maybe Bool
verifyBase64 :: PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBase64 PublicKeys
pk IdentifiedURI SignatureAlgorithm
alg ByteString
sig ByteString
m = (String -> Maybe Bool)
-> (ByteString -> Maybe Bool)
-> Either String ByteString
-> Maybe Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Bool -> String -> Maybe Bool
forall a b. a -> b -> a
const (Maybe Bool -> String -> Maybe Bool)
-> Maybe Bool -> String -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (\ByteString
s -> PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBytes PublicKeys
pk IdentifiedURI SignatureAlgorithm
alg ByteString
s ByteString
m) (Either String ByteString -> Maybe Bool)
-> Either String ByteString -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
Base64.decode ByteString
sig

generateSignature :: SigningKey -> SignedInfo -> IO Signature
generateSignature :: SigningKey -> SignedInfo -> IO Signature
generateSignature SigningKey
sk SignedInfo
si = do
  -- XXX: samlToDoc may not match later
  ByteString
six <- CanonicalizationMethod -> Maybe String -> XmlTree -> IO ByteString
applyCanonicalization (SignedInfo -> CanonicalizationMethod
signedInfoCanonicalizationMethod SignedInfo
si) Maybe String
forall a. Maybe a
Nothing (XmlTree -> IO ByteString) -> XmlTree -> IO ByteString
forall a b. (a -> b) -> a -> b
$ SignedInfo -> XmlTree
forall a. XmlPickler a => a -> XmlTree
samlToDoc SignedInfo
si
  ByteString
sv <- SigningKey -> ByteString -> IO ByteString
signBytes SigningKey
sk ByteString
six
  Signature -> IO Signature
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Signature
    { signatureId :: Maybe String
signatureId = Maybe String
forall a. Maybe a
Nothing
    , signatureSignedInfo :: SignedInfo
signatureSignedInfo = SignedInfo
si
    , signatureSignatureValue :: SignatureValue
signatureSignatureValue = Maybe String -> ByteString -> SignatureValue
SignatureValue Maybe String
forall a. Maybe a
Nothing ByteString
sv
    , signatureKeyInfo :: Maybe KeyInfo
signatureKeyInfo = KeyInfo -> Maybe KeyInfo
forall a. a -> Maybe a
Just (KeyInfo -> Maybe KeyInfo) -> KeyInfo -> Maybe KeyInfo
forall a b. (a -> b) -> a -> b
$ Maybe String -> List1 KeyInfoElement -> KeyInfo
KeyInfo Maybe String
forall a. Maybe a
Nothing (List1 KeyInfoElement -> KeyInfo)
-> List1 KeyInfoElement -> KeyInfo
forall a b. (a -> b) -> a -> b
$ KeyValue -> KeyInfoElement
KeyInfoKeyValue (SigningKey -> KeyValue
signingKeyValue SigningKey
sk) KeyInfoElement -> [KeyInfoElement] -> List1 KeyInfoElement
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| []
    , signatureObject :: [Object]
signatureObject = []
    }

-- deprecated!  use 'verifySignature' instead.  this is left here so it can be used for testing only.
-- Exception in IO:  something is syntactically wrong with the input
-- Nothing:          no matching key/alg pairs found
-- Just False:       signature verification failed || dangling refs || explicit ref is not among the signed ones
-- Just True:        everything is ok!
verifySignature :: PublicKeys -> String -> HXT.XmlTree -> IO (Maybe Bool)
verifySignature :: PublicKeys -> String -> XmlTree -> IO (Maybe Bool)
verifySignature PublicKeys
pks String
xid XmlTree
doc = do
  let namespaces :: NsEnv
namespaces = AssocList String String -> NsEnv
DOM.toNsEnv (AssocList String String -> NsEnv)
-> AssocList String String -> NsEnv
forall a b. (a -> b) -> a -> b
$ LA XmlTree (String, String) -> XmlTree -> AssocList String String
forall a b. LA a b -> a -> [b]
HXT.runLA LA XmlTree (String, String)
HXT.collectNamespaceDecl XmlTree
doc
  XmlTree
x <- case LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
getID String
xid LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> NsEnv -> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => NsEnv -> a XmlTree XmlTree
HXT.attachNsEnv NsEnv
namespaces) XmlTree
doc of
    [XmlTree
x] -> XmlTree -> IO XmlTree
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return XmlTree
x
    [XmlTree]
_ -> String -> IO XmlTree
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"verifySignature: element not found"
  XmlTree
sx <- case String -> XmlTree -> [XmlTree]
child String
"Signature" XmlTree
x of
    [XmlTree
sx] -> XmlTree -> IO XmlTree
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return XmlTree
sx
    [XmlTree]
_ -> String -> IO XmlTree
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"verifySignature: Signature not found"
  s :: Signature
s@Signature{ signatureSignedInfo :: Signature -> SignedInfo
signatureSignedInfo = SignedInfo
si } <- (String -> IO Signature)
-> (Signature -> IO Signature)
-> Either String Signature
-> IO Signature
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Signature
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Signature -> IO Signature
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Signature -> IO Signature)
-> Either String Signature -> IO Signature
forall a b. (a -> b) -> a -> b
$ XmlTree -> Either String Signature
forall a. XmlPickler a => XmlTree -> Either String a
docToSAML XmlTree
sx
  ByteString
six <- CanonicalizationMethod -> Maybe String -> XmlTree -> IO ByteString
applyCanonicalization (SignedInfo -> CanonicalizationMethod
signedInfoCanonicalizationMethod SignedInfo
si) (String -> Maybe String
forall a. a -> Maybe a
Just String
xpath) (XmlTree -> IO ByteString) -> XmlTree -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [XmlTree] -> [XmlTree] -> XmlTree
DOM.mkRoot [] [XmlTree
x]
  NonEmpty (Either String String)
rl <- (Reference -> IO (Either String String))
-> NonEmpty Reference -> IO (NonEmpty (Either String String))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (HasCallStack => Reference -> XmlTree -> IO (Either String String)
Reference -> XmlTree -> IO (Either String String)
`verifyReference` XmlTree
x) (SignedInfo -> NonEmpty Reference
signedInfoReference SignedInfo
si)
  let verified :: Maybe Bool
      verified :: Maybe Bool
verified = PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBytes PublicKeys
pks (SignatureMethod -> IdentifiedURI SignatureAlgorithm
signatureMethodAlgorithm (SignatureMethod -> IdentifiedURI SignatureAlgorithm)
-> SignatureMethod -> IdentifiedURI SignatureAlgorithm
forall a b. (a -> b) -> a -> b
$ SignedInfo -> SignatureMethod
signedInfoSignatureMethod SignedInfo
si) (SignatureValue -> ByteString
signatureValue (SignatureValue -> ByteString) -> SignatureValue -> ByteString
forall a b. (a -> b) -> a -> b
$ Signature -> SignatureValue
signatureSignatureValue Signature
s) ByteString
six
      valid :: Bool
      valid :: Bool
valid = Either String String -> NonEmpty (Either String String) -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> Either String String
forall a b. b -> Either a b
Right String
xid) NonEmpty (Either String String)
rl Bool -> Bool -> Bool
&& (Either String String -> Bool)
-> NonEmpty (Either String String) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either String String -> Bool
forall a b. Either a b -> Bool
isRight NonEmpty (Either String String)
rl
  Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ (Bool
valid Bool -> Bool -> Bool
&&) (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
verified
  where
  child :: String -> XmlTree -> [XmlTree]
child String
n = LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> XmlTree -> [XmlTree])
-> LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
HXT.getChildren LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> String -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
isDSElem String
n LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> LA XmlTree (String, String) -> LA XmlTree XmlTree
HXT.cleanupNamespaces LA XmlTree (String, String)
HXT.collectPrefixUriPairs
  xpathsel :: String -> String
xpathsel String
t = String
"/*[local-name()='" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' and namespace-uri()='" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Namespace -> String
namespaceURIString Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"']"
  xpathbase :: String
xpathbase = String
"/*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
xpathsel String
"Signature" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
xpathsel String
"SignedInfo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"//"
  xpath :: String
xpath = String
xpathbase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xpathbase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@* | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xpathbase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"namespace::*"


-- | It turns out sometimes we don't get envelopped signatures, but signatures that are
-- located outside the signed sub-tree.  Since 'verifySiganture' doesn't support this case, if
-- you encounter it you should fall back to 'verifySignatureUnenvelopedSigs'.
verifySignatureUnenvelopedSigs :: PublicKeys -> String -> HXT.XmlTree -> IO (Either SignatureError ())
verifySignatureUnenvelopedSigs :: PublicKeys -> String -> XmlTree -> IO (Either SignatureError ())
verifySignatureUnenvelopedSigs PublicKeys
pks String
xid XmlTree
doc = IO (Either SignatureError ()) -> IO (Either SignatureError ())
catchAll (IO (Either SignatureError ()) -> IO (Either SignatureError ()))
-> IO (Either SignatureError ()) -> IO (Either SignatureError ())
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Either SignatureError ()
warpResult (Maybe Bool -> Either SignatureError ())
-> IO (Maybe Bool) -> IO (Either SignatureError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PublicKeys -> String -> XmlTree -> IO (Maybe Bool)
verifySignature PublicKeys
pks String
xid XmlTree
doc
  where
    catchAll :: IO (Either SignatureError ()) -> IO (Either SignatureError ())
    catchAll :: IO (Either SignatureError ()) -> IO (Either SignatureError ())
catchAll = (SomeException -> IO (Either SignatureError ()))
-> IO (Either SignatureError ()) -> IO (Either SignatureError ())
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO (Either SignatureError ()))
 -> IO (Either SignatureError ()) -> IO (Either SignatureError ()))
-> (SomeException -> IO (Either SignatureError ()))
-> IO (Either SignatureError ())
-> IO (Either SignatureError ())
forall a b. (a -> b) -> a -> b
$ Either SignatureError () -> IO (Either SignatureError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SignatureError () -> IO (Either SignatureError ()))
-> (SomeException -> Either SignatureError ())
-> SomeException
-> IO (Either SignatureError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignatureError -> Either SignatureError ()
forall a b. a -> Either a b
Left (SignatureError -> Either SignatureError ())
-> (SomeException -> SignatureError)
-> SomeException
-> Either SignatureError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String (Maybe Bool) -> SignatureError
SignatureVerificationLegacyFailure (Either String (Maybe Bool) -> SignatureError)
-> (SomeException -> Either String (Maybe Bool))
-> SomeException
-> SignatureError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (Maybe Bool)
forall a b. a -> Either a b
Left (String -> Either String (Maybe Bool))
-> (SomeException -> String)
-> SomeException
-> Either String (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Show a => a -> String
show @SomeException)

    warpResult :: Maybe Bool -> Either SignatureError ()
warpResult (Just Bool
True) = () -> Either SignatureError ()
forall a b. b -> Either a b
Right ()
    warpResult Maybe Bool
bad = SignatureError -> Either SignatureError ()
forall a b. a -> Either a b
Left (Either String (Maybe Bool) -> SignatureError
SignatureVerificationLegacyFailure (Maybe Bool -> Either String (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
bad))

data SignatureError =
    SignedElementNotFound
  | SignatureNotFoundOrEmpty
  | SignatureParseError String
  | SignatureCanonicalizationError String
  | SignatureVerifyReferenceError String
  | SignatureVerifyBadReferences String
  | SignatureVerifyInputNotReferenced String
  | SignatureVerificationCryptoUnsupported String
  | SignatureVerificationCryptoFailed String
  | SignatureVerificationLegacyFailure (Either String (Maybe Bool))
  deriving (SignatureError -> SignatureError -> Bool
(SignatureError -> SignatureError -> Bool)
-> (SignatureError -> SignatureError -> Bool) -> Eq SignatureError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignatureError -> SignatureError -> Bool
== :: SignatureError -> SignatureError -> Bool
$c/= :: SignatureError -> SignatureError -> Bool
/= :: SignatureError -> SignatureError -> Bool
Eq, Int -> SignatureError -> String -> String
[SignatureError] -> String -> String
SignatureError -> String
(Int -> SignatureError -> String -> String)
-> (SignatureError -> String)
-> ([SignatureError] -> String -> String)
-> Show SignatureError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SignatureError -> String -> String
showsPrec :: Int -> SignatureError -> String -> String
$cshow :: SignatureError -> String
show :: SignatureError -> String
$cshowList :: [SignatureError] -> String -> String
showList :: [SignatureError] -> String -> String
Show)