1/*  Part of SWI-Prolog
    2
    3    Author:        Matt Lilley
    4    E-mail:        thetrime@gmail.com
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2004-2016, SWI-Prolog Foundation
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36
   37:-module(xmlenc,
   38         [ decrypt_xml/4,   % +EncryptedXML, -DecryptedXML, :KeyCallback, +Options
   39           load_certificate_from_base64_string/2 % +Base64String, -Certificate
   40         ]).   41:- use_module(library(ssl)).   42:- use_module(library(crypto)).   43:- use_module(library(sgml)).   44:- use_module(library(base64)).   45:- use_module(library(error)).   46
   47:- meta_predicate
   48    decrypt_xml(+, -, 3, +).   49
   50/** <module> XML encryption library
   51
   52This library is a partial implementation of the XML encryption standard.
   53It implements the _decryption_ part, which is needed by SAML clients.
   54
   55@see https://www.w3.org/TR/xmlenc-core1/
   56@see https://en.wikipedia.org/wiki/Security_Assertion_Markup_Language
   57*/
   58
   59% These are the 4 mandatory block cipher algorithms
   60% (actually aes-192-cbc is not mandatory, but it is easy to support)
   61ssl_algorithm('http://www.w3.org/2001/04/xmlenc#tripledes-cbc', 'des3',         8).
   62ssl_algorithm('http://www.w3.org/2001/04/xmlenc#aes128-cbc',    'aes-128-cbc', 16).
   63ssl_algorithm('http://www.w3.org/2001/04/xmlenc#aes256-cbc',    'aes-256-cbc', 32).
   64ssl_algorithm('http://www.w3.org/2001/04/xmlenc#aes192-cbc',    'aes-192-cbc', 24).
   65
   66%!  decrypt_xml(+DOMIn, -DOMOut, :KeyCallback, +Options) is det.
   67%
   68%   @arg KeyCallback may be called as follows:
   69%           - call(KeyCallback, name,        KeyName,         Key)
   70%           - call(KeyCallback, public_key,  public_key(RSA), Key)
   71%           - call(KeyCallback, certificate, Certificate,     Key)
   72
   73decrypt_xml([], [], _, _):- !.
   74decrypt_xml([element(ns(_, 'http://www.w3.org/2001/04/xmlenc#'):'EncryptedData',
   75                     Attributes, EncryptedData)|Siblings],
   76            [Decrypted|NewSiblings], KeyCallback, Options) :-
   77    !,
   78    decrypt_element(Attributes, EncryptedData, Decrypted, KeyCallback, Options),
   79    decrypt_xml(Siblings, NewSiblings, KeyCallback, Options).
   80
   81decrypt_xml([element(Tag, Attributes, Children)|Siblings],
   82            [element(Tag, Attributes, NewChildren)|NewSiblings], KeyCallback, Options) :-
   83    !,
   84    decrypt_xml(Children, NewChildren, KeyCallback, Options),
   85    decrypt_xml(Siblings, NewSiblings, KeyCallback, Options).
   86decrypt_xml([Other|Siblings], [Other|NewSiblings], KeyCallback, Options):-
   87    decrypt_xml(Siblings, NewSiblings, KeyCallback, Options).
   88
   89%!   decrypt_element(+Attributes,
   90%!                   +EncryptedData,
   91%!                   -DecryptedElement,
   92%!                   +Options).
   93%
   94%    Decrypt an EncryptedData element  with   Attributes  and  child
   95%    EncryptedData DecryptedElement will either be an element/3 term
   96%    or a string as dictacted by   the Type attribute in Attributes.
   97%    If Attributes does not contain a  Type attribute then we assume
   98%    it is a string
   99
  100:-meta_predicate(decrypt_element(+, +, -, 3, +)).  101
  102decrypt_element(Attributes, EncryptedData, Decrypted, KeyCallback, Options):-
  103    XENC = ns(_, 'http://www.w3.org/2001/04/xmlenc#'),
  104    (  memberchk(element(XENC:'CipherData', _, CipherData), EncryptedData)
  105    -> true
  106    ;  existence_error(cipher_data, EncryptedData)
  107    ),
  108    % The Type attribute is not mandatory. However, 3.1 states that
  109    % "Without this information, the decryptor will be unable to automatically restore the XML document to its original cleartext form."
  110    (  memberchk('Type'=Type, Attributes)
  111    -> true
  112    ;  Type = 'http://www.w3.org/2001/04/xmlenc#Content'
  113    ),
  114
  115    % First of all, determine the algorithm used to encrypt the data
  116    determine_encryption_algorithm(EncryptedData, Algorithm, IVSize),
  117
  118    % There are now two tasks remaining, and they seem like they ought to be quite simple, but unfortunately they are not
  119    % First, we must determine the key used to encrypt the message
  120    determine_key(EncryptedData, Key, KeyCallback, Options),
  121
  122    % Then, we must determine what the encrypted data even IS
  123    % If the message includes a CipherValue then this is straightfoward - the encrypted data is the base64-encoded child
  124    % of this element.
  125    (  memberchk(element(XENC:'CipherValue', _, CipherValueElement), CipherData)
  126    -> base64_element(CipherValueElement, CipherValueWithIV),
  127           string_codes(CipherValueWithIV, CipherValueWithIVCodes),
  128           length(IVCodes, IVSize),
  129           append(IVCodes, CipherCodes, CipherValueWithIVCodes),
  130           string_codes(IV, IVCodes),
  131           string_codes(CipherText, CipherCodes),
  132           length(CipherValueWithIVCodes, _),
  133           crypto_data_decrypt(CipherText, Algorithm, Key, IV, DecryptedStringWithPadding, [padding(none), encoding(octet)])
  134    ;  memberchk(element(XENC:'CipherReference', CipherReferenceAttributes, CipherReference), CipherData)->
  135           % However, it is allowed to include CipherReference instead. This is an arbitrary URI and a list of transforms to convert the
  136           % data identified by that URI into the raw octets that represent the encrypted data
  137           % The URI attribute of the CipherReference element is mandatory
  138           memberchk('URI'=CipherURI, CipherReferenceAttributes),
  139           % The transforms attribute is optional, though.
  140           (  memberchk(element('Transforms', _, Transforms), CipherReference)
  141           -> true
  142           ;  Transforms = []
  143           ),
  144           uri_components(CipherURI, uri_components(Scheme, _, _, _, _)),
  145           (  ( Scheme == 'http' ; Scheme == 'https')
  146              % FIXME: URI may not be an *absolute* URL
  147           ->  with_output_to(string(RawCipherValue),
  148                          setup_call_cleanup(http_open(CipherURI, HTTPStream, []),
  149                                             copy_stream_data(HTTPStream, current_output),
  150                                             close(HTTPStream)))
  151           ;  domain_error(resolvable_uri, CipherURI)
  152           ),
  153           apply_ciphertext_transforms(RawCipherValue, Transforms, CipherValue),
  154           sub_string(CipherValue, 0, IVSize, _, IV),
  155           sub_string(CipherValue, IVSize, _, 0, CipherText),
  156           crypto_data_decrypt(CipherText, Algorithm, Key, IV, DecryptedStringWithPadding, [padding(none), encoding(octet)])
  157    ),
  158    % The XML-ENC padding scheme does not comply with RFC-1423. This has been noted a few times by people trying to write
  159    % XML-ENC decryptors backed by OpenSSL, which insists on compliance. The only recourse we have is to disable padding entirely
  160    % and do it in our application
  161    xmlenc_padding(DecryptedStringWithPadding, DecryptedString),
  162    % Now that we have the decrypted data, we can decide whether to turn it into an element or leave it as
  163    % content
  164    (  Type == 'http://www.w3.org/2001/04/xmlenc#Element'
  165    -> setup_call_cleanup(open_string(DecryptedString, StringStream),
  166                          load_structure(StringStream, [Decrypted], [dialect(xmlns), keep_prefix(true)]),
  167                          close(StringStream))
  168    ;  Decrypted = DecryptedString
  169    ).
  170
  171xmlenc_padding(DecryptedStringWithPadding, DecryptedString):-
  172    string_length(DecryptedStringWithPadding, _),
  173    string_codes(DecryptedStringWithPadding, Codes),
  174    append(_, [LastCode], Codes),
  175    length(Padding, LastCode),
  176    append(DecryptedCodes, Padding, Codes),
  177    !,
  178    string_codes(DecryptedString, DecryptedCodes).
  179
  180apply_ciphertext_transforms(CipherValue, [], CipherValue):- !.
  181apply_ciphertext_transforms(_, [_AnythingElse|_], _):-
  182    % FIXME: Not implemented
  183    throw(error(implementation_missing('CipherReference transforms are not implemented', _))).
  184
  185:- meta_predicate determine_key(+,-,3,+).  186determine_key(EncryptedData, Key, KeyCallback, Options):-
  187    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  188    (  memberchk(element(DS:'KeyInfo', _, KeyInfo), EncryptedData)
  189    -> true
  190    ;  % Technically the KeyInfo is not mandatory. However, without a key we cannot decrypt
  191           % so raise an error. In the future Options could contain a key if it is agreed upon
  192           % by some other channel
  193           existence_error(key_info, EncryptedData)
  194    ),
  195    resolve_key(KeyInfo, Key, KeyCallback, Options).
  196
  197:- meta_predicate resolve_key(+,-,3,+).  198
  199resolve_key(Info, Key, KeyCallback, Options):-
  200    % EncryptedKey
  201    XENC = 'http://www.w3.org/2001/04/xmlenc#',
  202    memberchk(element(ns(_, XENC):'EncryptedKey', _KeyAttributes, EncryptedKey), Info),
  203    !,
  204    % The EncryptedKey is slightly different to EncryptedData. For a start, the algorithms used to decrypt the
  205    % key are orthogonal to those used for EncryptedData. However we can recursively search for the keys then
  206    % decrypt them using the different algorithms as needed
  207    memberchk(element(ns(_, XENC):'EncryptionMethod', MethodAttributes, EncryptionMethod), EncryptedKey),
  208    memberchk('Algorithm'=Algorithm, MethodAttributes),
  209
  210    % Now find the KeyInfo
  211    determine_key(EncryptedKey, PrivateKey, KeyCallback, Options),
  212
  213    memberchk(element(ns(_, XENC):'CipherData', _, CipherData), EncryptedKey),
  214    memberchk(element(ns(_, XENC):'CipherValue', _, CipherValueElement), CipherData),
  215    base64_element(CipherValueElement, CipherValue),
  216    (  Algorithm == 'http://www.w3.org/2001/04/xmlenc#rsa-oaep-mgf1p'
  217    -> rsa_private_decrypt(PrivateKey, CipherValue, Key, [encoding(octet), padding(pkcs1_oaep)])
  218    ;  Algorithm == 'http://www.w3.org/2009/xmlenc11#rsa-oaep',
  219           memberchk(element(ns(_, 'http://www.w3.org/2009/xmlenc11#'):'MGF', MGFAttributes, _), EncryptionMethod),
  220           memberchk('Algorithm'='http://www.w3.org/2009/xmlenc11#mgf1sha1', MGFAttributes)   % This is just the same as rsa-oaep-mgf1p!
  221    -> rsa_private_decrypt(PrivateKey, CipherValue, Key, [encoding(octet), padding(pkcs1_oaep)])
  222    ;  Algorithm == 'http://www.w3.org/2001/04/xmlenc#rsa-1_5'
  223    -> rsa_private_decrypt(PrivateKey, CipherValue, Key, [encoding(octet), padding(pkcs1)])
  224    ;  domain_error(key_transport, Algorithm)
  225    ).
  226resolve_key(KeyInfo, _Key, _KeyCallback, _Options):-
  227    % AgreementMethod. FIXME: Not implemented
  228    XENC = ns(_, 'http://www.w3.org/2001/04/xmlenc#'),
  229    memberchk(element(XENC:'AgreementMethod', _KeyAttributes, _AgreementMethod), KeyInfo),
  230    !,
  231    throw(not_implemented).
  232% Additionally, we are allowed to use any elements from XML-DSIG
  233resolve_key(KeyInfo, Key, KeyCallback, _Options):-
  234    % KeyName. Use the callback with type=name and hint=KeyName
  235    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  236    memberchk(element(DS:'KeyName', _KeyAttributes, [KeyName]), KeyInfo),
  237    !,
  238    call(KeyCallback, name, KeyName, Key).
  239resolve_key(KeyInfo, _Key, _KeyCallback, _Options):-
  240    % RetrievalMethod. FIXME: Not implemented
  241    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  242    memberchk(element(DS:'RetrievalMethod', _KeyAttributes, _RetrievalMethod), KeyInfo),
  243    !,
  244    throw(not_implemented).
  245resolve_key(KeyInfo, Key, KeyCallback, _Options):-
  246    % KeyValue.
  247    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  248    memberchk(element(DS:'KeyValue', _KeyAttributes, KeyValue), KeyInfo),
  249    !,
  250    (  memberchk(element(DS:'RSAKeyValue', _, RSAKeyValue), KeyInfo)
  251    -> memberchk(element(DS:'Modulus', _, [ModulusBase64]), RSAKeyValue),
  252           memberchk(element(DS:'Exponent', _, [ExponentBase64]), RSAKeyValue),
  253           base64_to_hex(ModulusBase64, Modulus),
  254           base64_to_hex(ExponentBase64, Exponent),
  255           call(KeyCallback, public_key, public_key(rsa(Modulus, Exponent, -, -, -, -, -, -)), Key)
  256    ;  memberchk(element(DS:'DSAKeyValue', _, _DSAKeyValue), KeyInfo)
  257    -> throw(error(not_implemented(dsa_key), _)) % FIXME: Not implemented
  258    ;  existence_error(usable_key_value, KeyValue)
  259    ).
  260resolve_key(KeyInfo, Key, KeyCallback, _Options):-
  261    % X509Data.
  262    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  263    memberchk(element(DS:'X509Data', _, X509Data), KeyInfo),
  264    memberchk(element(DS:'X509Certificate', _, [X509Certificate]), X509Data),
  265    !,
  266    load_certificate_from_base64_string(X509Certificate, Certificate),
  267    call(KeyCallback, certificate, Certificate, Key).
  268resolve_key(KeyInfo, _Key, _KeyCallback, _Options):-
  269    % PGPData. FIXME: Not implemented
  270    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  271    memberchk(element(DS:'PGPData', _KeyAttributes, _PGPData), KeyInfo),
  272    !,
  273    throw(not_implemented).
  274resolve_key(KeyInfo, _Key, _KeyCallback, _Options):-
  275    % SPKIData. FIXME: Not implemented
  276    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  277    memberchk(element(DS:'SPKIData', _KeyAttributes, _SPKIData), KeyInfo),
  278    !,
  279    throw(not_implemented).
  280resolve_key(KeyInfo, _Key, _KeyCallback, _Options):-
  281    % MgmtData. FIXME: Not implemented
  282    DS = ns(_, 'http://www.w3.org/2000/09/xmldsig#'),
  283    memberchk(element(DS:'MgmtData', _KeyAttributes, _SPKIData), KeyInfo),
  284    !,
  285    throw(not_implemented).
  286resolve_key(Info, _, _, _):-
  287    % The XML-ENC standard allows for arbitrary other means of transmitting keys in application-specific
  288    % protocols. This is not supported here, though. In the future a callback could be provided in Options
  289    % to obtain the key information from a KeyInfo structure.
  290    existence_error(usable_key, Info).
  291
  292
  293base64_to_hex(Base64, Hex):-
  294    base64(Raw, Base64),
  295    atom_codes(Raw, Codes),
  296    hex_bytes(Hex0, Codes),
  297    string_upper(Hex0, Hex).
  298
  299
  300determine_encryption_algorithm(EncryptedData, Algorithm, IVSize):-
  301    XENC = ns(_, 'http://www.w3.org/2001/04/xmlenc#'),
  302    (  memberchk(element(XENC:'EncryptionMethod', EncryptionMethodAttributes, _), EncryptedData)
  303    -> % This is a mandatory attribute
  304           memberchk('Algorithm'=XMLAlgorithm, EncryptionMethodAttributes),
  305           (  ssl_algorithm(XMLAlgorithm, Algorithm, IVSize)
  306           -> true
  307           ; domain_error(block_cipher, XMLAlgorithm)
  308           )
  309        % In theory the EncryptionMethod is optional. In pracitse though, if the method is not supplied we
  310        % cannot decrypt the data. In the future we could support encryption_algorithm/1 as an option to
  311        % decrypt_element/3 but for now raise an exception
  312    ; existence_error(encryption_method, EncryptedData)
  313    ).
  314
  315base64_element([CipherValueElement], CipherValue):-
  316    atom_codes(CipherValueElement, Base64Codes),
  317    delete_newlines(Base64Codes, TrimmedCodes),
  318    string_codes(Trimmed, TrimmedCodes),
  319    base64(CipherValue, Trimmed).
  320
  321delete_newlines([], []):- !.
  322delete_newlines([13|As], B):- !, delete_newlines(As, B).
  323delete_newlines([10|As], B):- !, delete_newlines(As, B).
  324delete_newlines([A|As], [A|B]):- !, delete_newlines(As, B).
  325
  326
  327
  328%!	load_certificate_from_base64_string(+String, -Certificate) is det.
  329%
  330%	Loads a certificate from a string, adding newlines and header
  331%       where appropriate so that OpenSSL 1.0.1+ will be able to parse it
  332
  333load_certificate_from_base64_string(UnnormalizedData, Certificate):-
  334    normalize_space(codes(Codes), UnnormalizedData),
  335    % Break into 64-byte chunks
  336    chunk_certificate(Codes, Chunks),
  337    atomics_to_string(["-----BEGIN CERTIFICATE-----"|Chunks], '\n', CompleteCertificate),
  338    setup_call_cleanup(open_string(CompleteCertificate, StringStream),
  339                       load_certificate(StringStream, Certificate),
  340                       close(StringStream)).
  341
  342chunk_certificate(Codes, [Chunk|Chunks]):-
  343    length(ChunkCodes, 64),
  344    append(ChunkCodes, Rest, Codes),
  345    !,
  346    string_codes(Chunk, ChunkCodes),
  347    chunk_certificate(Rest, Chunks).
  348chunk_certificate([], ["-----END CERTIFICATE-----\n"]):- !.
  349chunk_certificate(LastCodes, [LastChunk, "-----END CERTIFICATE-----\n"]):-
  350    string_codes(LastChunk, LastCodes)