{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-unused-binds -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.SAML2.WebSSO.XMLSpec
  ( spec,
  )
where

import Data.Default
import Data.Either
import Data.String.Conversions
import Data.Text.Lazy qualified as LT
import Imports
import SAML2.Core qualified as HS
import SAML2.Util
import SAML2.WebSSO
import SAML2.XML qualified as HS
import Test.Hspec
import Text.XML as XMLC
import URI.ByteString.QQ (uri)

-- | embed an email into a valid NameID context
xmlWithName :: Maybe LT -> LT -> LT
xmlWithName mformat txt =
  "<NameID " <> namespaces <> format <> " " <> namespaces2 <> ">" <> txt <> "</NameID>"
  where
    namespaces =
      LT.unwords
        [ "xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\"",
          "xmlns:samla=\"urn:oasis:names:tc:SAML:2.0:assertion\"",
          "xmlns:samlm=\"urn:oasis:names:tc:SAML:2.0:metadata\"",
          "xmlns:ds=\"http://www.w3.org/2000/09/xmldsig#\""
        ]
    namespaces2 =
      LT.unwords
        [ "xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\""
        ]
    format = maybe "" (\f -> " Format=\"" <> f <> "\"") mformat

emailFormat :: LT
emailFormat = "urn:oasis:names:tc:SAML:1.1:nameid-format:emailAddress"

unspecifiedFormat :: LT
unspecifiedFormat = "urn:oasis:names:tc:SAML:1.1:nameid-format:unspecified"

entityFormat :: LT
entityFormat = "urn:oasis:names:tc:SAML:2.0:nameid-format:entity"

spec :: Spec
spec = describe "XML Sanitization" $ do
  describe "decodeElem" $ do
    it "should decode a valid email" $ do
      decodeElem (xmlWithName (Just emailFormat) "somebody@example.org")
        `shouldBe` (emailNameID "somebody@example.org" :: Either String NameID)
    it "should fail to decode an invalid email" $ do
      decodeElem @NameID (xmlWithName (Just emailFormat) "&lt;somebody@example.org&gt;")
        `shouldBe` Left "HasXML: could not parse NameID: \"\\\": Failed reading: satisfyWith\""
    -- the "\": Failed reading: satisfyWith" part is from 'Text.Email.Validate.validate'

    it "should decode an escaped name if format is unspecified" $ do
      decodeElem (xmlWithName (Just unspecifiedFormat) "&lt;somebody@example.org&gt;")
        `shouldBe` Right (unspecifiedNameID "<somebody@example.org>")
    it "should unescape names" $ do
      decodeElem (xmlWithName (Just unspecifiedFormat) "&lt;somebody@example.org&gt;")
        `shouldBe` Right (unspecifiedNameID "<somebody@example.org>")
    it "should not unescape more than once" $ do
      decodeElem
        (xmlWithName (Just unspecifiedFormat) "&amp;lt;somebody@example.org&amp;gt;")
        `shouldBe` ( mkNameID
                       (UNameIDUnspecified "&lt;somebody@example.org&gt;")
                       Nothing
                       Nothing
                       Nothing ::
                       Either String NameID
                   )
    it "should not unescape text multiple times" $ do
      decodeElem (xmlWithName (Just entityFormat) "https://www.google.com/search?q=hello&lt;world&gt;")
        `shouldBe` ( mkNameID
                       ( UNameIDEntity
                           ( fromRight (error "bad uri in tests") $
                               parseURI' "https://www.google.com/search?q=hello<world>"
                           )
                       )
                       Nothing
                       Nothing
                       Nothing ::
                       Either String NameID
                   )
    describe "these tests are weird and caused by the XmlText type removed in may 2025" $ do
      it "rendering doesn't double escape" $ do
        encodeElem (unspecifiedNameID "<something>")
          `shouldBe` (xmlWithName Nothing "&lt;something&gt;")

      it "rendering escapes emails correctly" $ do
        encodeElem (fromRight (error "bad test case") $ emailNameID "a&@b.c")
          `shouldBe` (xmlWithName (Just emailFormat) "a&amp;@b.c")

      it "rendering escapes urls correctly" $ do
        encodeElem (entityNameID [uri|http://example.com/?<&>|])
          `shouldBe` (xmlWithName (Just entityFormat) "http://example.com/?%3C=&amp;%3E=")

    describe "unicode, utf8, and xml string escaping (this was quite a journey...)" $ do
      it "hsaml2 does the right thing: bad xml." $ do
        HS.xmlToSAML @HS.NameID "<NameID xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\"><something></NameID>"
          `shouldSatisfy` isLeft

      it "hsaml2 does the right thing: properly escaped xml." $ do
        HS.xmlToSAML @HS.NameID "<NameID xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">&lt;something&gt;</NameID>"
          `shouldBe` Right (HS.simpleNameID HS.NameIDFormatUnspecified "<something>")

      it "counter-example base case" $ do
        let xin = "<NameID xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">Caro</NameID>"
            xout = "<NameID xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names:tc:SAML:2.0:assertion\" xmlns:samlm=\"urn:oasis:names:tc:SAML:2.0:metadata\" xmlns:ds=\"http://www.w3.org/2000/09/xmldsig#\" xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">Caro</NameID>"
        (fmap encodeElem . decodeElem @NameID) xin `shouldBe` Right xout

      it "counter-example unicode" $ do
        let xin :: LT.Text = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><NameID xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">Căro</NameID>"
            xout :: LT.Text = "<NameID xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names:tc:SAML:2.0:assertion\" xmlns:samlm=\"urn:oasis:names:tc:SAML:2.0:metadata\" xmlns:ds=\"http://www.w3.org/2000/09/xmldsig#\" xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">Căro</NameID>"

            xmlcIn :: Either SomeException Document = XMLC.parseText def xin
            xmlcInExpected =
              Document
                { documentPrologue = Prologue {prologueBefore = [], prologueDoctype = Nothing, prologueAfter = []},
                  documentRoot = Element {elementName = Name {nameLocalName = "NameID", nameNamespace = Just "urn:oasis:names:tc:SAML:2.0:assertion", namePrefix = Nothing}, elementAttributes = mempty, elementNodes = [NodeContent "Căro"]},
                  documentEpilogue = []
                }
            Right decodeElemExpected = mkNameID (UNameIDUnspecified "Căro") Nothing Nothing Nothing

            xmlcOut :: LByteString = XMLC.renderLBS def (either (error . show) id xmlcIn)
            xmlcOutExpected :: LT.Text = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><NameID xmlns=\"urn:oasis:names:tc:SAML:2.0:assertion\">Căro</NameID>"

        either (error . show) id xmlcIn `shouldBe` xmlcInExpected
        xmlcOut `shouldBe` cs xmlcOutExpected

        -- do {en,de}codeElem work?
        (decodeElem @NameID) xin `shouldBe` Right decodeElemExpected
        encodeElem decodeElemExpected `shouldBe` xout
