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

-- 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.XML.ExamplesSpec
  ( spec,
  )
where

import Control.Exception
import Control.Lens
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader
import Data.ByteString.Base64.Lazy qualified as EL (decodeLenient)
import Data.CaseInsensitive qualified as CI
import Data.Either
import Data.List qualified as List
import Data.List.NonEmpty as NL
import Data.Map qualified as Map
import Data.String.Conversions
import SAML2.Util
import SAML2.WebSSO
import SAML2.WebSSO.Test.Lenses
import SAML2.WebSSO.Test.MockResponse
import SAML2.WebSSO.Test.Util
import Samples qualified
import System.Environment (setEnv)
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Text.Show.Pretty (ppShow)
import Text.XML
import Text.XML.DSig as DSig
import URI.ByteString

spec :: Spec
spec = describe "XML serialization" $ do
  describe "unit tests" $ do
    it "Time seconds have no more than 7 decimal digits" $ do
      --  (or else azure/AD will choke on it with a very useless error message)
      renderTime (unsafeReadTime "2013-03-18T03:28:54.1839884Z")
        `shouldBe` renderTime (unsafeReadTime "2013-03-18T03:28:54.18398841817Z")
      let decimalses = dot <$> List.inits "1839884181781"
            where
              dot "" = ""
              dot s = '.' : s
      forM_ decimalses $ \decimals -> do
        let bad = "2013-03-18T03:28:54" <> decimals <> "Z"
            good = "2013-03-18T03:28:54" <> List.take 8 decimals <> "Z"
        renderTime (unsafeReadTime good) `shouldBe` renderTime (unsafeReadTime bad)
    roundtrip 0 (readSampleIO "microsoft-authnrequest-1.xml") Samples.microsoftAuthnRequest1
  -- roundtrip 1 (readSample "microsoft-authnresponse-0.xml") Samples.microsoft_authnresponse_0
  -- roundtrip 2 (readSample "microsoft-authnresponse-1.xml") Samples.microsoft_authnresponse_1
  -- roundtrip 3 (readSample "microsoft-authnresponse-2.xml") Samples.microsoft_authnresponse_2
  -- roundtrip 4 (readSample "microsoft-meta-2.xml") Samples.microsoft_meta_2
  -- roundtrip 5 (readSample "onelogin-request-1.xml") Samples.onelogin_request_1
  -- roundtrip 6 (readSample "onelogin-response-1.xml") (undefined :: AuthnResponse)
  -- roundtrip 7 (readSample "onelogin-response-2.xml") (undefined :: AuthnResponse)
  -- roundtrip 8 (readSample "onelogin-response-3.xml") (undefined :: AuthnResponse)

  describe "AuthnRequest" $ do
    it "works" $ do
      let req =
            AuthnRequest
              { _rqID = ID "_233f9cee-b6bc-11e8-87ff-97a7b126bf5a",
                _rqIssueInstant = unsafeReadTime "2013-03-18T07:33:56Z",
                _rqIssuer = iss,
                _rqNameIDPolicy = Nothing
              }
          iss = Issuer $ unsafeParseURI "http://wire.com"
      decodeElem @Issuer @(Either String) (encodeElem iss) `shouldBe` Right iss
      decodeElem @AuthnRequest @(Either String) (encodeElem req) `shouldBe` Right req
  describe "AuthnResponse with tricky Subject elements" $ do
    -- https://developer.okta.com/blog/2018/02/27/a-breakdown-of-the-new-saml-authentication-bypass-vulnerability
    -- We were not affected, but it's always good to have tests.  'mkAuthnResponseWithRawSubj'
    -- deletes all 'SubjectConfirmation' children, but that is irrelevant for what we're testing
    -- here.

    let check :: (HasCallStack) => String -> [Node] -> Maybe ST -> Spec
        check msg nameId expectedsubj = it msg $ do
          ctx :: CtxV <- mkTestCtxSimple
          spmeta :: SPMetadata <- ioFromTestSP ctx mkTestSPMetadata
          (testIdPConfig, SampleIdP _ sampleIdPPrivkey _ _) <- makeTestIdPConfig
          authnreq :: AuthnRequest <- ioFromTestSP ctx $ do
            spiss <- defSPIssuer
            let idpiss = testIdPConfig ^. idpMetadata . edIssuer
            createAuthnRequest 3600 spiss idpiss
          SignedAuthnResponse doc <-
            ioFromTestSP ctx $
              mkAuthnResponseWithRawSubj nameId sampleIdPPrivkey testIdPConfig spmeta (Just authnreq) True
          let parsed :: Either String AuthnResponse = parseFromDocument @AuthnResponse doc
          case expectedsubj of
            Nothing -> do
              parsed `shouldSatisfy` isLeft
            Just subj -> do
              parsed `shouldSatisfy` isRight
              let Right (subjid :: NameID) = parsed <&> (^. assertionL . assContents . sasSubject . subjectID)
              (CI.original <$> shortShowNameID subjid) `shouldBe` Just subj

        mknid :: [Node] -> Node
        mknid = NodeElement . Element "{urn:oasis:names:tc:SAML:2.0:assertion}NameID" mempty

    check
      "good"
      [mknid [NodeContent "xkcd"]]
      (Just "xkcd")
    check
      "NameID with fragmented contents"
      [mknid [NodeContent "we", NodeContent "f"]]
      (Just "wef")
    check
      "no NameID"
      []
      Nothing
    check
      "empty NameID"
      [mknid mempty]
      Nothing
    check
      "NameID with comments in contents"
      [mknid [NodeContent "wef", NodeComment "phlaa", NodeContent "fie"]]
      Nothing
    check
      "NameID with whitespace in contents"
      [mknid [NodeContent "  we f  "]]
      (Just "  we f  ")
    check
      "NameID with fragmented, whitespacy contents"
      [mknid [NodeContent "  we  ", NodeContent "  f  "]]
      (Just "  we    f  ")
