{-# 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,
    certToPublicKey,
    mkSignCreds,
    mkSignCredsWithCert,

    -- * signature verification
    verify,
    verifyRoot,
    verifyIO,

    -- * signature creation
    signRoot,
    signRootAt,

    -- * testing
    HasMonadSign,
    MonadSign (MonadSign),
    runMonadSign,
    signElementIO,
    signElementIOAt,
  )
where

import Control.Exception (ErrorCall (ErrorCall), SomeException, throwIO, try)
import Control.Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Crypto.Hash as Crypto
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Crypto.PubKey.RSA.Types as RSA
import qualified Crypto.Random.Types as Crypto
import qualified Data.ByteArray as ByteArray
import Data.Either (isRight)
import Data.EitherR (fmapL)
import Data.Foldable (toList)
import qualified Data.Hourglass as Hourglass
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NL
import qualified Data.Map as Map
import Data.String.Conversions
import Data.UUID as UUID
import qualified Data.X509 as X509
import GHC.Stack
import Network.URI (URI, parseRelativeReference)
import qualified SAML2.XML as HS hiding (Node, URI)
import qualified SAML2.XML.Canonical as HS
import qualified SAML2.XML.Signature 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 qualified Text.XML.HXT.DOM.XmlNode as HXT
import Text.XML.Util
import qualified Time.System 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 -> String
(Int -> SignCreds -> ShowS)
-> (SignCreds -> String)
-> ([SignCreds] -> ShowS)
-> Show SignCreds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignCreds -> ShowS
showsPrec :: Int -> SignCreds -> ShowS
$cshow :: SignCreds -> String
show :: SignCreds -> String
$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 -> String
(Int -> SignDigest -> ShowS)
-> (SignDigest -> String)
-> ([SignDigest] -> ShowS)
-> Show SignDigest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignDigest -> ShowS
showsPrec :: Int -> SignDigest -> ShowS
$cshow :: SignDigest -> String
show :: SignDigest -> String
$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 -> String
(Int -> SignKey -> ShowS)
-> (SignKey -> String) -> ([SignKey] -> ShowS) -> Show SignKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignKey -> ShowS
showsPrec :: Int -> SignKey -> ShowS
$cshow :: SignKey -> String
show :: SignKey -> String
$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 -> String
(Int -> SignPrivCreds -> ShowS)
-> (SignPrivCreds -> String)
-> ([SignPrivCreds] -> ShowS)
-> Show SignPrivCreds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignPrivCreds -> ShowS
showsPrec :: Int -> SignPrivCreds -> ShowS
$cshow :: SignPrivCreds -> String
show :: SignPrivCreds -> String
$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 -> String
(Int -> SignPrivKey -> ShowS)
-> (SignPrivKey -> String)
-> ([SignPrivKey] -> ShowS)
-> Show SignPrivKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SignPrivKey -> ShowS
showsPrec :: Int -> SignPrivKey -> ShowS
$cshow :: SignPrivKey -> String
show :: SignPrivKey -> String
$cshowList :: [SignPrivKey] -> ShowS
showList :: [SignPrivKey] -> ShowS
Show)

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

verifySelfSignature :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m ()
verifySelfSignature :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SignedCertificate -> m ()
verifySelfSignature SignedCertificate
cert = do
  SignedCertificate -> m SignCreds
forall (m :: * -> *).
(HasCallStack, MonadError String 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
$
        String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"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 String 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 String a
HS.xmlToSAML @HS.KeyInfo (LBS -> Either String KeyInfo)
-> Either String LBS -> Either String KeyInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LBS -> Either String LBS
forall (m :: * -> *). (m ~ Either String) => 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
    [] ->
      String -> m SignedCertificate
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignedCertificate) -> String -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ String
"KeyInfo element must contain X509Data"
    [KeyInfoElement]
unsupported ->
      String -> m SignedCertificate
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignedCertificate) -> String -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ String
"unsupported children in KeyInfo element: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [KeyInfoElement] -> String
forall a. Show a => a -> String
show [KeyInfoElement]
unsupported
  Left String
