{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Partial implementation of <https://www.w3.org/TR/xmldsig-core/>.  We use hsaml2, hxt, x509 and
-- other dubious packages internally, but expose xml-types and cryptonite.
--
-- FUTUREWORK: other implementations that could be used for testing:
-- https://www.aleksey.com/xmlsec/ (C);
-- https://github.com/yaronn/xml-crypto (js)
module Text.XML.DSig
  ( -- * types
    SignCreds (..),
    SignDigest (..),
    SignKey (..),
    SignPrivCreds (..),
    SignPrivKey (..),

    -- * credential handling
    verifySelfSignature,
    parseKeyInfo,
    renderKeyInfo,
    certToCreds,
    mkSignCreds,
    mkSignCredsWithCert,

    -- * signature verification
    verify,
    verifyRoot,
    verifyIO,

    -- * signature creation
    signRootAt,

    -- * testing
    HasMonadSign,
    MonadSign (MonadSign),
    runMonadSign,
    signElementIOAt,
    verifyIO',
    verifySignatureUnenvelopedSigs,
  )
where

import Control.Arrow.ArrowTree qualified as Arr
import Control.Exception (ErrorCall (ErrorCall), SomeException, handle, throwIO, try)
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Crypto.Hash (RIPEMD160 (..), SHA1 (..), SHA256 (..), SHA512 (..), hashlazy)
import Crypto.Hash qualified as Crypto
import Crypto.Number.Serialize (os2ip)
import Crypto.PubKey.DSA qualified as DSA
import Crypto.PubKey.RSA qualified as RSA
import Crypto.PubKey.RSA.PKCS15 qualified as RSA
import Crypto.PubKey.RSA.Types qualified as RSA
import Crypto.Random.Types qualified as Crypto
import Data.ByteArray qualified as BA
import Data.ByteArray qualified as ByteArray
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Either (isRight)
import Data.EitherR (fmapL)
import Data.Foldable (toList)
import Data.Hourglass qualified as Hourglass
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NL
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.String.Conversions
import Data.UUID as UUID
import Data.X509 qualified as X509
import GHC.Stack
import Network.URI (URI (..), parseRelativeReference)
import SAML2.XML qualified as HS hiding (Node, URI)
import SAML2.XML.Canonical qualified as HS
import SAML2.XML.Signature qualified as HS
import System.IO (stderr, stdout)
import System.IO.Silently (hCapture)
import System.IO.Unsafe (unsafePerformIO)
import System.Random (mkStdGen, random)
import Text.XML as XML
import Text.XML.HXT.Arrow.Pickle.Xml.Invertible qualified as XP
import Text.XML.HXT.Core qualified as HXTC
import Text.XML.HXT.DOM.QualifiedName qualified as DOM
import Text.XML.HXT.DOM.XmlNode qualified as DOM
import Text.XML.HXT.DOM.XmlNode qualified as HXT
import Text.XML.Util
import Time.System qualified as Hourglass

----------------------------------------------------------------------
-- types

data SignCreds = SignCreds SignDigest SignKey
  deriving (SignCreds -> SignCreds -> Bool
(SignCreds -> SignCreds -> Bool)
-> (SignCreds -> SignCreds -> Bool) -> Eq SignCreds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignCreds -> SignCreds -> Bool
== :: SignCreds -> SignCreds -> Bool
$c/= :: SignCreds -> SignCreds -> Bool
/= :: SignCreds -> SignCreds -> Bool
Eq, Int -> SignCreds -> ShowS
[SignCreds] -> ShowS
SignCreds -> [Char]
(Int -> SignCreds -> ShowS)
-> (SignCreds -> [Char])
-> ([SignCreds] -> ShowS)
-> Show SignCreds
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignCreds -> ShowS
showsPrec :: Int -> SignCreds -> ShowS
$cshow :: SignCreds -> [Char]
show :: SignCreds -> [Char]
$cshowList :: [SignCreds] -> ShowS
showList :: [SignCreds] -> ShowS
Show)

data SignDigest = SignDigestSha256
  deriving (SignDigest -> SignDigest -> Bool
(SignDigest -> SignDigest -> Bool)
-> (SignDigest -> SignDigest -> Bool) -> Eq SignDigest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignDigest -> SignDigest -> Bool
== :: SignDigest -> SignDigest -> Bool
$c/= :: SignDigest -> SignDigest -> Bool
/= :: SignDigest -> SignDigest -> Bool
Eq, Int -> SignDigest -> ShowS
[SignDigest] -> ShowS
SignDigest -> [Char]
(Int -> SignDigest -> ShowS)
-> (SignDigest -> [Char])
-> ([SignDigest] -> ShowS)
-> Show SignDigest
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignDigest -> ShowS
showsPrec :: Int -> SignDigest -> ShowS
$cshow :: SignDigest -> [Char]
show :: SignDigest -> [Char]
$cshowList :: [SignDigest] -> ShowS
showList :: [SignDigest] -> ShowS
Show, SignDigest
SignDigest -> SignDigest -> Bounded SignDigest
forall a. a -> a -> Bounded a
$cminBound :: SignDigest
minBound :: SignDigest
$cmaxBound :: SignDigest
maxBound :: SignDigest
Bounded, Int -> SignDigest
SignDigest -> Int
SignDigest -> [SignDigest]
SignDigest -> SignDigest
SignDigest -> SignDigest -> [SignDigest]
SignDigest -> SignDigest -> SignDigest -> [SignDigest]
(SignDigest -> SignDigest)
-> (SignDigest -> SignDigest)
-> (Int -> SignDigest)
-> (SignDigest -> Int)
-> (SignDigest -> [SignDigest])
-> (SignDigest -> SignDigest -> [SignDigest])
-> (SignDigest -> SignDigest -> [SignDigest])
-> (SignDigest -> SignDigest -> SignDigest -> [SignDigest])
-> Enum SignDigest
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SignDigest -> SignDigest
succ :: SignDigest -> SignDigest
$cpred :: SignDigest -> SignDigest
pred :: SignDigest -> SignDigest
$ctoEnum :: Int -> SignDigest
toEnum :: Int -> SignDigest
$cfromEnum :: SignDigest -> Int
fromEnum :: SignDigest -> Int
$cenumFrom :: SignDigest -> [SignDigest]
enumFrom :: SignDigest -> [SignDigest]
$cenumFromThen :: SignDigest -> SignDigest -> [SignDigest]
enumFromThen :: SignDigest -> SignDigest -> [SignDigest]
$cenumFromTo :: SignDigest -> SignDigest -> [SignDigest]
enumFromTo :: SignDigest -> SignDigest -> [SignDigest]
$cenumFromThenTo :: SignDigest -> SignDigest -> SignDigest -> [SignDigest]
enumFromThenTo :: SignDigest -> SignDigest -> SignDigest -> [SignDigest]
Enum)

data SignKey = SignKeyRSA RSA.PublicKey
  deriving (SignKey -> SignKey -> Bool
(SignKey -> SignKey -> Bool)
-> (SignKey -> SignKey -> Bool) -> Eq SignKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignKey -> SignKey -> Bool
== :: SignKey -> SignKey -> Bool
$c/= :: SignKey -> SignKey -> Bool
/= :: SignKey -> SignKey -> Bool
Eq, Int -> SignKey -> ShowS
[SignKey] -> ShowS
SignKey -> [Char]
(Int -> SignKey -> ShowS)
-> (SignKey -> [Char]) -> ([SignKey] -> ShowS) -> Show SignKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignKey -> ShowS
showsPrec :: Int -> SignKey -> ShowS
$cshow :: SignKey -> [Char]
show :: SignKey -> [Char]
$cshowList :: [SignKey] -> ShowS
showList :: [SignKey] -> ShowS
Show)

data SignPrivCreds = SignPrivCreds SignDigest SignPrivKey
  deriving (SignPrivCreds -> SignPrivCreds -> Bool
(SignPrivCreds -> SignPrivCreds -> Bool)
-> (SignPrivCreds -> SignPrivCreds -> Bool) -> Eq SignPrivCreds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignPrivCreds -> SignPrivCreds -> Bool
== :: SignPrivCreds -> SignPrivCreds -> Bool
$c/= :: SignPrivCreds -> SignPrivCreds -> Bool
/= :: SignPrivCreds -> SignPrivCreds -> Bool
Eq, Int -> SignPrivCreds -> ShowS
[SignPrivCreds] -> ShowS
SignPrivCreds -> [Char]
(Int -> SignPrivCreds -> ShowS)
-> (SignPrivCreds -> [Char])
-> ([SignPrivCreds] -> ShowS)
-> Show SignPrivCreds
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignPrivCreds -> ShowS
showsPrec :: Int -> SignPrivCreds -> ShowS
$cshow :: SignPrivCreds -> [Char]
show :: SignPrivCreds -> [Char]
$cshowList :: [SignPrivCreds] -> ShowS
showList :: [SignPrivCreds] -> ShowS
Show)

data SignPrivKey = SignPrivKeyRSA RSA.KeyPair
  deriving (SignPrivKey -> SignPrivKey -> Bool
(SignPrivKey -> SignPrivKey -> Bool)
-> (SignPrivKey -> SignPrivKey -> Bool) -> Eq SignPrivKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignPrivKey -> SignPrivKey -> Bool
== :: SignPrivKey -> SignPrivKey -> Bool
$c/= :: SignPrivKey -> SignPrivKey -> Bool
/= :: SignPrivKey -> SignPrivKey -> Bool
Eq, Int -> SignPrivKey -> ShowS
[SignPrivKey] -> ShowS
SignPrivKey -> [Char]
(Int -> SignPrivKey -> ShowS)
-> (SignPrivKey -> [Char])
-> ([SignPrivKey] -> ShowS)
-> Show SignPrivKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignPrivKey -> ShowS
showsPrec :: Int -> SignPrivKey -> ShowS
$cshow :: SignPrivKey -> [Char]
show :: SignPrivKey -> [Char]
$cshowList :: [SignPrivKey] -> ShowS
showList :: [SignPrivKey] -> ShowS
Show)

----------------------------------------------------------------------
-- credential handling

verifySelfSignature :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m ()
verifySelfSignature :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SignedCertificate -> m ()
verifySelfSignature SignedCertificate
cert = do
  SignedCertificate -> m SignCreds
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SignedCertificate -> m SignCreds
certToCreds SignedCertificate
cert m SignCreds -> (SignCreds -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SignCreds SignDigest
SignDigestSha256 (SignKeyRSA PublicKey
pubkey) -> do
      let signedMessage :: ByteString
signedMessage = SignedCertificate -> ByteString
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X509.getSignedData SignedCertificate
cert
          signatureValue :: ByteString
signatureValue = Signed Certificate -> ByteString
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> ByteString
X509.signedSignature (Signed Certificate -> ByteString)
-> Signed Certificate -> ByteString
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned SignedCertificate
cert
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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
Crypto.SHA256) PublicKey
pubkey ByteString
signedMessage ByteString
signatureValue) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"verifySelfSignature: invalid signature."

