{-# 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,
    mkSignCredsWithCertWithLifespan,

    -- * 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 Network.Wai.Utilities.Exception
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 (Eq, Show)

data SignDigest = SignDigestSha256
  deriving (Eq, Show, Bounded, Enum)

data SignKey = SignKeyRSA RSA.PublicKey
  deriving (Eq, Show)

data SignPrivCreds = SignPrivCreds SignDigest SignPrivKey
  deriving (Eq, Show)

data SignPrivKey = SignPrivKeyRSA RSA.KeyPair
  deriving (Eq, Show)

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

verifySelfSignature :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m ()
verifySelfSignature cert = do
  certToCreds cert >>= \case
    SignCreds SignDigestSha256 (SignKeyRSA pubkey) -> do
      let signedMessage = X509.getSignedData cert
          signatureValue = X509.signedSignature $ X509.getSigned cert
      unless (RSA.verify (Just Crypto.SHA256) pubkey signedMessage signatureValue) $
        throwError "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 doVerify (cs @LT @LBS -> lbs) = case HS.xmlToSAML @HS.KeyInfo =<< stripWhitespaceLBS lbs of
  Right keyinf -> case filter (not . ignorable) . toList $ HS.keyInfoElements keyinf of
    [HS.X509Data dt] ->
      parseX509Data dt
    [] ->
      throwError $ "KeyInfo element must contain X509Data"
    unsupported ->
      throwError $ "unsupported children in KeyInfo element: " <> show unsupported
  Left errmsg ->
    throwError $ "expected exactly one KeyInfo element: " <> errmsg
  where
    ignorable (HS.KeyName _) = True
    ignorable _ = False
    parseX509Data (HS.X509Certificate cert :| []) =
      when doVerify (verifySelfSignature cert) >> pure cert
    parseX509Data bad =
      throwError $ "data with more than one child: " <> show (toList bad)

-- | Call 'stripWhitespaceDoc' on a rendered bytestring.
stripWhitespaceLBS :: (m ~ Either String) => LBS -> m LBS
stripWhitespaceLBS lbs = renderLBS def . stripWhitespace <$> fmapL displayExceptionNoBacktrace (parseLBS def lbs)

renderKeyInfo :: (HasCallStack) => X509.SignedCertificate -> LT
renderKeyInfo cert = cs . ourSamlToXML . HS.KeyInfo Nothing $ NonEmpty.singleton (HS.X509Data (NonEmpty.singleton (HS.X509Certificate cert)))

certToCreds :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m SignCreds
certToCreds cert = do
  digest <- case X509.signedAlg $ X509.getSigned cert of
    X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA -> pure SignDigestSha256
    bad -> throwError $ "unsupported: " <> show bad
  key <- case X509.certPubKey . X509.signedObject $ X509.getSigned cert of
    X509.PubKeyRSA pk -> pure $ SignKeyRSA pk
    bad -> throwError $ "unsupported: " <> show bad
  pure $ SignCreds digest key

mkSignCreds :: (Crypto.MonadRandom m, MonadIO m) => Int -> m (SignPrivCreds, SignCreds)
mkSignCreds size = mkSignCredsWithCert Nothing size <&> \(priv, pub, _) -> (priv, pub)

-- | If first argument @validSince@ is @Nothing@, use current system time.
mkSignCredsWithCert ::
  forall m.
  (Crypto.MonadRandom m, MonadIO m) =>
  Maybe Hourglass.DateTime ->
  Int ->
  m (SignPrivCreds, SignCreds, X509.SignedCertificate)
mkSignCredsWithCert mValidSince size = do
  validSince :: Hourglass.DateTime <- maybe (liftIO Hourglass.dateCurrent) pure mValidSince
  let validUntil = validSince `Hourglass.timeAdd` mempty {Hourglass.durationHours = 24 * 365 * 20}
  mkSignCredsWithCertWithLifespan validSince validUntil size

-- | Generate signing credentials and a self-signed X509 certificate with the
-- given validity window.
mkSignCredsWithCertWithLifespan ::
  forall m.
  (Crypto.MonadRandom m, MonadIO m) =>
  Hourglass.DateTime ->
  Hourglass.DateTime ->
  Int ->
  m (SignPrivCreds, SignCreds, X509.SignedCertificate)
mkSignCredsWithCertWithLifespan validSinceRaw validUntilRaw size = do
  -- https://github.com/vincenthz/hs-certificate/issues/119
  let cropToSecs :: Hourglass.DateTime -> Hourglass.DateTime
      cropToSecs dt = dt {Hourglass.dtTime = (Hourglass.dtTime dt) {Hourglass.todNSec = 0}}
      validSince = cropToSecs validSinceRaw
      validUntil = cropToSecs validUntilRaw
  when (validSince > validUntil) . liftIO . throwIO . ErrorCall $
    "mkSignCredsWithCertWithLifespan: validSince > validUntil: "
      <> Hourglass.timePrint Hourglass.ISO8601_DateAndTime validSince
      <> " > "
      <> Hourglass.timePrint Hourglass.ISO8601_DateAndTime validUntil
  let rsaexp = 17
  (pubkey, privkey) <- RSA.generate size rsaexp
  let signcert :: SBS -> m (SBS, X509.SignatureALG)
      signcert sbs = (,sigalg) <$> sigval
        where
          sigalg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA
          sigval :: m SBS =
            liftIO $
              RSA.signSafer (Just Crypto.SHA256) privkey sbs
                >>= either (throwIO . ErrorCall . show) 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 creds el sid = case unsafePerformIO (try @SomeException $ verifyIO creds el sid) of
  Right (_, Right xml) -> pure xml
  Right (_, Left signErr) -> throwError $ show signErr
  Left exc -> throwError $ displayExceptionNoBacktrace 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 creds el = do
  signedID <- do
    XML.Document _ (XML.Element _ attrs _) _ <-
      either
        (throwError . ("Could not parse signed document: " <>) . cs . displayExceptionNoBacktrace)
        pure
        (XML.parseLBS XML.def 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 creds el sid = capture' $ do
  results <- NL.zip creds <$> forM creds (\cred -> verifyIO' cred el sid)
  case NL.filter (isRight . snd) results of
    [result] -> pure result
    _ -> throwIO . ErrorCall $ "all credentials failed to verify signature"
  where
    capture' :: IO a -> IO a
    capture' action =
      hCapture [stdout, stderr] action >>= \case
        ("", out) -> pure out
        (noise, _) -> throwIO . ErrorCall $ "noise on stdout/stderr from hsaml2 package: " <> noise

verifyIO' :: SignCreds -> LBS -> String -> IO (Either HS.SignatureError HXTC.XmlTree)
verifyIO' (SignCreds SignDigestSha256 (SignKeyRSA key)) el sid = runExceptT $ do
  el' <- either (throwError . HS.SignatureParseError) pure $ HS.xmlToDocE 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 pks xid doc = catchAll $ warpResult <$> verifySignature pks xid doc
  where
    catchAll :: IO (Either HS.SignatureError a) -> IO (Either HS.SignatureError a)
    catchAll = handle $ pure . Left . HS.SignatureVerificationLegacyFailure . Left . (displayExceptionNoBacktrace @SomeException)

    warpResult :: Maybe HXTC.XmlTree -> Either HS.SignatureError HXTC.XmlTree
    warpResult (Just xml) = Right xml
    warpResult Nothing = Left (HS.SignatureVerificationLegacyFailure (Right 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 pks xid doc = do
  let namespaces = DOM.toNsEnv $ HXTC.runLA HXTC.collectNamespaceDecl doc
  x <- case HXTC.runLA (getID xid HXTC.>>> HXTC.attachNsEnv namespaces) doc of
    [x] -> pure x
    _ -> fail "verifySignature: element not found"
  sx <- case child "Signature" x of
    [sx] -> pure sx
    _ -> fail "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 filter matchingId (toList results) of
        [(Right (_, xml))] -> Just xml
        _ -> Nothing
  let isSignatureValid = verifyBytes pks (HS.signatureMethodAlgorithm $ HS.signedInfoSignatureMethod si) (HS.signatureValue $ HS.signatureSignatureValue s) six
  pure $ case isSignatureValid of
    Just True -> mResult
    _ -> Nothing
  where
    matchingId :: Either String (String, HXTC.XmlTree) -> Bool
    matchingId (Right (xid', _)) = xid == xid'
    matchingId (Left _) = False

    child n = HXTC.runLA $ Arr.getChildren HXTC.>>> isDSElem n HXTC.>>> HXTC.cleanupNamespaces HXTC.collectPrefixUriPairs
    xpathsel t = "/*[local-name()='" ++ t ++ "' and namespace-uri()='" ++ HS.namespaceURIString HS.ns ++ "']"
    xpathbase = "/*" ++ xpathsel "Signature" ++ xpathsel "SignedInfo" ++ "//"
    xpath = xpathbase ++ ". | " ++ xpathbase ++ "@* | " ++ xpathbase ++ "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 HS.PublicKeys {publicKeyDSA = Just k} (HS.Identified HS.SignatureDSA_SHA1) sig m =
  Just $
    BS.length sig == 40
      && DSA.verify SHA1 k DSA.Signature {DSA.sign_r = os2ip r, DSA.sign_s = os2ip s} m
  where
    (r, s) = BS.splitAt 20 sig
verifyBytes HS.PublicKeys {publicKeyRSA = Just k} (HS.Identified HS.SignatureRSA_SHA1) sig m =
  Just $
    RSA.verify (Just SHA1) k m sig
verifyBytes HS.PublicKeys {publicKeyRSA = Just k} (HS.Identified HS.SignatureRSA_SHA256) sig m =
  Just $
    RSA.verify (Just SHA256) k m sig
verifyBytes _ _ _ _ = Nothing

isDSElem :: (HXTC.ArrowXml a) => String -> a HXTC.XmlTree HXTC.XmlTree
isDSElem n = HXTC.isElem HXTC.>>> HXTC.hasQName (HS.mkNName HS.ns n)

getID :: (HXTC.ArrowXml a) => String -> a HXTC.XmlTree HXTC.XmlTree
getID = HXTC.deep . HXTC.hasAttrValue "ID" . (==)

applyCanonicalization :: HS.CanonicalizationMethod -> Maybe String -> HXTC.XmlTree -> IO BS.ByteString
applyCanonicalization (HS.CanonicalizationMethod (HS.Identified a) ins []) x y = HS.canonicalize a ins x y
applyCanonicalization m _ _ = fail $ "applyCanonicalization: unsupported " ++ show m

applyTransformsBytes :: [HS.Transform] -> BSL.ByteString -> IO BSL.ByteString
applyTransformsBytes [] v = pure v
applyTransformsBytes (t : _) _ = fail ("applyTransforms: unsupported Signature " ++ show t)

applyTransformsXML :: [HS.Transform] -> HXTC.XmlTree -> IO BSL.ByteString
applyTransformsXML (HS.Transform (HS.Identified (HS.TransformCanonicalization a)) ins x : tl) =
  applyTransformsBytes tl . BSL.fromStrict
    <=< applyCanonicalization (HS.CanonicalizationMethod (HS.Identified a) ins (map (XP.pickleDoc XP.xpickle) x)) Nothing
applyTransformsXML (HS.Transform (HS.Identified HS.TransformEnvelopedSignature) Nothing [] : tl) =
  -- XXX assumes "this" signature in top-level
  applyTransformsXML tl
    . head
    . HXTC.runLA
      ( HXTC.processChildren $
          HXTC.processChildren $
            HXTC.neg (isDSElem "Signature")
      )
applyTransformsXML tl = applyTransformsBytes tl . xmlTreesToByteString . pure
  where
    xmlTreesToByteString :: HXTC.XmlTrees -> BSL.ByteString
    xmlTreesToByteString = ourDocToXMLWithoutRoot . (HXT.NTree (HXTC.XText "throw-me-away"))

applyTransforms :: Maybe HS.Transforms -> HXTC.XmlTree -> IO BSL.ByteString
applyTransforms = applyTransformsXML . maybe [] (NonEmpty.toList . HS.transforms)

applyDigest :: HS.DigestMethod -> BSL.ByteString -> BS.ByteString
applyDigest (HS.DigestMethod (HS.Identified HS.DigestSHA1) []) = BA.convert . hashlazy @SHA1
applyDigest (HS.DigestMethod (HS.Identified HS.DigestSHA256) []) = BA.convert . hashlazy @SHA256
applyDigest (HS.DigestMethod (HS.Identified HS.DigestSHA512) []) = BA.convert . hashlazy @SHA512
applyDigest (HS.DigestMethod (HS.Identified HS.DigestRIPEMD160) []) = BA.convert . hashlazy @RIPEMD160
applyDigest d = error $ "unsupported " ++ show 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 r doc = case HS.referenceURI r of
  Just URI {uriScheme = "", uriAuthority = Nothing, uriPath = "", uriQuery = "", uriFragment = '#' : xid} ->
    case HXTC.runLA (getID xid) doc of
      x@[result] -> do
        t :: BSL.ByteString <- applyTransforms (HS.referenceTransforms r) $ DOM.mkRoot [] x
        let have = applyDigest (HS.referenceDigestMethod r) t
            want = HS.referenceDigestValue r
        pure $
          if have == want
            then Right (xid, result)
            else Left $ "#" <> xid <> ": digest mismatch"
      bad -> pure . Left $ "#" <> xid <> ": has " <> show (length bad) <> " matches, should have 1."
  bad -> pure . Left $ "unexpected referenceURI: " <> show 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 sigPos (SignPrivCreds hashAlg (SignPrivKeyRSA keypair)) doc =
  do
    (docWithID :: XML.Document, reference) <- addRootIDIfMissing doc
    docInHXT <- conduitToHxt docWithID
    let canoAlg = HS.CanonicalXMLExcl10 True
        transforms =
          Just . HS.Transforms $
            HS.Transform
              { HS.transformAlgorithm = HS.Identified HS.TransformEnvelopedSignature,
                HS.transformInclusiveNamespaces = Nothing,
                HS.transform = []
              }
              :| [ HS.Transform
                     { HS.transformAlgorithm = HS.Identified (HS.TransformCanonicalization canoAlg),
                       HS.transformInclusiveNamespaces = Nothing,
                       HS.transform = []
                     }
                 ]
    docCanonic :: SBS <-
      either (throwError . displayExceptionNoBacktrace) (pure . cs) . unsafePerformIO . try @SomeException $
        HS.applyTransforms transforms (HXT.mkRoot [] [docInHXT])
    let digest :: SBS
        digest = case hashAlg of
          SignDigestSha256 -> ByteArray.convert $ Crypto.hash @SBS @Crypto.SHA256 docCanonic
    let signedInfo =
          HS.SignedInfo
            { signedInfoId = Nothing :: Maybe HS.ID,
              signedInfoCanonicalizationMethod = HS.CanonicalizationMethod (HS.Identified canoAlg) Nothing [],
              signedInfoSignatureMethod = HS.SignatureMethod (HS.Identified HS.SignatureRSA_SHA256) Nothing [],
              signedInfoReference =
                NonEmpty.singleton
                  HS.Reference
                    { referenceId = Nothing,
                      referenceURI = Just reference,
                      referenceType = Nothing,
                      referenceTransforms = transforms,
                      referenceDigestMethod = HS.DigestMethod (HS.Identified HS.DigestSHA256) [],
                      referenceDigestValue = digest
                    }
            }
    -- (note that there are two rounds of SHA256 application, hence two mentions of the has alg here)

    signedInfoSBS :: SBS <-
      either (throwError . displayExceptionNoBacktrace) (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 = Nothing :: Maybe HS.ID,
              signatureSignedInfo = signedInfo :: HS.SignedInfo,
              signatureSignatureValue = HS.SignatureValue Nothing sigval :: HS.SignatureValue,
              signatureKeyInfo = Nothing :: Maybe HS.KeyInfo,
              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 (XML.Document prol (Element tag attrs nodes) epil) = do
  (fresh, ref) <- maybe makeID keepID $ Map.lookup "ID" attrs
  uriref <- maybe (throwError "bad reference URI") pure . parseRelativeReference . cs $ "#" <> ref
  let updAttrs = if fresh then Map.insert "ID" ref else id
  pure (XML.Document prol (Element tag (updAttrs attrs) nodes) epil, uriref)
  where
    makeID :: m (Bool, ST)
    makeID = (True,) . UUID.toText <$> randomUUID
    keepID :: ST -> m (Bool, ST)
    keepID = pure . (False,)

randomUUID :: (Crypto.MonadRandom m) => m UUID.UUID
randomUUID = fst . random . mkStdGen . fromIntegral <$> randomInteger

-- | (uses 64 bits of entropy)
randomInteger :: (Crypto.MonadRandom m) => m Integer
randomInteger =
  ( Crypto.getRandomBytes 8
      <&> ByteArray.unpack @ByteArray.Bytes
  )
    <&> foldl' (*) 1 . fmap fromIntegral

injectSignedInfoAtRoot :: (MonadError String m) => Int -> HS.Signature -> XML.Document -> m XML.Document
injectSignedInfoAtRoot sigPos signedInfo (XML.Document prol (Element tag attrs nodes) epil) = do
  when (sigPos > Prelude.length nodes) $ do
    throwError ("child list too short: is " <> show (Prelude.length nodes) <> ", need " <> show sigPos)
  XML.Document _ signedInfoXML _ <- samlToConduit signedInfo
  pure $ XML.Document prol (Element tag attrs (insertAt sigPos (XML.NodeElement signedInfoXML) nodes)) epil
  where
    insertAt :: Int -> a -> [a] -> [a]
    insertAt pos el els = case Prelude.splitAt pos els of (prefix, suffix) -> prefix <> [el] <> suffix

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

newtype MonadSign a = MonadSign {runMonadSign' :: ExceptT String IO a}
  deriving (Functor, Applicative, Monad)

runMonadSign :: MonadSign a -> IO (Either String a)
runMonadSign = runExceptT . runMonadSign'

instance Crypto.MonadRandom MonadSign where
  getRandomBytes l = MonadSign . ExceptT $ Right <$> Crypto.getRandomBytes l

instance MonadError String MonadSign where
  throwError = MonadSign . throwError
  catchError (MonadSign m) handler = MonadSign $ m `catchError` (runMonadSign' . handler)

type HasMonadSign = MonadIO

signElementIOAt :: (HasCallStack, HasMonadSign m) => Int -> SignPrivCreds -> [XML.Node] -> m [XML.Node]
signElementIOAt sigPos creds [NodeElement el] = do
  eNodes :: Either String [XML.Node] <-
    liftIO . runMonadSign . fmap docToNodes . signRootAt sigPos creds . mkDocument $ el
  either error pure eNodes
signElementIOAt _ _ bad = liftIO . throwIO . ErrorCall . show $ bad