errmsg ->
    String -> m SignedCertificate
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignedCertificate) -> String -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ String
"expected exactly one KeyInfo element: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
errmsg
  where
    ignorable :: KeyInfoElement -> Bool
ignorable (HS.KeyName String
_) = 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 String 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 =
      String -> m SignedCertificate
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignedCertificate) -> String -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ String
"data with more than one child: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [X509Element] -> String
forall a. Show a => a -> String
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 String) => 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 -> String)
-> Either SomeException Document -> Either String Document
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL SomeException -> String
forall a. Show a => a -> String
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
HS.samlToXML (KeyInfo -> LBS)
-> (List1 KeyInfoElement -> KeyInfo) -> List1 KeyInfoElement -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> List1 KeyInfoElement -> KeyInfo
HS.KeyInfo Maybe String
forall a. Maybe a
Nothing (List1 KeyInfoElement -> LT) -> List1 KeyInfoElement -> LT
forall a b. (a -> b) -> a -> b
$ List1 X509Element -> KeyInfoElement
HS.X509Data (SignedCertificate -> X509Element
HS.X509Certificate SignedCertificate
cert X509Element -> [X509Element] -> List1 X509Element
forall a. a -> [a] -> NonEmpty a
:| []) KeyInfoElement -> [KeyInfoElement] -> List1 KeyInfoElement
forall a. a -> [a] -> NonEmpty a
:| []

certToCreds :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m SignCreds
certToCreds :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SignedCertificate -> m SignCreds
certToCreds SignedCertificate
cert = do
  SignDigest
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 -> String -> m SignDigest
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignDigest) -> String -> m SignDigest
forall a b. (a -> b) -> a -> b
$ String
"unsupported: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SignatureALG -> String
forall a. Show a => a -> String
show SignatureALG
bad
  SignKey
key <- case Certificate -> PubKey
X509.certPubKey (Certificate -> PubKey)
-> (Signed Certificate -> Certificate)
-> Signed Certificate
-> PubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X509.signedObject (Signed Certificate -> PubKey) -> Signed Certificate -> PubKey
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.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 -> String -> m SignKey
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignKey) -> String -> m SignKey
forall a b. (a -> b) -> a -> b
$ String
"unsupported: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PubKey -> String
forall a. Show a => a -> String
show PubKey
bad
  SignCreds -> m SignCreds
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignCreds -> m SignCreds) -> SignCreds -> m SignCreds
forall a b. (a -> b) -> a -> b
$ SignDigest -> SignKey -> SignCreds
SignCreds SignDigest
digest SignKey
key

certToPublicKey :: (HasCallStack, MonadError String m) => X509.SignedCertificate -> m RSA.PublicKey
certToPublicKey :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SignedCertificate -> m PublicKey
certToPublicKey SignedCertificate
cert = SignedCertificate -> m SignCreds
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SignedCertificate -> m SignCreds
certToCreds SignedCertificate
cert m SignCreds -> (SignCreds -> PublicKey) -> m PublicKey
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SignCreds SignDigest
_ (SignKeyRSA PublicKey
key)) -> PublicKey
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
  (PublicKey
pubkey, PrivateKey
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 -> DateTime
cropToSecs DateTime
dt = DateTime
dt {Hourglass.dtTime = (Hourglass.dtTime dt) {Hourglass.todNSec = 0}}
  DateTime
validSince :: Hourglass.DateTime <- DateTime -> DateTime
cropToSecs (DateTime -> DateTime) -> m DateTime -> m DateTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DateTime
-> (DateTime -> m DateTime) -> Maybe DateTime -> m DateTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO DateTime -> m DateTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO DateTime
Hourglass.dateCurrent) DateTime -> m DateTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DateTime
mValidSince
  let validUntil :: DateTime
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 -> m (ByteString, 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. Exception e => e -> IO a
throwIO (ErrorCall -> IO ByteString)
-> (Error -> ErrorCall) -> Error -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall) -> (Error -> String) -> Error -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show) ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  SignedCertificate
cert <-
    (ByteString -> m (ByteString, SignatureALG))