-- | Read the KeyInfo element of a meta file's IDPSSODescriptor into a public key that can be used
-- for signing.  Tested for KeyInfo elements that contain an x509 certificate.
--
-- Self-signatures are only verified if first argument is 'True'.  The reason for this flag is
-- that some IdPs (e.g. centrify) sign their certificates with external CAs.  Verification
-- against external cert needs to be done separately before calling this function.
parseKeyInfo :: (HasCallStack, MonadError String m) => Bool -> LT -> m X509.SignedCertificate
parseKeyInfo :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Bool -> LT -> m SignedCertificate
parseKeyInfo Bool
doVerify (forall a b. ConvertibleStrings a b => a -> b
cs @LT @LBS -> LBS
lbs) = case forall a. XmlPickler a => LBS -> Either [Char] a
HS.xmlToSAML @HS.KeyInfo (LBS -> Either [Char] KeyInfo)
-> Either [Char] LBS -> Either [Char] KeyInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LBS -> Either [Char] LBS
forall (m :: * -> *). (m ~ Either [Char]) => LBS -> m LBS
stripWhitespaceLBS LBS
lbs of
  Right KeyInfo
keyinf -> case (KeyInfoElement -> Bool) -> [KeyInfoElement] -> [KeyInfoElement]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (KeyInfoElement -> Bool) -> KeyInfoElement -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyInfoElement -> Bool
ignorable) ([KeyInfoElement] -> [KeyInfoElement])
-> (List1 KeyInfoElement -> [KeyInfoElement])
-> List1 KeyInfoElement
-> [KeyInfoElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 KeyInfoElement -> [KeyInfoElement]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (List1 KeyInfoElement -> [KeyInfoElement])
-> List1 KeyInfoElement -> [KeyInfoElement]
forall a b. (a -> b) -> a -> b
$ KeyInfo -> List1 KeyInfoElement
HS.keyInfoElements KeyInfo
keyinf of
    [HS.X509Data List1 X509Element
dt] ->
      List1 X509Element -> m SignedCertificate
parseX509Data List1 X509Element
dt
    [] ->
      [Char] -> m SignedCertificate
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignedCertificate) -> [Char] -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ [Char]
"KeyInfo element must contain X509Data"
    [KeyInfoElement]
unsupported ->
      [Char] -> m SignedCertificate
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignedCertificate) -> [Char] -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported children in KeyInfo element: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [KeyInfoElement] -> [Char]
forall a. Show a => a -> [Char]
show [KeyInfoElement]
unsupported
  Left [Char]
errmsg ->
    [Char] -> m SignedCertificate
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignedCertificate) -> [Char] -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly one KeyInfo element: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
errmsg
  where
    ignorable :: KeyInfoElement -> Bool
ignorable (HS.KeyName [Char]
_) = Bool
True
    ignorable KeyInfoElement
_ = Bool
False
    parseX509Data :: List1 X509Element -> m SignedCertificate
parseX509Data (HS.X509Certificate SignedCertificate
cert :| []) =
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doVerify (SignedCertificate -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SignedCertificate -> m ()
verifySelfSignature SignedCertificate
cert) m () -> m SignedCertificate -> m SignedCertificate
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SignedCertificate -> m SignedCertificate
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignedCertificate
cert
    parseX509Data List1 X509Element
bad =
      [Char] -> m SignedCertificate
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignedCertificate) -> [Char] -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ [Char]
"data with more than one child: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [X509Element] -> [Char]
forall a. Show a => a -> [Char]
show (List1 X509Element -> [X509Element]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List1 X509Element
bad)

-- | Call 'stripWhitespaceDoc' on a rendered bytestring.
stripWhitespaceLBS :: (m ~ Either String) => LBS -> m LBS
stripWhitespaceLBS :: forall (m :: * -> *). (m ~ Either [Char]) => LBS -> m LBS
stripWhitespaceLBS LBS
lbs = RenderSettings -> Document -> LBS
renderLBS RenderSettings
forall a. Default a => a
def (Document -> LBS) -> (Document -> Document) -> Document -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Document
stripWhitespace (Document -> LBS) -> m Document -> m LBS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SomeException -> [Char])
-> Either SomeException Document -> Either [Char] Document
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL SomeException -> [Char]
forall a. Show a => a -> [Char]
show (ParseSettings -> LBS -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def LBS
lbs)

renderKeyInfo :: (HasCallStack) => X509.SignedCertificate -> LT
renderKeyInfo :: HasCallStack => SignedCertificate -> LT
renderKeyInfo SignedCertificate
cert = LBS -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (LBS -> LT)
-> (List1 KeyInfoElement -> LBS) -> List1 KeyInfoElement -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyInfo -> LBS
forall a. XmlPickler a => a -> LBS
ourSamlToXML (KeyInfo -> LBS)
-> (List1 KeyInfoElement -> KeyInfo) -> List1 KeyInfoElement -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> List1 KeyInfoElement -> KeyInfo
HS.KeyInfo Maybe [Char]
forall a. Maybe a
Nothing (List1 KeyInfoElement -> LT) -> List1 KeyInfoElement -> LT
forall a b. (a -> b) -> a -> b
$ KeyInfoElement -> List1 KeyInfoElement
forall a. a -> NonEmpty a
NonEmpty.singleton (List1 X509Element -> KeyInfoElement
HS.X509Data (X509Element -> List1 X509Element
forall a. a -> NonEmpty a
NonEmpty.singleton (SignedCertificate -> X509Element
HS.X509Certificate SignedCertificate
cert)))

certToCreds :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m SignCreds
certToCreds :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SignedCertificate -> m SignCreds
certToCreds SignedCertificate
cert = do
  digest <- case Signed Certificate -> SignatureALG
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> SignatureALG
X509.signedAlg (Signed Certificate -> SignatureALG)
-> Signed Certificate -> SignatureALG
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned SignedCertificate
cert of
    X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_RSA -> SignDigest -> m SignDigest
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignDigest
SignDigestSha256
    SignatureALG
