wip

Author: fisx

libs/saml2-web-sso/saml2-web-sso.cabal

@@ -208,6 +208,7 @@ test-suite spec
     , asn1-parse            >=0.9.5
     , asn1-types            >=0.3.3
     , base                  >=4.12.0.0
+    , base64
     , base64-bytestring     >=1.0.0.2
     , binary                >=0.8.6.0
     , bytestring            >=0.10.8.2
@@ -236,7 +237,7 @@ test-suite spec
     , hspec-wai             >=0.9.0
     , http-media            >=0.8.0.0
     , http-types            >=0.12.3
-    , hxt                   >=9.3.1.18
+    , hxt
     , imports
     , lens                  >=4.17.1
     , lens-datetime         >=0.3
@@ -263,6 +264,7 @@ test-suite spec
     , types-common
     , uniplate              >=1.6.12
     , uri-bytestring        >=0.3.2.2
+    , utf8-string
     , uuid                  >=1.3.13
     , wai                   >=3.2.2.1
     , wai-extra             >=3.0.28

libs/saml2-web-sso/src/SAML2/WebSSO/API.hs

@@ -46,6 +46,7 @@ import SAML2.WebSSO.SP
 import SAML2.WebSSO.Servant
 import SAML2.WebSSO.Types
 import SAML2.WebSSO.XML
+import SAML2.XML qualified as HS
 import Servant.API as Servant hiding (URI (..))
 import Servant.Multipart
 import Servant.Server
@@ -56,6 +57,7 @@ import Text.XML
 import Text.XML.Cursor
 import Text.XML.DSig
 import Text.XML.HXT.Core (XmlTree)
+import Text.XML.HXT.DOM.TypeDefs qualified as HS
 import URI.ByteString
 
 ----------------------------------------------------------------------
@@ -224,12 +226,16 @@ simpleVerifyAuthnResponse creds raw = do
 allVerifies :: forall m err. (MonadError (Error err) m) => NonEmpty SignCreds -> LBS -> NonEmpty String -> m (NonEmpty Assertion)
 allVerifies creds raw nodeids = do
   let workArounds = verifyADFS creds raw nodeids
-  xmls <- case verify creds raw `mapM` nodeids of
+  xmls :: NonEmpty XmlTree <- case verify creds raw `mapM` nodeids of
     Right assertions -> pure assertions
     Left err -> case workArounds of
       Right ws -> pure ws
       Left _ -> throwError . BadSamlResponseInvalidSignature $ cs err
-  (renderVerifyErrorHack . parseFromXmlTree) `mapM` xmls
+  -- here, xmls still contains correctly utf8-encoded display name:
+  -- () <- error $ "********************************* " <> show xmls
+  result <- (renderVerifyErrorHack . parseFromXmlTree) `mapM` xmls -- CRASH!!!
+  -- () <- error "********************************* [not reached]"
+  pure result
   where
     -- (there must be a better way for this, but where?)
     renderVerifyErrorHack :: forall m' err' a. (MonadError (Error err') m') => Either String a -> m' a

libs/saml2-web-sso/src/SAML2/WebSSO/Test/Util/Misc.hs

@@ -6,6 +6,7 @@ module SAML2.WebSSO.Test.Util.Misc where
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.ByteString.Base64.Lazy qualified as EL (encode)
+import Data.ByteString.Lazy qualified as LBS
 import Data.EitherR
 import Data.Generics.Uniplate.Data
 import Data.List (sort)
@@ -35,6 +36,13 @@ readSampleIO fpath =
     LT.readFile $
       $(fileRelativeToProject "test/samples") </> fpath
 
+readSampleIOLBS :: (MonadIO m) => FilePath -> m LBS
+readSampleIOLBS fpath =
+  liftIO
+    $ LBS.readFile
+    $ $(fileRelativeToProject "test/samples")
+    </> fpath
+
 doesSampleExistIO :: (MonadIO m) => FilePath -> m Bool
 doesSampleExistIO fpath =
   liftIO $

libs/saml2-web-sso/src/SAML2/WebSSO/XML.hs

@@ -30,6 +30,7 @@ import Control.Exception (SomeException)
 import Control.Lens hiding (element)
 import Control.Monad
 import Control.Monad.Except
+import Data.ByteString.Lazy qualified as LBS
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive qualified as CI
 import Data.EitherR
@@ -60,6 +61,7 @@ import SAML2.XML qualified as HS
 import SAML2.XML qualified as HX
 import SAML2.XML.Schema.Datatypes qualified as HX (Boolean, Duration, UnsignedShort)
 import SAML2.XML.Signature.Types qualified as HX (Signature)
+import System.IO.Unsafe
 import Text.Hamlet.XML
 import Text.XML
 import Text.XML.Cursor
@@ -104,9 +106,15 @@ renderToDocument = mkDocument . renderRoot
 parseFromDocument :: (HasXML a, MonadError String m) => Document -> m a
 parseFromDocument doc = parse [NodeElement $ documentRoot doc]
 
-parseFromXmlTree :: (MonadError String m, HasXML a) => XmlTree -> m a
+-- raw: "R\259zvan Ioan BIBAR\538"  UTF16
+-- x: "R\ETXzvan Ioan BIBAR\SUB"
+
+parseFromXmlTree :: (MonadError String m, HasXML a, Show a) => XmlTree -> m a
 parseFromXmlTree raw = do
-  doc <- decode . decodeUtf8 $ HX.docToXMLWithRoot raw
+  let x = HX.docToXMLWithRoot raw
+  () <- error $ "************** [1]" <> show (raw, x) -- TODO: only x contains broken display name, so it's HX.docToXMLWithRoot :-(
+  doc :: Document <- decode . decodeUtf8 $ HX.docToXMLWithRoot raw
+  () <- error $ "************** CRASHED"
   parseFromDocument doc
 
 -- FUTUREWORK: perhaps we want to split this up: HasXML (for nameSpaces), and HasXMLParse, HasXMLRender,

libs/saml2-web-sso/test/Test/SAML2/WebSSO/APISpec.hs

@@ -6,18 +6,25 @@ module Test.SAML2.WebSSO.APISpec
   )
 where
 