-> Certificate -> m SignedCertificate
forall (f :: * -> *) a.
(Functor f, Show a, Eq a, ASN1Object a) =>
(ByteString -> f (ByteString, SignatureALG))
-> a -> f (SignedExact a)
X509.objectToSignedExactF
      ByteString -> m (ByteString, SignatureALG)
signcert
      X509.Certificate
        { certVersion :: Int
X509.certVersion = Int
2 :: Int,
          certSerial :: Integer
X509.certSerial = Integer
387928798798718181888591698169861 :: Integer,
          certSignatureAlg :: SignatureALG
X509.certSignatureAlg = HashALG -> PubKeyALG -> SignatureALG
X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_RSA,
          certIssuerDN :: DistinguishedName
X509.certIssuerDN = [(OID, ASN1CharacterString)] -> DistinguishedName
X509.DistinguishedName [],
          certValidity :: (DateTime, DateTime)
X509.certValidity = (DateTime
validSince, DateTime
validUntil),
          certSubjectDN :: DistinguishedName
X509.certSubjectDN = [(OID, ASN1CharacterString)] -> DistinguishedName
X509.DistinguishedName [],
          certPubKey :: PubKey
X509.certPubKey = PublicKey -> PubKey
X509.PubKeyRSA PublicKey
pubkey,
          certExtensions :: Extensions
X509.certExtensions = Maybe [ExtensionRaw] -> Extensions
X509.Extensions Maybe [ExtensionRaw]
forall a. Maybe a
Nothing
        }
  (SignPrivCreds, SignCreds, SignedCertificate)
-> m (SignPrivCreds, SignCreds, SignedCertificate)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( SignDigest -> SignPrivKey -> SignPrivCreds
SignPrivCreds SignDigest
SignDigestSha256 (SignPrivKey -> SignPrivCreds)
-> (KeyPair -> SignPrivKey) -> KeyPair -> SignPrivCreds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair -> SignPrivKey
SignPrivKeyRSA (KeyPair -> SignPrivCreds) -> KeyPair -> SignPrivCreds
forall a b. (a -> b) -> a -> b
$ PrivateKey -> KeyPair
RSA.KeyPair PrivateKey
privkey,
      SignDigest -> SignKey -> SignCreds
SignCreds SignDigest
SignDigestSha256 (SignKey -> SignCreds)
-> (PublicKey -> SignKey) -> PublicKey -> SignCreds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> SignKey
SignKeyRSA (PublicKey -> SignCreds) -> PublicKey -> SignCreds
forall a b. (a -> b) -> a -> b
$ PublicKey
pubkey,
      SignedCertificate
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 ()
verify :: forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> LBS -> String -> m ()
verify NonEmpty SignCreds
creds LBS
el String
signedID = case IO (Either SomeException [(SignCreds, Either SignatureError ())])
-> Either SomeException [(SignCreds, Either SignatureError ())]
forall a. IO a -> a
unsafePerformIO (forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO [(SignCreds, Either SignatureError ())]
 -> IO
      (Either SomeException [(SignCreds, Either SignatureError ())]))
-> IO [(SignCreds, Either SignatureError ())]
-> IO
     (Either SomeException [(SignCreds, Either SignatureError ())])
forall a b. (a -> b) -> a -> b
$ NonEmpty SignCreds
-> LBS -> String -> IO [(SignCreds, Either SignatureError ())]
verifyIO NonEmpty SignCreds
creds LBS
el String
signedID) of
  Right [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Right [(SignCreds, Either SignatureError ())]
errs -> String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [Either SignatureError ()] -> String
forall a. Show a => a -> String
show ((SignCreds, Either SignatureError ()) -> Either SignatureError ()
forall a b. (a, b) -> b
snd ((SignCreds, Either SignatureError ()) -> Either SignatureError ())
-> [(SignCreds, Either SignatureError ())]
-> [Either SignatureError ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SignCreds, Either SignatureError ())]
errs)
  Left SomeException
exc -> String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
exc

verifyRoot :: forall m. (MonadError String m) => NonEmpty SignCreds -> LBS -> m ()
verifyRoot :: forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> LBS -> m ()
verifyRoot NonEmpty SignCreds
creds LBS
el = do
  String