bad -> [Char] -> m SignDigest
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignDigest) -> [Char] -> m SignDigest
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SignatureALG -> [Char]
forall a. Show a => a -> [Char]
show SignatureALG
bad
  key <- case X509.certPubKey . X509.signedObject $ X509.getSigned cert of
    X509.PubKeyRSA PublicKey
pk -> SignKey -> m SignKey
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignKey -> m SignKey) -> SignKey -> m SignKey
forall a b. (a -> b) -> a -> b
$ PublicKey -> SignKey
SignKeyRSA PublicKey
pk
    PubKey
bad -> [Char] -> m SignKey
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignKey) -> [Char] -> m SignKey
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PubKey -> [Char]
forall a. Show a => a -> [Char]
show PubKey
bad
  pure $ SignCreds digest key

mkSignCreds :: (Crypto.MonadRandom m, MonadIO m) => Int -> m (SignPrivCreds, SignCreds)
mkSignCreds :: forall (m :: * -> *).
(MonadRandom m, MonadIO m) =>
Int -> m (SignPrivCreds, SignCreds)
mkSignCreds Int
size = Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
forall (m :: * -> *).
(MonadRandom m, MonadIO m) =>
Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
mkSignCredsWithCert Maybe DateTime
forall a. Maybe a
Nothing Int
size m (SignPrivCreds, SignCreds, SignedCertificate)
-> ((SignPrivCreds, SignCreds, SignedCertificate)
    -> (SignPrivCreds, SignCreds))
-> m (SignPrivCreds, SignCreds)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SignPrivCreds
priv, SignCreds
pub, SignedCertificate
_) -> (SignPrivCreds
priv, SignCreds
pub)

-- | If first argument @validSince@ is @Nothing@, use cucrent system time.
mkSignCredsWithCert ::
  forall m.
  (Crypto.MonadRandom m, MonadIO m) =>
  Maybe Hourglass.DateTime ->
  Int ->
  m (SignPrivCreds, SignCreds, X509.SignedCertificate)
mkSignCredsWithCert :: forall (m :: * -> *).
(MonadRandom m, MonadIO m) =>
Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
mkSignCredsWithCert Maybe DateTime
mValidSince Int
size = do
  let rsaexp :: a
rsaexp = a
17
  (pubkey, privkey) <- Int -> Integer -> m (PublicKey, PrivateKey)
forall (m :: * -> *).
MonadRandom m =>
Int -> Integer -> m (PublicKey, PrivateKey)
RSA.generate Int
size Integer
forall {a}. Num a => a
rsaexp
  let -- https://github.com/vincenthz/hs-certificate/issues/119
      cropToSecs :: Hourglass.DateTime -> Hourglass.DateTime
      cropToSecs DateTime
dt = DateTime
dt {Hourglass.dtTime = (Hourglass.dtTime dt) {Hourglass.todNSec = 0}}
  validSince :: Hourglass.DateTime <- cropToSecs <$> maybe (liftIO Hourglass.dateCurrent) pure mValidSince
  let validUntil = DateTime
validSince DateTime -> Duration -> DateTime
forall t ti. (Time t, TimeInterval ti) => t -> ti -> t
`Hourglass.timeAdd` Duration
forall a. Monoid a => a
mempty {Hourglass.durationHours = 24 * 365 * 20}
      signcert :: SBS -> m (SBS, X509.SignatureALG)
      signcert ByteString
sbs = (,SignatureALG
sigalg) (ByteString -> (ByteString, SignatureALG))
-> m ByteString -> m (ByteString, SignatureALG)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ByteString
sigval
        where
          sigalg :: SignatureALG
sigalg = HashALG -> PubKeyALG -> SignatureALG
X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_RSA
          m ByteString
sigval :: m SBS =
            IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$
              Maybe SHA256
-> PrivateKey -> ByteString -> IO (Either Error ByteString)
forall hashAlg (m :: * -> *).
(HashAlgorithmASN1 hashAlg, MonadRandom m) =>
Maybe hashAlg
-> PrivateKey -> ByteString -> m (Either Error ByteString)
RSA.signSafer (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
Crypto.SHA256) PrivateKey
privkey ByteString
sbs
                IO (Either Error ByteString)
-> (Either Error ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m 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 (ErrorCall -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ErrorCall -> IO ByteString)
-> (Error -> ErrorCall) -> Error -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ErrorCall
ErrorCall ([Char] -> ErrorCall) -> (Error -> [Char]) -> Error -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [Char]
forall a. Show a => a -> [Char]
show) ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  cert <-
    X509.objectToSignedExactF
      signcert
      X509.Certificate
        { X509.certVersion = 2 :: Int,
          X509.certSerial = 387928798798718181888591698169861 :: Integer,
          X509.certSignatureAlg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA,
          X509.certIssuerDN = X509.DistinguishedName [],
          X509.certValidity = (validSince, validUntil),
          X509.certSubjectDN = X509.DistinguishedName [],
          X509.certPubKey = X509.PubKeyRSA pubkey,
          X509.certExtensions = X509.Extensions Nothing
        }
  pure
    ( SignPrivCreds SignDigestSha256 . SignPrivKeyRSA $ RSA.KeyPair privkey,
      SignCreds SignDigestSha256 . SignKeyRSA $ pubkey,
      cert
    )

----------------------------------------------------------------------
-- signature verification

-- | We sometimes get XML documents that are underspecific about which credentials they are going to
-- use later.  As longs as all credentials are from the same authoritative source, it may be ok to
-- ask for *any* of them to match a signature.  So here is an @or@ over 'verify' and a non-empty
-- list of 'SignCred's.
--
-- NB: The call to 'unsafePerformIO' in this function is sound under the assumption that
-- 'verifyIO' has no effects in 'IO' other than throwing 'SomeException' (which are captured
-- by 'try'.  Technically, it does have other effects, like opening temp files for capturing
-- stderr (if any), but we do not care about those.  The only thing we care about is that the
-- conceptually pure function of validating a signature will either be called twice with the
-- same arguments and return the same result value, or not be called a second time with the
-- same arguments, in which case that same value will be used.
{-# NOINLINE verify #-}
verify :: forall m. (MonadError String m) => NonEmpty SignCreds -> LBS -> String -> m HXTC.XmlTree
verify :: forall (m :: * -> *).
MonadError [Char] m =>
NonEmpty SignCreds -> LBS -> [Char] -> m XmlTree
verify NonEmpty SignCreds
creds LBS
el [Char]
sid = case IO
  (Either SomeException (SignCreds, Either SignatureError XmlTree))
-> Either SomeException (SignCreds, Either SignatureError XmlTree)
forall a. IO a -> a
unsafePerformIO (forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO (SignCreds, Either SignatureError XmlTree)
 -> IO
      (Either SomeException (SignCreds, Either SignatureError XmlTree)))
-> IO (SignCreds, Either SignatureError XmlTree)
-> IO
     (Either SomeException (SignCreds, Either SignatureError XmlTree))
forall a b. (a -> b) -> a -> b
$ NonEmpty SignCreds
-> LBS -> [Char] -> IO (SignCreds, Either SignatureError XmlTree)
verifyIO NonEmpty SignCreds
creds LBS
el [Char]
sid) of
  Right (SignCreds
_, Right XmlTree
xml) -> XmlTree -> m XmlTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XmlTree
xml
  Right (SignCreds
_, Left SignatureError
exc) -> [Char] -> m XmlTree
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m XmlTree) -> [Char] -> m XmlTree
forall a b. (a -> b) -> a -> b
$ SignatureError -> [Char]
forall a. Show a => a -> [Char]
show SignatureError
exc
  Left SomeException
exc -> [Char] -> m XmlTree
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m XmlTree) -> [Char] -> m XmlTree
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exc

-- | Convenient wrapper that picks the ID of the root element node and passes it to `verify`.
verifyRoot :: forall m. (MonadError String m) => NonEmpty SignCreds -> LBS -> m HXTC.XmlTree
verifyRoot :: forall (m :: * -> *).
MonadError [Char] m =>
NonEmpty SignCreds -> LBS -> m XmlTree
verifyRoot NonEmpty SignCreds
creds LBS
el = do
  signedID <- do
    XML.Document _ (XML.Element _ attrs _) _ <-
      (SomeException -> m Document)