+import Codec.Binary.UTF8.String qualified as UTF8
 import Control.Concurrent.MVar
 import Control.Exception (SomeException, try)
 import Control.Lens
 import Control.Monad
 import Control.Monad.IO.Class
+import Data.ByteString qualified as SBS
 import Data.ByteString.Base64.Lazy qualified as EL (decodeLenient, encode)
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBSC8
+import Data.ByteString.Lazy.UTF8 qualified as LBSUTF8
 import Data.Either
 import Data.EitherR
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Map qualified as Map
-import Data.Maybe (maybeToList)
+import Data.Maybe
 import Data.String.Conversions
+import Data.Text.Lazy.Encoding as LT
+import Data.Tree.NTree.TypeDefs as HXT
 import Data.UUID
 import Data.Yaml qualified as Yaml
 import Network.Wai.Test
@@ -26,14 +33,17 @@ import SAML2.WebSSO
 import SAML2.WebSSO.API.Example (RequestStore)
 import SAML2.WebSSO.Test.MockResponse
 import SAML2.WebSSO.Test.Util
+import SAML2.XML qualified as HSAML2
 import Servant
 import Test.Hspec hiding (pending)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.Matcher
 import Text.XML as XML
+import Text.XML.HXT.DOM.ShowXml as HXT
+import Text.XML.HXT.DOM.TypeDefs as HXT
 import URI.ByteString.QQ
 
-spec :: Spec
+spec :: (HasCallStack) => Spec
 spec = describe "API" $ do
   describe "base64 encoding" $ do
     describe "compatible with /usr/bin/env base64" $ do
@@ -327,10 +337,11 @@ spec = describe "API" $ do
   --  * onelogin
   --  * jives [https://community.jivesoftware.com/docs/DOC-240217#jive_content_id_IdP_Metadata]
 
-  focus . describe "simpleVerifyAuthnResponse, second attempt" $ do
+  describe "simpleVerifyAuthnResponse, second attempt" $ do
     let check :: FilePath -> FilePath -> Expectation
         check metaFile respFile = do
-          resp :: LBS <- cs <$> readSampleIO respFile
+          resp :: LBS <- readSampleIOLBS respFile
+          -- () <- error $ show resp -- "R\196\131zvan Ioan BIBAR\200\154"  (UTF8!)
           assertions <- liftIO $ do
             idpCfg :: IdPConfig_ <- do
               raw :: LBS <- cs <$> readSampleIO metaFile
@@ -347,3 +358,45 @@ spec = describe "API" $ do
 
     it "works" $ do
       check "microsoft-azure-utf8-issue-metadata.base64" "microsoft-azure-utf8-issue-authentication-request.base64"
+
+    -- hxt uses Char8.pack, which won't work on unicode strings.
+
+    focus . it "hxt bug?" $ do
+      let nope1 :: LBS.ByteString = HXT.xshowBlob [NTree (XText payloadString) []]
+          nope2 :: LBS.ByteString = LBSC8.pack payloadString
+          nope3 :: LBS.ByteString = LBSUTF8.fromString payloadString
+          yeah1 :: LBS.ByteString = LBS.pack bs
+
+          -- 0xC4=196, 0x83=131, 0xC8 = 200, 0x9A = 154
+          -- ă -> 0xC4 0x83 (utf-8), 0x0103 (utf-16)
+          -- Ț -> 0xC8 0x9A (utf-8), 0x021A (utf-16)
+          bs = [0xC4, 0x83, 0xC8, 0x9A]
+          payloadLBS :: LBS.ByteString = LBS.pack bs
+          payloadString :: String = "ăȚ"
+          utf8String = UTF8.encodeString payloadString
+
+      print (payloadLBS, payloadString, nope1, nope2, nope3)
+      print (LBS.unpack payloadLBS, LBS.unpack nope1, LBS.unpack nope2, (LBS.unpack . LBSC8.pack) utf8String, LBS.unpack nope3)
+      -- print ((LB.toString . LBS.toString) nope1, (LB.toString . LBS.toStrict) nope2)
+
+      LBS.writeFile "/tmp/x" payloadLBS
+      -- <>) . LT.encodeUtf8) <$> LT.decodeUtf8' nope1)
+      LBS.unpack nope2 `shouldBe` bs
+      nope1 `shouldSatisfy` (SBS.isValidUtf8 . LBSC8.toStrict)
+      nope2 `shouldSatisfy` (SBS.isValidUtf8 . LBSC8.toStrict)
+      nope1 `shouldBe` "\x0103\x021a"
+      nope2 `shouldBe` "\x0103\x021a"
+
+    it "parseFromXmlTree" $ do
+      resp :: LBS <- cs <$> readSampleIO "microsoft-azure-utf8-issue-authentication-request.base64"
+      let tree :: Maybe (NTree XNode) = HSAML2.xmlToDoc resp
+      liftIO $ print resp
+      liftIO $ print tree
+      let result :: Either String AuthnResponse = parseFromXmlTree (fromJust tree)
+      liftIO $ print result
+      False `shouldBe` True
+
+    it "HSAML2.docToXMLWithRoot" $ do
+      let x = "<samlp:Response ID=\"ăȚ\"></samlp:Response>\n"
+          y = HSAML2.docToXMLWithRoot (HXT.NTree (HXT.XText x) [])
+      y `shouldBe` x