signedID <- do
    XML.Document Prologue
_ (XML.Element Name
_ Map Name Text
attrs [Node]
_) [Miscellaneous]
_ <-
      (SomeException -> m Document)
-> (Document -> m Document)
-> Either SomeException Document
-> m Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (String -> m Document
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Document)
-> (SomeException -> String) -> SomeException -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Could not parse signed document: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ShowS -> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
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)
    m String -> (Text -> m String) -> Maybe Text -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (String -> m String
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Could not parse signed document: no ID attribute in root element." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LBS -> String
forall a. Show a => a -> String
show LBS
el)
      (String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> (Text -> String) -> Text -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs)
      (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)
  NonEmpty SignCreds -> LBS -> String -> m ()
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> LBS -> String -> m ()
verify NonEmpty SignCreds
creds LBS
el String
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 ())]
verifyIO :: NonEmpty SignCreds
-> LBS -> String -> IO [(SignCreds, Either SignatureError ())]
verifyIO NonEmpty SignCreds
creds LBS
el String
signedID = IO [(SignCreds, Either SignatureError ())]
-> IO [(SignCreds, Either SignatureError ())]
forall a. IO a -> IO a
capture' (IO [(SignCreds, Either SignatureError ())]
 -> IO [(SignCreds, Either SignatureError ())])
-> IO [(SignCreds, Either SignatureError ())]
-> IO [(SignCreds, Either SignatureError ())]
forall a b. (a -> b) -> a -> b
$ do
  NonEmpty (SignCreds, Either SignatureError ())
results <- NonEmpty SignCreds
-> NonEmpty (Either SignatureError ())
-> NonEmpty (SignCreds, Either SignatureError ())
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NL.zip NonEmpty SignCreds
creds (NonEmpty (Either SignatureError ())
 -> NonEmpty (SignCreds, Either SignatureError ()))
-> IO (NonEmpty (Either SignatureError ()))
-> IO (NonEmpty (SignCreds, Either SignatureError ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SignCreds
-> (SignCreds -> IO (Either SignatureError ()))
-> IO (NonEmpty (Either SignatureError ()))
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 -> String -> IO (Either SignatureError ())
verifyIO' SignCreds
cred LBS
el String
signedID)
  case ((SignCreds, Either SignatureError ()) -> Bool)
-> NonEmpty (SignCreds, Either SignatureError ())
-> [(SignCreds, Either SignatureError ())]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NL.filter (Either SignatureError () -> Bool
forall a b. Either a b -> Bool
isRight (Either SignatureError () -> Bool)
-> ((SignCreds, Either SignatureError ())
    -> Either SignatureError ())
-> (SignCreds, Either SignatureError ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SignCreds, Either SignatureError ()) -> Either SignatureError ()
forall a b. (a, b) -> b
snd) NonEmpty (SignCreds, Either SignatureError ())
results of
    ((SignCreds, Either SignatureError ())
_ : [(SignCreds, Either SignatureError ())]
_) -> [(SignCreds, Either SignatureError ())]
-> IO [(SignCreds, Either SignatureError ())]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    [] -> [(SignCreds, Either SignatureError ())]
-> IO [(SignCreds, Either SignatureError ())]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(SignCreds, Either SignatureError ())]
 -> IO [(SignCreds, Either SignatureError ())])
-> [(SignCreds, Either SignatureError ())]
-> IO [(SignCreds, Either SignatureError ())]
forall a b. (a -> b) -> a -> b
$ NonEmpty (SignCreds, Either SignatureError ())
-> [(SignCreds, Either SignatureError ())]
forall a. NonEmpty a -> [a]
NL.toList NonEmpty (SignCreds, Either SignatureError ())
results
  where
    capture' :: IO a -> IO a
    capture' :: forall a. IO a -> IO a
capture' IO a
action =
      [Handle] -> IO a -> IO (String, a)