-> (Document -> m Document)
-> Either SomeException Document
-> m Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        ([Char] -> m Document
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m Document)
-> (SomeException -> [Char]) -> SomeException -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Could not parse signed document: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (SomeException -> [Char]) -> SomeException -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ShowS -> (SomeException -> [Char]) -> SomeException -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall a. Show a => a -> [Char]
show)
        Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (ParseSettings -> LBS -> Either SomeException Document
XML.parseLBS ParseSettings
forall a. Default a => a
XML.def LBS
el)
    maybe
      (throwError $ "Could not parse signed document: no ID attribute in root element." <> show el)
      (pure . cs)
      (Map.lookup "ID" attrs)
  verify creds el signedID

-- | Try a list of creds against a document.  If all fail, return a list of errors for each cert; if
-- *any* succeed, return the empty list.
verifyIO :: NonEmpty SignCreds -> LBS -> String -> IO (SignCreds, Either HS.SignatureError HXTC.XmlTree)
verifyIO :: NonEmpty SignCreds
-> LBS -> [Char] -> IO (SignCreds, Either SignatureError XmlTree)
verifyIO NonEmpty SignCreds
creds LBS
el [Char]
sid = IO (SignCreds, Either SignatureError XmlTree)
-> IO (SignCreds, Either SignatureError XmlTree)
forall a. IO a -> IO a
capture' (IO (SignCreds, Either SignatureError XmlTree)
 -> IO (SignCreds, Either SignatureError XmlTree))
-> IO (SignCreds, Either SignatureError XmlTree)
-> IO (SignCreds, Either SignatureError XmlTree)
forall a b. (a -> b) -> a -> b
$ do
  results <- NonEmpty SignCreds
-> NonEmpty (Either SignatureError XmlTree)
-> NonEmpty (SignCreds, Either SignatureError XmlTree)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NL.zip NonEmpty SignCreds
creds (NonEmpty (Either SignatureError XmlTree)
 -> NonEmpty (SignCreds, Either SignatureError XmlTree))
-> IO (NonEmpty (Either SignatureError XmlTree))
-> IO (NonEmpty (SignCreds, Either SignatureError XmlTree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SignCreds
-> (SignCreds -> IO (Either SignatureError XmlTree))
-> IO (NonEmpty (Either SignatureError XmlTree))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty SignCreds
creds (\SignCreds
cred -> SignCreds -> LBS -> [Char] -> IO (Either SignatureError XmlTree)
verifyIO' SignCreds
cred LBS
el [Char]
sid)
  case NL.filter (isRight . snd) results of
    [(SignCreds, Either SignatureError XmlTree)
result] -> (SignCreds, Either SignatureError XmlTree)
-> IO (SignCreds, Either SignatureError XmlTree)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignCreds, Either SignatureError XmlTree)
result
    [(SignCreds, Either SignatureError XmlTree)]
_ -> ErrorCall -> IO (SignCreds, Either SignatureError XmlTree)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ErrorCall -> IO (SignCreds, Either SignatureError XmlTree))
-> ([Char] -> ErrorCall)
-> [Char]
-> IO (SignCreds, Either SignatureError XmlTree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ErrorCall
ErrorCall ([Char] -> IO (SignCreds, Either SignatureError XmlTree))
-> [Char] -> IO (SignCreds, Either SignatureError XmlTree)
forall a b. (a -> b) -> a -> b
$ [Char]
"all credentials failed to verify signature"
  where
    capture' :: IO a -> IO a
    capture' :: forall a. IO a -> IO a
capture' IO a
action =
      [Handle] -> IO a -> IO ([Char], a)
forall a. [Handle] -> IO a -> IO ([Char], a)
hCapture [Handle
stdout, Handle
stderr] IO a
action IO ([Char], a) -> (([Char], a) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ([Char]
"", a
out) -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
out
        ([Char]
noise, a
_) -> ErrorCall -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ErrorCall -> IO a) -> ([Char] -> ErrorCall) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ErrorCall
ErrorCall ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
"noise on stdout/stderr from hsaml2 package: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
noise

verifyIO' :: SignCreds -> LBS -> String -> IO (Either HS.SignatureError HXTC.XmlTree)
verifyIO' :: SignCreds -> LBS -> [Char] -> IO (Either SignatureError XmlTree)
verifyIO' (SignCreds SignDigest
SignDigestSha256 (SignKeyRSA PublicKey
key)) LBS
el [Char]
sid = ExceptT SignatureError IO XmlTree
-> IO (Either SignatureError XmlTree)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SignatureError IO XmlTree
 -> IO (Either SignatureError XmlTree))
-> ExceptT SignatureError IO XmlTree
-> IO (Either SignatureError XmlTree)
forall a b. (a -> b) -> a -> b
$ do
  el' <- ([Char] -> ExceptT SignatureError IO XmlTree)
-> (XmlTree -> ExceptT SignatureError IO XmlTree)
-> Either [Char] XmlTree
-> ExceptT SignatureError IO XmlTree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SignatureError -> ExceptT SignatureError IO XmlTree
forall a. SignatureError -> ExceptT SignatureError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SignatureError -> ExceptT SignatureError IO XmlTree)
-> ([Char] -> SignatureError)
-> [Char]
-> ExceptT SignatureError IO XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> SignatureError
HS.SignatureParseError) XmlTree -> ExceptT SignatureError IO XmlTree
forall a. a -> ExceptT SignatureError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] XmlTree -> ExceptT SignatureError IO XmlTree)
-> Either [Char] XmlTree -> ExceptT SignatureError IO XmlTree
forall a b. (a -> b) -> a -> b
$ LBS -> Either [Char] XmlTree
HS.xmlToDocE LBS
el
  ExceptT $ verifySignatureUnenvelopedSigs (HS.PublicKeys Nothing . Just $ key) sid el'

----------------------------------------------------------------------------------------------------
-- the following is copied from hsaml2 and patched to fit our API

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

    warpResult :: Maybe HXTC.XmlTree -> Either HS.SignatureError HXTC.XmlTree
    warpResult :: Maybe XmlTree -> Either SignatureError XmlTree
warpResult (Just XmlTree
xml) = XmlTree -> Either SignatureError XmlTree
forall a b. b -> Either a b
Right XmlTree
xml
    warpResult Maybe XmlTree
Nothing = SignatureError -> Either SignatureError XmlTree
forall a b. a -> Either a b
Left (Either [Char] (Maybe Bool) -> SignatureError
HS.SignatureVerificationLegacyFailure (Maybe Bool -> Either [Char] (Maybe Bool)
forall a b. b -> Either a b
Right Maybe Bool
forall a. Maybe a
Nothing))

-- | Returns the xml sub-trees of the input that have valid signatures signatures.  May throw
-- exceptions in IO.
verifySignature :: HS.PublicKeys -> String -> HXTC.XmlTree -> IO (Maybe HXTC.XmlTree)
verifySignature :: PublicKeys -> [Char] -> XmlTree -> IO (Maybe XmlTree)
verifySignature PublicKeys
pks [Char]
xid XmlTree
doc = do
  let namespaces :: NsEnv
namespaces = AssocList [Char] [Char] -> NsEnv
DOM.toNsEnv (AssocList [Char] [Char] -> NsEnv)
-> AssocList [Char] [Char] -> NsEnv
forall a b. (a -> b) -> a -> b
$ LA XmlTree ([Char], [Char]) -> XmlTree -> AssocList [Char] [Char]
forall a b. LA a b -> a -> [b]
HXTC.runLA LA XmlTree ([Char], [Char])
HXTC.collectNamespaceDecl XmlTree
doc
  x <- case LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXTC.runLA ([Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
getID [Char]
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
HXTC.>>> NsEnv -> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => NsEnv -> a XmlTree XmlTree
HXTC.attachNsEnv NsEnv
namespaces) XmlTree
doc of
    [XmlTree
x] -> XmlTree -> IO XmlTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XmlTree
x
    [XmlTree]
_ -> [Char] -> IO XmlTree
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"verifySignature: element not found"
  sx <- case child "Signature" x of
    [XmlTree
sx] -> XmlTree -> IO XmlTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XmlTree
sx
    [XmlTree]
_ -> [Char] -> IO XmlTree
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"verifySignature: Signature not found"
  s@HS.Signature {signatureSignedInfo = si} <- either fail pure $ HS.docToSAML sx
  six <- applyCanonicalization (HS.signedInfoCanonicalizationMethod si) (Just xpath) $ DOM.mkRoot [] [x]
  results <- mapM (`verifyReference` x) (HS.signedInfoReference si)
  let mResult = case (Either [Char] ([Char], XmlTree) -> Bool)
-> [Either [Char] ([Char], XmlTree)]
-> [Either [Char] ([Char], XmlTree)]
forall a. (a -> Bool) -> [a] -> [a]
filter Either [Char] ([Char], XmlTree) -> Bool
matchingId (NonEmpty (Either [Char] ([Char], XmlTree))
-> [Either [Char] ([Char], XmlTree)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Either [Char] ([Char], XmlTree))
results) of
        [(Right ([Char]
_, XmlTree
xml))] -> XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just XmlTree
xml
        [Either [Char] ([Char], XmlTree)]
_ -> Maybe XmlTree
forall a. Maybe a
Nothing
  let isSignatureValid = PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBytes PublicKeys
pks (SignatureMethod -> IdentifiedURI SignatureAlgorithm
HS.signatureMethodAlgorithm (SignatureMethod -> IdentifiedURI SignatureAlgorithm)
-> SignatureMethod -> IdentifiedURI SignatureAlgorithm
forall a b. (a -> b) -> a -> b
$ SignedInfo -> SignatureMethod
HS.signedInfoSignatureMethod SignedInfo
si) (SignatureValue -> ByteString
HS.signatureValue (SignatureValue -> ByteString) -> SignatureValue -> ByteString
forall a b. (a -> b) -> a -> b
$ Signature -> SignatureValue
HS.signatureSignatureValue Signature
s) ByteString
six
  pure $ case isSignatureValid of
    Just Bool
True -> Maybe XmlTree
mResult
    Maybe Bool
_ -> Maybe XmlTree
forall a. Maybe a
Nothing
  where
    matchingId :: Either String (String, HXTC.XmlTree) -> Bool
    matchingId :: Either [Char] ([Char], XmlTree) -> Bool
matchingId (Right ([Char]
xid', XmlTree
_)) = [Char]
xid [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
xid'
    matchingId (Left [Char]
_) = Bool
False

    child :: [Char] -> XmlTree -> [XmlTree]
child [Char]
n = LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXTC.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)
Arr.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
HXTC.>>> [Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
isDSElem [Char]
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
HXTC.>>> LA XmlTree ([Char], [Char]) -> LA XmlTree XmlTree
HXTC.cleanupNamespaces LA XmlTree ([Char], [Char])
HXTC.collectPrefixUriPairs
    xpathsel :: ShowS
xpathsel [Char]
t = [Char]
"/*[local-name()='" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"' and namespace-uri()='" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Namespace -> [Char]
HS.namespaceURIString Namespace
HS.ns [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"']"
    xpathbase :: [Char]
xpathbase = [Char]
"/*" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
xpathsel [Char]
"Signature" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
xpathsel [Char]
"SignedInfo" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"//"
    xpath :: [Char]
xpath = [Char]
xpathbase [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
". | " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
xpathbase [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"@* | " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
xpathbase [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"namespace::*"

-- | indicate verification result; return 'Nothing' if no matching key/alg pair is found
verifyBytes :: HS.PublicKeys -> HS.IdentifiedURI HS.SignatureAlgorithm -> BS.ByteString -> BS.ByteString -> Maybe Bool
verifyBytes :: PublicKeys
-> IdentifiedURI SignatureAlgorithm
-> ByteString
-> ByteString
-> Maybe Bool
verifyBytes HS.PublicKeys {publicKeyDSA :: PublicKeys -> Maybe PublicKey
publicKeyDSA = Just PublicKey
k} (HS.Identified SignatureAlgorithm
HS.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 :: Integer
DSA.sign_r = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
r, sign_s :: Integer
DSA.sign_s = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
s} ByteString
m
  where
    (ByteString
r, ByteString
s) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
20 ByteString
sig
verifyBytes HS.PublicKeys {publicKeyRSA :: PublicKeys -> Maybe PublicKey
publicKeyRSA = Just PublicKey
k} (HS.Identified SignatureAlgorithm
HS.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 HS.PublicKeys {publicKeyRSA :: PublicKeys -> Maybe PublicKey
publicKeyRSA = Just PublicKey
k} (HS.Identified SignatureAlgorithm
HS.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

isDSElem :: (HXTC.ArrowXml a) => String -> a HXTC.XmlTree HXTC.XmlTree
isDSElem :: forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
isDSElem [Char]
n = a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXTC.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
HXTC.>>> QName -> a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => QName -> a XmlTree XmlTree
HXTC.hasQName (Namespace -> [Char] -> QName
HS.mkNName Namespace
HS.ns [Char]
n)

getID :: (HXTC.ArrowXml a) => String -> a HXTC.XmlTree HXTC.XmlTree
getID :: forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> 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
HXTC.deep (a XmlTree XmlTree -> a XmlTree XmlTree)
-> ([Char] -> a XmlTree XmlTree) -> [Char] -> a XmlTree XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char] -> Bool) -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> ([Char] -> Bool) -> a XmlTree XmlTree
HXTC.hasAttrValue [Char]
"ID" (([Char] -> Bool) -> a XmlTree XmlTree)
-> ([Char] -> [Char] -> Bool) -> [Char] -> a XmlTree XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==)

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

applyTransformsBytes :: [HS.Transform] -> BSL.ByteString -> IO BSL.ByteString
applyTransformsBytes :: [Transform] -> LBS -> IO LBS
applyTransformsBytes [] LBS
v = LBS -> IO LBS
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LBS
v
applyTransformsBytes (Transform
t : [Transform]
_) LBS
_ = [Char] -> IO LBS
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"applyTransforms: unsupported Signature " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Transform -> [Char]
forall a. Show a => a -> [Char]
show Transform
t)

applyTransformsXML :: [HS.Transform] -> HXTC.XmlTree -> IO BSL.ByteString
applyTransformsXML :: [Transform] -> XmlTree -> IO LBS
applyTransformsXML (HS.Transform (HS.Identified (HS.TransformCanonicalization CanonicalizationAlgorithm
a)) Maybe InclusiveNamespaces
ins [TransformElement]
x : [Transform]
tl) =
  [Transform] -> LBS -> IO LBS
applyTransformsBytes [Transform]
tl (LBS -> IO LBS) -> (ByteString -> LBS) -> ByteString -> IO LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LBS
BSL.fromStrict
    (ByteString -> IO LBS)
-> (XmlTree -> IO ByteString) -> XmlTree -> IO LBS
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< CanonicalizationMethod -> Maybe [Char] -> XmlTree -> IO ByteString
applyCanonicalization (Identified URI CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces -> [XmlTree] -> CanonicalizationMethod
HS.CanonicalizationMethod (CanonicalizationAlgorithm
-> Identified URI CanonicalizationAlgorithm
forall b a. a -> Identified b a
HS.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 [Char]
forall a. Maybe a
Nothing
applyTransformsXML (HS.Transform (HS.Identified TransformAlgorithm
HS.TransformEnvelopedSignature) Maybe InclusiveNamespaces
Nothing [] : [Transform]
tl) =
  -- XXX assumes "this" signature in top-level
  [Transform] -> XmlTree -> IO LBS
applyTransformsXML [Transform]
tl
    (XmlTree -> IO LBS) -> (XmlTree -> XmlTree) -> XmlTree -> IO LBS
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]
HXTC.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)
HXTC.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)
HXTC.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
HXTC.neg ([Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
isDSElem [Char]
"Signature")
      )
applyTransformsXML [Transform]
tl = [Transform] -> LBS -> IO LBS
applyTransformsBytes [Transform]
tl (LBS -> IO LBS) -> (XmlTree -> LBS) -> XmlTree -> IO LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> LBS
xmlTreesToByteString ([XmlTree] -> LBS) -> (XmlTree -> [XmlTree]) -> XmlTree -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> [XmlTree]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    xmlTreesToByteString :: HXTC.XmlTrees -> BSL.ByteString
    xmlTreesToByteString :: [XmlTree] -> LBS
xmlTreesToByteString = HasCallStack => XmlTree -> LBS
XmlTree -> LBS
ourDocToXMLWithoutRoot (XmlTree -> LBS) -> ([XmlTree] -> XmlTree) -> [XmlTree] -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XNode -> [XmlTree] -> XmlTree
forall a. a -> NTrees a -> NTree a
HXT.NTree ([Char] -> XNode
HXTC.XText [Char]
"throw-me-away"))

applyTransforms :: Maybe HS.Transforms -> HXTC.XmlTree -> IO BSL.ByteString
applyTransforms :: Maybe Transforms -> XmlTree -> IO LBS
applyTransforms = [Transform] -> XmlTree -> IO LBS
applyTransformsXML ([Transform] -> XmlTree -> IO LBS)
-> (Maybe Transforms -> [Transform])
-> Maybe Transforms
-> XmlTree
-> IO LBS
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
HS.transforms)

applyDigest :: HS.DigestMethod -> BSL.ByteString -> BS.ByteString
applyDigest :: DigestMethod -> LBS -> ByteString
applyDigest (HS.DigestMethod (HS.Identified DigestAlgorithm
HS.DigestSHA1) []) = Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA1 -> ByteString)
-> (LBS -> Digest SHA1) -> LBS -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LBS -> Digest a
hashlazy @SHA1
applyDigest (HS.DigestMethod (HS.Identified DigestAlgorithm
HS.DigestSHA256) []) = Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA256 -> ByteString)
-> (LBS -> Digest SHA256) -> LBS -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LBS -> Digest a
hashlazy @SHA256
applyDigest (HS.DigestMethod (HS.Identified DigestAlgorithm
HS.DigestSHA512) []) = Digest SHA512 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA512 -> ByteString)
-> (LBS -> Digest SHA512) -> LBS -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LBS -> Digest a
hashlazy @SHA512
applyDigest (HS.DigestMethod (HS.Identified DigestAlgorithm
HS.DigestRIPEMD160) []) = Digest RIPEMD160 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest RIPEMD160 -> ByteString)
-> (LBS -> Digest RIPEMD160) -> LBS -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LBS -> Digest a
hashlazy @RIPEMD160
applyDigest DigestMethod
d = [Char] -> LBS -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> LBS -> ByteString) -> [Char] -> LBS -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DigestMethod -> [Char]
forall a. Show a => a -> [Char]
show DigestMethod
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) => HS.Reference -> HXTC.XmlTree -> IO (Either String (String, HXTC.XmlTree))
verifyReference :: HasCallStack =>
Reference -> XmlTree -> IO (Either [Char] ([Char], XmlTree))
verifyReference Reference
r XmlTree
doc = case Reference -> Maybe URI
HS.referenceURI Reference
r of
  Just URI {uriScheme :: URI -> [Char]
uriScheme = [Char]
"", uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Maybe URIAuth
Nothing, uriPath :: URI -> [Char]
uriPath = [Char]
"", uriQuery :: URI -> [Char]
uriQuery = [Char]
"", uriFragment :: URI -> [Char]
uriFragment = Char
'#' : [Char]
xid} ->
    case LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXTC.runLA ([Char] -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
getID [Char]
xid) XmlTree
doc of
      x :: [XmlTree]