forall a. [Handle] -> IO a -> IO (String, a)
hCapture [Handle
stdout, Handle
stderr] IO a
action IO (String, a) -> ((String, 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
        (String
"", a
out) -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
out
        (String
noise, a
_) -> ErrorCall -> IO a
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO a) -> (String -> ErrorCall) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"noise on stdout/stderr from hsaml2 package: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
noise

verifyIO' :: SignCreds -> LBS -> String -> IO (Either HS.SignatureError ())
verifyIO' :: SignCreds -> LBS -> String -> IO (Either SignatureError ())
verifyIO' (SignCreds SignDigest
SignDigestSha256 (SignKeyRSA PublicKey
key)) LBS
el String
signedID = ExceptT SignatureError IO () -> IO (Either SignatureError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SignatureError IO () -> IO (Either SignatureError ()))
-> ExceptT SignatureError IO () -> IO (Either SignatureError ())
forall a b. (a -> b) -> a -> b
$ do
  XmlTree
el' <- (String -> ExceptT SignatureError IO XmlTree)
-> (XmlTree -> ExceptT SignatureError IO XmlTree)
-> Either String 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)
-> (String -> SignatureError)
-> String
-> ExceptT SignatureError IO XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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 String XmlTree -> ExceptT SignatureError IO XmlTree)
-> Either String XmlTree -> ExceptT SignatureError IO XmlTree
forall a b. (a -> b) -> a -> b
$ LBS -> Either String XmlTree
HS.xmlToDocE LBS
el
  IO (Either SignatureError ()) -> ExceptT SignatureError IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SignatureError ()) -> ExceptT SignatureError IO ())
-> IO (Either SignatureError ()) -> ExceptT SignatureError IO ()
forall a b. (a -> b) -> a -> b
$ PublicKeys -> String -> XmlTree -> IO (Either SignatureError ())
HS.verifySignatureUnenvelopedSigs (Maybe PublicKey -> Maybe PublicKey -> PublicKeys
HS.PublicKeys Maybe PublicKey
forall a. Maybe a
Nothing (Maybe PublicKey -> PublicKeys)
-> (PublicKey -> Maybe PublicKey) -> PublicKey -> PublicKeys
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> Maybe PublicKey
forall a. a -> Maybe a
Just (PublicKey -> PublicKeys) -> PublicKey -> PublicKeys
forall a b. (a -> b) -> a -> b
$ PublicKey
key) String
signedID XmlTree
el'

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

-- | Make sure that root node node has ID attribute and sign it.  This is similar to the more
-- primitive 'HS.generateSignature'.  Cons signature to the children list (left-most position).
signRoot :: (Crypto.MonadRandom m, MonadError String m) => SignPrivCreds -> XML.Document -> m XML.Document
signRoot :: forall (m :: * -> *).
(MonadRandom m, MonadError String m) =>
SignPrivCreds -> Document -> m Document
signRoot = Int -> SignPrivCreds -> Document -> m Document
forall (m :: * -> *).
(MonadRandom m, MonadError String m) =>
Int -> SignPrivCreds -> Document -> m Document
signRootAt Int
0

-- | 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 String m) =>
Int -> SignPrivCreds -> Document -> m Document
signRootAt Int
sigPos (SignPrivCreds SignDigest
hashAlg (SignPrivKeyRSA KeyPair
keypair)) Document
doc =
  do
    (Document
docWithID :: XML.Document, URI
reference) <- Document -> m (Document, URI)
forall (m :: * -> *).
(MonadError String m, MonadRandom m) =>
Document -> m (Document, URI)
addRootIDIfMissing Document
doc
    XmlTree
docInHXT <- Document -> m XmlTree
forall (m :: * -> *). MonadError String m => Document -> m XmlTree
conduitToHxt Document
docWithID
    let canoAlg :: CanonicalizationAlgorithm
canoAlg = Bool -> CanonicalizationAlgorithm
HS.CanonicalXMLExcl10 Bool
True
        transforms :: Maybe Transforms
transforms =
          Transforms -> Maybe Transforms