x@[XmlTree
result] -> do
        t :: BSL.ByteString <- Maybe Transforms -> XmlTree -> IO LBS
applyTransforms (Reference -> Maybe Transforms
HS.referenceTransforms Reference
r) (XmlTree -> IO LBS) -> XmlTree -> IO LBS
forall a b. (a -> b) -> a -> b
$ [XmlTree] -> [XmlTree] -> XmlTree
DOM.mkRoot [] [XmlTree]
x
        let have = DigestMethod -> LBS -> ByteString
applyDigest (Reference -> DigestMethod
HS.referenceDigestMethod Reference
r) LBS
t
            want = Reference -> ByteString
HS.referenceDigestValue Reference
r
        pure $
          if have == want
            then Right (xid, result)
            else Left $ "#" <> xid <> ": digest mismatch"
      [XmlTree]
bad -> Either [Char] ([Char], XmlTree)
-> IO (Either [Char] ([Char], XmlTree))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] ([Char], XmlTree)
 -> IO (Either [Char] ([Char], XmlTree)))
-> ([Char] -> Either [Char] ([Char], XmlTree))
-> [Char]
-> IO (Either [Char] ([Char], XmlTree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] ([Char], XmlTree)
forall a b. a -> Either a b
Left ([Char] -> IO (Either [Char] ([Char], XmlTree)))
-> [Char] -> IO (Either [Char] ([Char], XmlTree))
forall a b. (a -> b) -> a -> b
$ [Char]
"#" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
xid [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": has " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([XmlTree] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XmlTree]
bad) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" matches, should have 1."
  Maybe URI
bad -> Either [Char] ([Char], XmlTree)
-> IO (Either [Char] ([Char], XmlTree))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] ([Char], XmlTree)
 -> IO (Either [Char] ([Char], XmlTree)))
-> ([Char] -> Either [Char] ([Char], XmlTree))
-> [Char]
-> IO (Either [Char] ([Char], XmlTree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] ([Char], XmlTree)
forall a b. a -> Either a b
Left ([Char] -> IO (Either [Char] ([Char], XmlTree)))
-> [Char] -> IO (Either [Char] ([Char], XmlTree))
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected referenceURI: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe URI -> [Char]
forall a. Show a => a -> [Char]
show Maybe URI
bad

-- the above is copied from hsaml2 and patched to fit our API
----------------------------------------------------------------------------------------------------

----------------------------------------------------------------------
-- signature creation

-- | Like 'signRoot', but insert signature at any given position in the children list.  If the list
-- is too short for this position, throw an error.
signRootAt :: (Crypto.MonadRandom m, MonadError String m) => Int -> SignPrivCreds -> XML.Document -> m XML.Document
signRootAt :: forall (m :: * -> *).
(MonadRandom m, MonadError [Char] m) =>
Int -> SignPrivCreds -> Document -> m Document
signRootAt Int
sigPos (SignPrivCreds SignDigest
hashAlg (SignPrivKeyRSA KeyPair
keypair)) Document
doc =
  do
    (docWithID :: XML.Document, reference) <- Document -> m (Document, URI)
forall (m :: * -> *).
(MonadError [Char] m, MonadRandom m) =>
Document -> m (Document, URI)
addRootIDIfMissing Document
doc
    docInHXT <- conduitToHxt docWithID
    let canoAlg = Bool -> CanonicalizationAlgorithm
HS.CanonicalXMLExcl10 Bool
True
        transforms =
          Transforms -> Maybe Transforms
forall a. a -> Maybe a
Just (Transforms -> Maybe Transforms)
-> (NonEmpty Transform -> Transforms)
-> NonEmpty Transform
-> Maybe Transforms
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Transform -> Transforms
HS.Transforms (NonEmpty Transform -> Maybe Transforms)
-> NonEmpty Transform -> Maybe Transforms
forall a b. (a -> b) -> a -> b
$
            HS.Transform
              { transformAlgorithm :: Identified URI TransformAlgorithm
HS.transformAlgorithm = TransformAlgorithm -> Identified URI TransformAlgorithm
forall b a. a -> Identified b a
HS.Identified TransformAlgorithm
HS.TransformEnvelopedSignature,
                transformInclusiveNamespaces :: Maybe InclusiveNamespaces
HS.transformInclusiveNamespaces = Maybe InclusiveNamespaces
forall a. Maybe a
Nothing,
                transform :: [TransformElement]
HS.transform = []
              }
              Transform -> [Transform] -> NonEmpty Transform
forall a. a -> [a] -> NonEmpty a
:| [ HS.Transform
                     { transformAlgorithm :: Identified URI TransformAlgorithm
HS.transformAlgorithm = TransformAlgorithm -> Identified URI TransformAlgorithm
forall b a. a -> Identified b a
HS.Identified (CanonicalizationAlgorithm -> TransformAlgorithm
HS.TransformCanonicalization CanonicalizationAlgorithm
canoAlg),
                       transformInclusiveNamespaces :: Maybe InclusiveNamespaces
HS.transformInclusiveNamespaces = Maybe InclusiveNamespaces
forall a. Maybe a
Nothing,
                       transform :: [TransformElement]
HS.transform = []
                     }
                 ]
    docCanonic :: SBS <-
      either (throwError . show) (pure . cs) . unsafePerformIO . try @SomeException $
        HS.applyTransforms transforms (HXT.mkRoot [] [docInHXT])
    let digest :: SBS
        digest = case SignDigest
hashAlg of
          SignDigest
SignDigestSha256 -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest SHA256 -> ByteString) -> Digest SHA256 -> ByteString
forall a b. (a -> b) -> a -> b
$ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Crypto.hash @SBS @Crypto.SHA256 ByteString
docCanonic
    let signedInfo =
          HS.SignedInfo
            { signedInfoId :: Maybe [Char]
signedInfoId = Maybe [Char]
forall a. Maybe a
Nothing :: Maybe HS.ID,
              signedInfoCanonicalizationMethod :: CanonicalizationMethod
signedInfoCanonicalizationMethod = Identified URI CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces -> [XmlTree] -> CanonicalizationMethod
HS.CanonicalizationMethod (CanonicalizationAlgorithm
-> Identified URI CanonicalizationAlgorithm
forall b a. a -> Identified b a
HS.Identified CanonicalizationAlgorithm
canoAlg) Maybe InclusiveNamespaces
forall a. Maybe a
Nothing [],
              signedInfoSignatureMethod :: SignatureMethod
signedInfoSignatureMethod = IdentifiedURI SignatureAlgorithm
-> Maybe Int -> [XmlTree] -> SignatureMethod
HS.SignatureMethod (SignatureAlgorithm -> IdentifiedURI SignatureAlgorithm
forall b a. a -> Identified b a
HS.Identified SignatureAlgorithm
HS.SignatureRSA_SHA256) Maybe Int
forall a. Maybe a
Nothing [],
              signedInfoReference :: NonEmpty Reference
signedInfoReference =
                Reference -> NonEmpty Reference
forall a. a -> NonEmpty a
NonEmpty.singleton
                  HS.Reference
                    { referenceId :: Maybe [Char]
referenceId = Maybe [Char]
forall a. Maybe a
Nothing,
                      referenceURI :: Maybe URI
referenceURI = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
reference,
                      referenceType :: Maybe URI
referenceType = Maybe URI
forall a. Maybe a
Nothing,
                      referenceTransforms :: Maybe Transforms
referenceTransforms = Maybe Transforms
transforms,
                      referenceDigestMethod :: DigestMethod
referenceDigestMethod = Identified URI DigestAlgorithm -> [XmlTree] -> DigestMethod
HS.DigestMethod (DigestAlgorithm -> Identified URI DigestAlgorithm
forall b a. a -> Identified b a
HS.Identified DigestAlgorithm
HS.DigestSHA256) [],
                      referenceDigestValue :: ByteString
referenceDigestValue = ByteString
digest
                    }
            }
    -- (note that there are two rounds of SHA256 application, hence two mentions of the has alg here)

    signedInfoSBS :: SBS <-
      either (throwError . show) (pure . cs) . unsafePerformIO . try @SomeException $
        HS.applyCanonicalization (HS.signedInfoCanonicalizationMethod signedInfo) Nothing $
          HS.samlToDoc signedInfo
    sigval :: SBS <-
      either (throwError . show @RSA.Error) pure
        =<< RSA.signSafer
          (Just Crypto.SHA256)
          (RSA.toPrivateKey keypair)
          signedInfoSBS
    let sig =
          HS.Signature
            { signatureId :: Maybe [Char]
signatureId = Maybe [Char]
forall a. Maybe a
Nothing :: Maybe HS.ID,
              signatureSignedInfo :: SignedInfo
signatureSignedInfo = SignedInfo
signedInfo :: HS.SignedInfo,
              signatureSignatureValue :: SignatureValue
signatureSignatureValue = Maybe [Char] -> ByteString -> SignatureValue
HS.SignatureValue Maybe [Char]
forall a. Maybe a
Nothing ByteString
sigval :: HS.SignatureValue,
              signatureKeyInfo :: Maybe KeyInfo
signatureKeyInfo = Maybe KeyInfo
forall a. Maybe a
Nothing :: Maybe HS.KeyInfo,
              signatureObject :: [Object]
signatureObject = []
            }
    unless (RSA.verify (Just Crypto.SHA256) (RSA.toPublicKey keypair) signedInfoSBS sigval) $
      throwError "signRoot: internal error: failed to verify my own signature!"
    injectSignedInfoAtRoot sigPos sig =<< hxtToConduit docInHXT

addRootIDIfMissing :: forall m. (MonadError String m, Crypto.MonadRandom m) => XML.Document -> m (XML.Document, URI)
addRootIDIfMissing :: forall (m :: * -> *).
(MonadError [Char] m, MonadRandom m) =>
Document -> m (Document, URI)
addRootIDIfMissing (XML.Document Prologue
prol (Element Name
tag Map Name Text
attrs [Node]
nodes) [Miscellaneous]
epil) = do
  (fresh, ref) <- m (Bool, Text)
-> (Text -> m (Bool, Text)) -> Maybe Text -> m (Bool, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Bool, Text)
makeID Text -> m (Bool, Text)
keepID (Maybe Text -> m (Bool, Text)) -> Maybe Text -> m (Bool, Text)
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"ID" Map Name Text
attrs
  uriref <- maybe (throwError "bad reference URI") pure . parseRelativeReference . cs $ "#" <> ref
  let updAttrs = if Bool
fresh then Name -> Text -> Map Name Text -> Map Name Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
"ID" Text
ref else Map Name Text -> Map Name Text
forall a. a -> a
id
  pure (XML.Document prol (Element tag (updAttrs attrs) nodes) epil, uriref)
  where
    makeID :: m (Bool, ST)
    makeID :: m (Bool, Text)
makeID = (Bool
True,) (Text -> (Bool, Text)) -> (UUID -> Text) -> UUID -> (Bool, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText (UUID -> (Bool, Text)) -> m UUID -> m (Bool, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m UUID
forall (m :: * -> *). MonadRandom m => m UUID
randomUUID
    keepID :: ST -> m (Bool, ST)
    keepID :: Text -> m (Bool, Text)
keepID = (Bool, Text) -> m (Bool, Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, Text) -> m (Bool, Text))
-> (Text -> (Bool, Text)) -> Text -> m (Bool, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
False,)

randomUUID :: (Crypto.MonadRandom m) => m UUID.UUID
randomUUID :: forall (m :: * -> *). MonadRandom m => m UUID
randomUUID = (UUID, StdGen) -> UUID
forall a b. (a, b) -> a
fst ((UUID, StdGen) -> UUID)
-> (Integer -> (UUID, StdGen)) -> Integer -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdGen -> (UUID, StdGen)
forall g. RandomGen g => g -> (UUID, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random (StdGen -> (UUID, StdGen))
-> (Integer -> StdGen) -> Integer -> (UUID, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StdGen
mkStdGen (Int -> StdGen) -> (Integer -> Int) -> Integer -> StdGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> UUID) -> m Integer -> m UUID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Integer
forall (m :: * -> *). MonadRandom m => m Integer
randomInteger

-- | (uses 64 bits of entropy)
randomInteger :: (Crypto.MonadRandom m) => m Integer
randomInteger :: forall (m :: * -> *). MonadRandom m => m Integer
randomInteger =
  ( Int -> m Bytes
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes Int
8
      m Bytes -> (Bytes -> [Word8]) -> m [Word8]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ByteArrayAccess a => a -> [Word8]
ByteArray.unpack @ByteArray.Bytes
  )
    m [Word8] -> ([Word8] -> Integer) -> m Integer
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Integer -> Integer -> Integer) -> Integer -> OID -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Integer
1 (OID -> Integer) -> ([Word8] -> OID) -> [Word8] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Integer) -> [Word8] -> OID
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

injectSignedInfoAtRoot :: (MonadError String m) => Int -> HS.Signature -> XML.Document -> m XML.Document
injectSignedInfoAtRoot :: forall (m :: * -> *).
MonadError [Char] m =>
Int -> Signature -> Document -> m Document
injectSignedInfoAtRoot Int
sigPos Signature
signedInfo (XML.Document Prologue
prol (Element Name
tag Map Name Text
attrs [Node]
nodes) [Miscellaneous]
epil) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sigPos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Node]
nodes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"child list too short: is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Node]
nodes) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", need " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sigPos)
  XML.Document _ signedInfoXML _ <- Signature -> m Document
forall (m :: * -> *) a.
(MonadError [Char] m, XmlPickler a) =>
a -> m Document
samlToConduit Signature
signedInfo
  pure $ XML.Document prol (Element tag attrs (insertAt sigPos (XML.NodeElement signedInfoXML) nodes)) epil
  where
    insertAt :: Int -> a -> [a] -> [a]
    insertAt :: forall a. Int -> a -> [a] -> [a]