forall a. a -> Maybe a
Just (Transforms -> Maybe Transforms)
-> (List1 Transform -> Transforms)
-> List1 Transform
-> Maybe Transforms
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Transform -> Transforms
HS.Transforms (List1 Transform -> Maybe Transforms)
-> List1 Transform -> Maybe Transforms
forall a b. (a -> b) -> a -> b
$
            HS.Transform
              { transformAlgorithm :: IdentifiedURI TransformAlgorithm
HS.transformAlgorithm = TransformAlgorithm -> IdentifiedURI 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] -> List1 Transform
forall a. a -> [a] -> NonEmpty a
:| [ HS.Transform
                     { transformAlgorithm :: IdentifiedURI TransformAlgorithm
HS.transformAlgorithm = TransformAlgorithm -> IdentifiedURI 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 = []
                     }
                 ]
    ByteString
docCanonic :: SBS <-
      (SomeException -> m ByteString)
-> (LBS -> m ByteString)
-> Either SomeException LBS
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ByteString)
-> (SomeException -> String) -> SomeException -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) (ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString)
-> (LBS -> ByteString) -> LBS -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBS -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs) (Either SomeException LBS -> m ByteString)
-> (IO LBS -> Either SomeException LBS) -> IO LBS -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SomeException LBS) -> Either SomeException LBS
forall a. IO a -> a
unsafePerformIO (IO (Either SomeException LBS) -> Either SomeException LBS)
-> (IO LBS -> IO (Either SomeException LBS))
-> IO LBS
-> Either SomeException LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO LBS -> m ByteString) -> IO LBS -> m ByteString
forall a b. (a -> b) -> a -> b
$
        Maybe Transforms -> XmlTree -> IO LBS
HS.applyTransforms Maybe Transforms
transforms (XmlTrees -> XmlTrees -> XmlTree
HXT.mkRoot [] [XmlTree
docInHXT])
    let digest :: SBS
        digest :: ByteString
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 :: SignedInfo
signedInfo =
          HS.SignedInfo
            { signedInfoId :: Maybe String
signedInfoId = Maybe String
forall a. Maybe a
Nothing :: Maybe HS.ID,
              signedInfoCanonicalizationMethod :: CanonicalizationMethod
signedInfoCanonicalizationMethod = IdentifiedURI CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces -> XmlTrees -> CanonicalizationMethod
HS.CanonicalizationMethod (CanonicalizationAlgorithm
-> IdentifiedURI 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 -> XmlTrees -> 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 :: List1 Reference
signedInfoReference =
                HS.Reference
                  { referenceId :: Maybe String
referenceId = Maybe String
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 = IdentifiedURI DigestAlgorithm -> XmlTrees -> DigestMethod
HS.DigestMethod (DigestAlgorithm -> IdentifiedURI DigestAlgorithm
forall b a. a -> Identified b a
HS.Identified DigestAlgorithm
HS.DigestSHA256) [],
                    referenceDigestValue :: ByteString
referenceDigestValue = ByteString
digest
                  }
                  Reference -> [Reference] -> List1 Reference
forall a. a -> [a] -> NonEmpty a
:| []
            }
    -- (note that there are two rounds of SHA256 application, hence two mentions of the has alg here)

    ByteString
signedInfoSBS :: SBS <-
      (SomeException -> m ByteString)
-> (ByteString -> m ByteString)
-> Either SomeException ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ByteString)
-> (SomeException -> String) -> SomeException -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) (ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString)
-> (ByteString -> ByteString) -> ByteString -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs) (Either SomeException ByteString -> m ByteString)
-> (IO ByteString -> Either SomeException ByteString)
-> IO ByteString
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SomeException ByteString)
-> Either SomeException ByteString
forall a. IO a -> a
unsafePerformIO (IO (Either SomeException ByteString)
 -> Either SomeException ByteString)
-> (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString
-> Either SomeException ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$
        CanonicalizationMethod -> Maybe String -> XmlTree -> IO ByteString
HS.applyCanonicalization (SignedInfo -> CanonicalizationMethod
HS.signedInfoCanonicalizationMethod SignedInfo
signedInfo) Maybe String
forall a. Maybe a
Nothing (XmlTree -> IO ByteString) -> XmlTree -> IO ByteString
forall a b. (a -> b) -> a -> b
$
          SignedInfo -> XmlTree
forall a. XmlPickler a => a -> XmlTree
HS.samlToDoc SignedInfo
signedInfo
    ByteString
sigval :: SBS <-
      (Error -> m ByteString)
-> (ByteString -> m ByteString)
-> Either Error ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m ByteString
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ByteString)
-> (Error -> String) -> Error -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @RSA.Error) ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either Error ByteString -> m ByteString)
-> m (Either Error ByteString) -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe SHA256
-> PrivateKey -> ByteString -> m (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)
          (KeyPair -> PrivateKey
RSA.toPrivateKey KeyPair
keypair)
          ByteString