insertAt Int
pos a
el [a]
els = case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
Prelude.splitAt Int
pos [a]
els of ([a]
prefix, [a]
suffix) -> [a]
prefix [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
el] [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
suffix

----------------------------------------------------------------------
-- testing

newtype MonadSign a = MonadSign {forall a. MonadSign a -> ExceptT [Char] IO a
runMonadSign' :: ExceptT String IO a}
  deriving ((forall a b. (a -> b) -> MonadSign a -> MonadSign b)
-> (forall a b. a -> MonadSign b -> MonadSign a)
-> Functor MonadSign
forall a b. a -> MonadSign b -> MonadSign a
forall a b. (a -> b) -> MonadSign a -> MonadSign b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MonadSign a -> MonadSign b
fmap :: forall a b. (a -> b) -> MonadSign a -> MonadSign b
$c<$ :: forall a b. a -> MonadSign b -> MonadSign a
<$ :: forall a b. a -> MonadSign b -> MonadSign a
Functor, Functor MonadSign
Functor MonadSign =>
(forall a. a -> MonadSign a)
-> (forall a b. MonadSign (a -> b) -> MonadSign a -> MonadSign b)
-> (forall a b c.
    (a -> b -> c) -> MonadSign a -> MonadSign b -> MonadSign c)
-> (forall a b. MonadSign a -> MonadSign b -> MonadSign b)
-> (forall a b. MonadSign a -> MonadSign b -> MonadSign a)
-> Applicative MonadSign
forall a. a -> MonadSign a
forall a b. MonadSign a -> MonadSign b -> MonadSign a
forall a b. MonadSign a -> MonadSign b -> MonadSign b
forall a b. MonadSign (a -> b) -> MonadSign a -> MonadSign b
forall a b c.
(a -> b -> c) -> MonadSign a -> MonadSign b -> MonadSign c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> MonadSign a
pure :: forall a. a -> MonadSign a
$c<*> :: forall a b. MonadSign (a -> b) -> MonadSign a -> MonadSign b
<*> :: forall a b. MonadSign (a -> b) -> MonadSign a -> MonadSign b
$cliftA2 :: forall a b c.
(a -> b -> c) -> MonadSign a -> MonadSign b -> MonadSign c
liftA2 :: forall a b c.
(a -> b -> c) -> MonadSign a -> MonadSign b -> MonadSign c
$c*> :: forall a b. MonadSign a -> MonadSign b -> MonadSign b
*> :: forall a b. MonadSign a -> MonadSign b -> MonadSign b
$c<* :: forall a b. MonadSign a -> MonadSign b -> MonadSign a
<* :: forall a b. MonadSign a -> MonadSign b -> MonadSign a
Applicative, Applicative MonadSign
Applicative MonadSign =>
(forall a b. MonadSign a -> (a -> MonadSign b) -> MonadSign b)
-> (forall a b. MonadSign a -> MonadSign b -> MonadSign b)
-> (forall a. a -> MonadSign a)
-> Monad MonadSign
forall a. a -> MonadSign a
forall a b. MonadSign a -> MonadSign b -> MonadSign b
forall a b. MonadSign a -> (a -> MonadSign b) -> MonadSign b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. MonadSign a -> (a -> MonadSign b) -> MonadSign b
>>= :: forall a b. MonadSign a -> (a -> MonadSign b) -> MonadSign b
$c>> :: forall a b. MonadSign a -> MonadSign b -> MonadSign b
>> :: forall a b. MonadSign a -> MonadSign b -> MonadSign b
$creturn :: forall a. a -> MonadSign a
return :: forall a. a -> MonadSign a
Monad)

runMonadSign :: MonadSign a -> IO (Either String a)
runMonadSign :: forall a. MonadSign a -> IO (Either [Char] a)
runMonadSign = ExceptT [Char] IO a -> IO (Either [Char] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Char] IO a -> IO (Either [Char] a))
-> (MonadSign a -> ExceptT [Char] IO a)
-> MonadSign a
-> IO (Either [Char] a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadSign a -> ExceptT [Char] IO a
forall a. MonadSign a -> ExceptT [Char] IO a
runMonadSign'

instance Crypto.MonadRandom MonadSign where
  getRandomBytes :: forall byteArray. ByteArray byteArray => Int -> MonadSign byteArray
getRandomBytes Int
l = ExceptT [Char] IO byteArray -> MonadSign byteArray
forall a. ExceptT [Char] IO a -> MonadSign a
MonadSign (ExceptT [Char] IO byteArray -> MonadSign byteArray)
-> (IO (Either [Char] byteArray) -> ExceptT [Char] IO byteArray)
-> IO (Either [Char] byteArray)
-> MonadSign byteArray
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either [Char] byteArray) -> ExceptT [Char] IO byteArray
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [Char] byteArray) -> MonadSign byteArray)
-> IO (Either [Char] byteArray) -> MonadSign byteArray
forall a b. (a -> b) -> a -> b
$ byteArray -> Either [Char] byteArray
forall a b. b -> Either a b
Right (byteArray -> Either [Char] byteArray)
-> IO byteArray -> IO (Either [Char] byteArray)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO byteArray
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes Int
l

instance MonadError String MonadSign where
  throwError :: forall a. [Char] -> MonadSign a
throwError = ExceptT [Char] IO a -> MonadSign a
forall a. ExceptT [Char] IO a -> MonadSign a
MonadSign (ExceptT [Char] IO a -> MonadSign a)
-> ([Char] -> ExceptT [Char] IO a) -> [Char] -> MonadSign a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ExceptT [Char] IO a
forall a. [Char] -> ExceptT [Char] IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. MonadSign a -> ([Char] -> MonadSign a) -> MonadSign a
catchError (MonadSign ExceptT [Char] IO a
m) [Char] -> MonadSign a
handler = ExceptT [Char] IO a -> MonadSign a
forall a. ExceptT [Char] IO a -> MonadSign a
MonadSign (ExceptT [Char] IO a -> MonadSign a)
-> ExceptT [Char] IO a -> MonadSign a
forall a b. (a -> b) -> a -> b
$ ExceptT [Char] IO a
m ExceptT [Char] IO a
-> ([Char] -> ExceptT [Char] IO a) -> ExceptT [Char] IO a
forall a.
ExceptT [Char] IO a
-> ([Char] -> ExceptT [Char] IO a) -> ExceptT [Char] IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (MonadSign a -> ExceptT [Char] IO a
forall a. MonadSign a -> ExceptT [Char] IO a
runMonadSign' (MonadSign a -> ExceptT [Char] IO a)
-> ([Char] -> MonadSign a) -> [Char] -> ExceptT [Char] IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> MonadSign a
handler)

type HasMonadSign = MonadIO

signElementIOAt :: (HasCallStack, HasMonadSign m) => Int -> SignPrivCreds -> [XML.Node] -> m [XML.Node]
signElementIOAt :: forall (m :: * -> *).
(HasCallStack, HasMonadSign m) =>
Int -> SignPrivCreds -> [Node] -> m [Node]
signElementIOAt Int
sigPos SignPrivCreds
creds [NodeElement Element
el] = do
  eNodes :: Either String [XML.Node] <-
    IO (Either [Char] [Node]) -> m (Either [Char] [Node])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] [Node]) -> m (Either [Char] [Node]))
-> (Element -> IO (Either [Char] [Node]))
-> Element
-> m (Either [Char] [Node])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadSign [Node] -> IO (Either [Char] [Node])
forall a. MonadSign a -> IO (Either [Char] a)
runMonadSign (MonadSign [Node] -> IO (Either [Char] [Node]))
-> (Element -> MonadSign [Node])
-> Element
-> IO (Either [Char] [Node])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Document -> [Node]) -> MonadSign Document -> MonadSign [Node]
forall a b. (a -> b) -> MonadSign a -> MonadSign b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => Document -> [Node]
Document -> [Node]
docToNodes (MonadSign Document -> MonadSign [Node])
-> (Element -> MonadSign Document) -> Element -> MonadSign [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SignPrivCreds -> Document -> MonadSign Document
forall (m :: * -> *).
(MonadRandom m, MonadError [Char] m) =>
Int -> SignPrivCreds -> Document -> m Document
signRootAt Int
sigPos SignPrivCreds
creds (Document -> MonadSign Document)
-> (Element -> Document) -> Element -> MonadSign Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Document
mkDocument (Element -> m (Either [Char] [Node]))
-> Element -> m (Either [Char] [Node])
forall a b. (a -> b) -> a -> b
$ Element
el
  either error pure eNodes
signElementIOAt Int
_ SignPrivCreds
_ [Node]
bad = IO [Node] -> m [Node]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Node] -> m [Node])
-> ([Node] -> IO [Node]) -> [Node] -> m [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> IO [Node]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ErrorCall -> IO [Node])
-> ([Node] -> ErrorCall) -> [Node] -> IO [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ErrorCall
ErrorCall ([Char] -> ErrorCall) -> ([Node] -> [Char]) -> [Node] -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Char]
forall a. Show a => a -> [Char]
show ([Node] -> m [Node]) -> [Node] -> m [Node]
forall a b. (a -> b) -> a -> b
$ [Node]
bad