signedInfoSBS
    let sig :: Signature
sig =
          HS.Signature
            { signatureId :: Maybe String
signatureId = Maybe String
forall a. Maybe a
Nothing :: Maybe HS.ID,
              signatureSignedInfo :: SignedInfo
signatureSignedInfo = SignedInfo
signedInfo :: HS.SignedInfo,
              signatureSignatureValue :: SignatureValue
signatureSignatureValue = Maybe String -> ByteString -> SignatureValue
HS.SignatureValue Maybe String
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 = []
            }
    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) (KeyPair -> PublicKey
RSA.toPublicKey KeyPair
keypair) ByteString
signedInfoSBS ByteString
sigval) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"signRoot: internal error: failed to verify my own signature!"
    Int -> Signature -> Document -> m Document
forall (m :: * -> *).
MonadError String m =>
Int -> Signature -> Document -> m Document
injectSignedInfoAtRoot Int
sigPos Signature
sig (Document -> m Document) -> m Document -> m Document
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XmlTree -> m Document
forall (m :: * -> *). MonadError String m => XmlTree -> m Document
hxtToConduit XmlTree
docInHXT

addRootIDIfMissing :: forall m. (MonadError String m, Crypto.MonadRandom m) => XML.Document -> m (XML.Document, URI)
addRootIDIfMissing :: forall (m :: * -> *).
(MonadError String m, MonadRandom m) =>
Document -> m (Document, URI)
addRootIDIfMissing (XML.Document Prologue
prol (Element Name
tag Map Name Text
attrs [Node]
nodes) [Miscellaneous]
epil) = do
  (Bool
fresh, Text
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
  URI
uriref <- m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m URI
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"bad reference URI") URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe URI -> m URI) -> (Text -> Maybe URI) -> Text -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe URI
parseRelativeReference (String -> Maybe URI) -> (Text -> String) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> m URI) -> Text -> m URI
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref
  let updAttrs :: Map Name Text -> Map Name Text
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
  (Document, URI) -> m (Document, URI)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Prologue -> Element -> [Miscellaneous] -> Document
XML.Document Prologue
prol (Name -> Map Name Text -> [Node] -> Element
Element Name
tag (Map Name Text -> Map Name Text
updAttrs Map Name Text
attrs) [Node]
nodes) [Miscellaneous]
epil, URI
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] -> OID) -> m OID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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
    m OID -> (OID -> 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

injectSignedInfoAtRoot :: (MonadError String m) => Int -> HS.Signature -> XML.Document -> m XML.Document
injectSignedInfoAtRoot :: forall (m :: * -> *).
MonadError String 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
    String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"child list too short: is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Node]
nodes) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", need " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
sigPos)
  XML.Document Prologue
_ Element
signedInfoXML [Miscellaneous]
_ <- Signature -> m Document
forall (m :: * -> *) a.
(MonadError String m, XmlPickler a) =>
a -> m Document
samlToConduit Signature
signedInfo
  Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document -> m Document) -> Document -> m Document
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
XML.Document Prologue
prol (Name -> Map Name Text -> [Node] -> Element
Element Name
tag Map Name Text
attrs (Int -> Node -> [Node] -> [Node]
forall a. Int -> a -> [a] -> [a]
insertAt Int
sigPos (Element -> Node
XML.NodeElement Element
signedInfoXML) [Node]
nodes)) [Miscellaneous]
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 String 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 String a)
runMonadSign = ExceptT String IO a -> IO (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO a -> IO (Either String a))
-> (MonadSign a -> ExceptT String IO a)
-> MonadSign a
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadSign a -> ExceptT String IO a
forall a. MonadSign a -> ExceptT String IO a
runMonadSign'

instance Crypto.MonadRandom MonadSign where
  getRandomBytes :: forall byteArray. ByteArray byteArray => Int -> MonadSign byteArray
getRandomBytes Int
l = ExceptT String IO byteArray -> MonadSign byteArray
forall a. ExceptT String IO a -> MonadSign a
MonadSign (ExceptT String IO byteArray -> MonadSign byteArray)
-> (IO (Either String byteArray) -> ExceptT String IO byteArray)
-> IO (Either String byteArray)
-> MonadSign byteArray
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either String byteArray) -> ExceptT String IO byteArray
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String byteArray) -> MonadSign byteArray)
-> IO (Either String byteArray) -> MonadSign byteArray
forall a b. (a -> b) -> a -> b
$ byteArray -> Either String byteArray
forall a b. b -> Either a b
Right (byteArray -> Either String byteArray)
-> IO byteArray -> IO (Either String 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. String -> MonadSign a
throwError = ExceptT String IO a -> MonadSign a
forall a. ExceptT String IO a -> MonadSign a
MonadSign (ExceptT String IO a -> MonadSign a)
-> (String -> ExceptT String IO a) -> String -> MonadSign a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String IO a
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. MonadSign a -> (String -> MonadSign a) -> MonadSign a
catchError (MonadSign ExceptT String IO a
m) String -> MonadSign a
handler = ExceptT String IO a -> MonadSign a
forall a. ExceptT String IO a -> MonadSign a
MonadSign (ExceptT String IO a -> MonadSign a)
-> ExceptT String IO a -> MonadSign a
forall a b. (a -> b) -> a -> b
$ ExceptT String IO a
m ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall a.
ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (MonadSign a -> ExceptT String IO a
forall a. MonadSign a -> ExceptT String IO a
runMonadSign' (MonadSign a -> ExceptT String IO a)
-> (String -> MonadSign a) -> String -> ExceptT String IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MonadSign a
handler)

type HasMonadSign = MonadIO

signElementIO :: (HasCallStack, HasMonadSign m) => SignPrivCreds -> [Node] -> m [Node]
signElementIO :: forall (m :: * -> *).
(HasCallStack, HasMonadSign m) =>
SignPrivCreds -> [Node] -> m [Node]
signElementIO = Int -> SignPrivCreds -> [Node] -> m [Node]
forall (m :: * -> *).
(HasCallStack, HasMonadSign m) =>
Int -> SignPrivCreds -> [Node] -> m [Node]
signElementIOAt Int
0

signElementIOAt :: (HasCallStack, HasMonadSign m) => Int -> SignPrivCreds -> [Node] -> m [Node]
signElementIOAt :: forall (m :: * -> *).
(HasCallStack, HasMonadSign m) =>
Int -> SignPrivCreds -> [Node] -> m [Node]
signElementIOAt Int
sigPos SignPrivCreds
creds [NodeElement Element
el] = do
  Either String [Node]
eNodes :: Either String [Node] <-
    IO (Either String [Node]) -> m (Either String [Node])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String [Node]) -> m (Either String [Node]))
-> (Element -> IO (Either String [Node]))
-> Element
-> m (Either String [Node])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonadSign [Node] -> IO (Either String [Node])
forall a. MonadSign a -> IO (Either String a)
runMonadSign (MonadSign [Node] -> IO (Either String [Node]))
-> (Element -> MonadSign [Node])
-> Element
-> IO (Either String [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 String 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 String [Node]))
-> Element -> m (Either String [Node])
forall a b. (a -> b) -> a -> b
$ Element
el
  (String -> m [Node])
-> ([Node] -> m [Node]) -> Either String [Node] -> m [Node]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m [Node]
forall a. HasCallStack => String -> a
error [Node] -> m [Node]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String [Node]
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. Exception e => e -> IO a
throwIO (ErrorCall -> IO [Node])
-> ([Node] -> ErrorCall) -> [Node] -> IO [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall) -> ([Node] -> String) -> [Node] -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> String
forall a. Show a => a -> String
show ([Node] -> m [Node]) -> [Node] -> m [Node]
forall a b. (a -> b) -> a -> b
$ [Node]
bad