diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.4.0: + - update dependencies + 0.3.6: - fix serialization: json attributes in scim are case-insensitive diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/hscim.cabal b/hscim.cabal --- a/hscim.cabal +++ b/hscim.cabal @@ -1,230 +1,228 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 8daa0bcbe43125e8d9749dd38e62f67cb01f62a1bcd57a0391e684860203e60c +cabal-version: 1.12 +name: hscim +version: 0.4.0 +synopsis: hscim json schema and server implementation +description: + The README file will answer all the questions you might have -name: hscim -version: 0.3.6 -synopsis: hscim json schema and server implementation -description: The README file will answer all the questions you might have -category: Web -homepage: https://github.com/wireapp/wire-server/libs/hscim/README.md -bug-reports: https://github.com/wireapp/wire-server/issues -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2018 Wire Swiss GmbH -license: AGPL-3 -license-file: LICENSE -build-type: Simple +category: Web +homepage: https://github.com/wireapp/wire-server/libs/hscim/README.md +bug-reports: https://github.com/wireapp/wire-server/issues +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2018 Wire Swiss GmbH +license: AGPL-3 +license-file: LICENSE +build-type: Simple extra-source-files: - README.md - CHANGELOG + CHANGELOG + README.md source-repository head - type: git + type: git location: https://github.com/wireapp/wire-server - subdir: libs/hscim + subdir: hscim library exposed-modules: - Web.Scim.AttrName - Web.Scim.Capabilities.MetaSchema - Web.Scim.Capabilities.MetaSchema.Group - Web.Scim.Capabilities.MetaSchema.ResourceType - Web.Scim.Capabilities.MetaSchema.Schema - Web.Scim.Capabilities.MetaSchema.SPConfig - Web.Scim.Capabilities.MetaSchema.User - Web.Scim.Class.Auth - Web.Scim.Class.Group - Web.Scim.Class.User - Web.Scim.Client - Web.Scim.ContentType - Web.Scim.Filter - Web.Scim.Handler - Web.Scim.Schema.AuthenticationScheme - Web.Scim.Schema.Common - Web.Scim.Schema.Error - Web.Scim.Schema.ListResponse - Web.Scim.Schema.Meta - Web.Scim.Schema.PatchOp - Web.Scim.Schema.ResourceType - Web.Scim.Schema.Schema - Web.Scim.Schema.User - Web.Scim.Schema.User.Address - Web.Scim.Schema.User.Certificate - Web.Scim.Schema.User.Email - Web.Scim.Schema.User.IM - Web.Scim.Schema.User.Name - Web.Scim.Schema.User.Phone - Web.Scim.Schema.User.Photo - Web.Scim.Schema.UserTypes - Web.Scim.Server - Web.Scim.Server.Mock - Web.Scim.Test.Acceptance - Web.Scim.Test.Util - other-modules: - Paths_hscim - hs-source-dirs: - src - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall + Web.Scim.AttrName + Web.Scim.Capabilities.MetaSchema + Web.Scim.Capabilities.MetaSchema.Group + Web.Scim.Capabilities.MetaSchema.ResourceType + Web.Scim.Capabilities.MetaSchema.Schema + Web.Scim.Capabilities.MetaSchema.SPConfig + Web.Scim.Capabilities.MetaSchema.User + Web.Scim.Class.Auth + Web.Scim.Class.Group + Web.Scim.Class.User + Web.Scim.Client + Web.Scim.ContentType + Web.Scim.Filter + Web.Scim.Handler + Web.Scim.Schema.AuthenticationScheme + Web.Scim.Schema.Common + Web.Scim.Schema.Error + Web.Scim.Schema.ListResponse + Web.Scim.Schema.Meta + Web.Scim.Schema.PatchOp + Web.Scim.Schema.ResourceType + Web.Scim.Schema.Schema + Web.Scim.Schema.User + Web.Scim.Schema.User.Address + Web.Scim.Schema.User.Certificate + Web.Scim.Schema.User.Email + Web.Scim.Schema.User.IM + Web.Scim.Schema.User.Name + Web.Scim.Schema.User.Phone + Web.Scim.Schema.User.Photo + Web.Scim.Schema.UserTypes + Web.Scim.Server + Web.Scim.Server.Mock + Web.Scim.Test.Acceptance + Web.Scim.Test.Util + + other-modules: Paths_hscim + hs-source-dirs: src + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + + ghc-options: -Wall -Wredundant-constraints -Wunused-packages build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.15 - , bytestring >=0.10.8 && <0.11 - , case-insensitive >=1.2.1.0 && <1.3 - , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.2 && <2.7 - , retry >=0.8.1.0 && <0.9 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.19 - , servant-client >=0.16.2 && <0.19 - , servant-client-core >=0.16.2 && <0.19 - , servant-server >=0.16.2 && <0.19 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.17 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.10 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 + aeson >=2.1.2 && <2.2 + , aeson-qq >=0.8.4 && <0.9 + , attoparsec >=0.14.4 && <0.15 + , base >=4.17.2 && <4.18 + , bytestring >=0.11.5 && <0.12 + , case-insensitive >=1.2.1 && <1.3 + , email-validate >=2.3.2 && <2.4 + , hashable >=1.4.3 && <1.5 + , hspec >=2.10.10 && <2.11 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.11.1 && <0.12 + , http-api-data >=0.5 && <0.6 + , http-media >=0.8.1 && <0.9 + , http-types >=0.12.3 && <0.13 + , list-t >=1.0.5 && <1.1 + , microlens >=0.4.13 && <0.5 + , mmorph >=1.2.0 && <1.3 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.4 && <2.7 + , retry >=0.9.3 && <0.10 + , scientific >=0.3.7 && <0.4 + , servant >=0.19.1 && <0.20 + , servant-client >=0.19 && <0.20 + , servant-client-core >=0.19 && <0.20 + , servant-server >=0.19.2 && <0.20 + , stm >=2.5.1 && <2.6 + , stm-containers >=1.2.0 && <1.3 + , string-conversions >=0.4.0 && <0.5 + , template-haskell >=2.19.0 && <2.20 + , text >=2.0.2 && <2.1 + , time >=1.12.2 && <1.13 + , uuid >=1.3.15 && <1.4 + , wai >=3.2.3 && <3.3 + , wai-extra >=3.1.13 && <3.2 + default-language: Haskell2010 + executable hscim-server - main-is: Main.hs - other-modules: - Paths_hscim - hs-source-dirs: - server - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + main-is: Main.hs + other-modules: Paths_hscim + hs-source-dirs: server + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints + -Wunused-packages + build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.15 - , bytestring >=0.10.8 && <0.11 - , case-insensitive >=1.2.1.0 && <1.3 - , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 + base + , email-validate , hscim - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.2 && <2.7 - , retry >=0.8.1.0 && <0.9 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.19 - , servant-client >=0.16.2 && <0.19 - , servant-client-core >=0.16.2 && <0.19 - , servant-server >=0.16.2 && <0.19 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.17 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.10 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 + , network-uri + , stm + , stm-containers + , time + , warp + default-language: Haskell2010 + test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs + type: exitcode-stdio-1.0 + main-is: Spec.hs other-modules: - Test.AcceptanceSpec - Test.Capabilities.MetaSchemaSpec - Test.Class.AuthSpec - Test.Class.GroupSpec - Test.Class.UserSpec - Test.FilterSpec - Test.MiscSpec - Test.Schema.AuthenticationSchemeSpec - Test.Schema.GroupSpec - Test.Schema.MetaSchemaSpec - Test.Schema.PatchOpSpec - Test.Schema.ResourceSpec - Test.Schema.UserSpec - Test.Schema.Util - Paths_hscim - hs-source-dirs: - test - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-tool-depends: - hspec-discover:hspec-discover + Paths_hscim + Test.AcceptanceSpec + Test.Capabilities.MetaSchemaSpec + Test.Class.AuthSpec + Test.Class.GroupSpec + Test.Class.UserSpec + Test.FilterSpec + Test.MiscSpec + Test.Schema.AuthenticationSchemeSpec + Test.Schema.GroupSpec + Test.Schema.MetaSchemaSpec + Test.Schema.PatchOpSpec + Test.Schema.ResourceSpec + Test.Schema.UserSpec + Test.Schema.Util + + hs-source-dirs: test + default-extensions: + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints + -Wunused-packages + + build-tool-depends: hspec-discover:hspec-discover build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.15 - , bytestring >=0.10.8 && <0.11 - , case-insensitive >=1.2.1.0 && <1.3 - , email-validate >=2.3.2 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 + aeson + , attoparsec + , base + , bytestring + , email-validate + , hedgehog , hscim - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.2 && <2.7 - , retry >=0.8.1.0 && <0.9 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.19 - , servant-client >=0.16.2 && <0.19 - , servant-client-core >=0.16.2 && <0.19 - , servant-server >=0.16.2 && <0.19 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , string-conversions >=0.4.0 && <0.5 - , template-haskell >=2.14.0 && <2.17 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.10 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 + , hspec + , hspec-expectations + , hspec-wai + , http-types + , hw-hspec-hedgehog + , indexed-traversable + , microlens + , network-uri + , servant + , servant-server + , stm-containers + , text + , wai + , wai-extra + + default-language: Haskell2010 diff --git a/server/Main.hs b/server/Main.hs --- a/server/Main.hs +++ b/server/Main.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/AttrName.hs b/src/Web/Scim/AttrName.hs --- a/src/Web/Scim/AttrName.hs +++ b/src/Web/Scim/AttrName.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -22,9 +22,10 @@ import Data.Aeson.Types (FromJSONKey, ToJSONKey) import Data.Attoparsec.ByteString.Char8 +import qualified Data.CaseInsensitive as CI import Data.Hashable import Data.String (IsString, fromString) -import Data.Text (Text, cons, toCaseFold) +import Data.Text (Text, cons) import Data.Text.Encoding (decodeUtf8) import Prelude hiding (takeWhile) @@ -38,13 +39,13 @@ deriving (Show, FromJSONKey, ToJSONKey) instance Eq AttrName where - AttrName a == AttrName b = toCaseFold a == toCaseFold b + AttrName a == AttrName b = CI.foldCase a == CI.foldCase b instance Ord AttrName where - compare (AttrName a) (AttrName b) = compare (toCaseFold a) (toCaseFold b) + compare (AttrName a) (AttrName b) = compare (CI.foldCase a) (CI.foldCase b) instance Hashable AttrName where - hashWithSalt x (AttrName a) = hashWithSalt x (toCaseFold a) + hashWithSalt x (AttrName a) = hashWithSalt x (CI.foldCase a) instance IsString AttrName where fromString = AttrName . fromString diff --git a/src/Web/Scim/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs --- a/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -27,7 +27,7 @@ where import Data.Aeson -import qualified Data.HashMap.Lazy as HML +import qualified Data.Aeson.KeyMap as KeyMap import Data.Text (Text) import Data.Typeable (Typeable, cast) import Servant hiding (URI) @@ -56,8 +56,8 @@ instance ToJSON a => ToJSON (Supported a) where toJSON (Supported (ScimBool b) v) = case toJSON v of - (Object o) -> Object $ HML.insert "supported" (Bool b) o - _ -> Object $ HML.fromList [("supported", Bool b)] + (Object o) -> Object $ KeyMap.insert "supported" (Bool b) o + _ -> Object $ KeyMap.fromList [("supported", Bool b)] -- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance -- better. @@ -81,7 +81,7 @@ toJSON = genericToJSON serializeOptions instance FromJSON BulkConfig where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower data FilterConfig = FilterConfig { maxResults :: Int @@ -92,7 +92,7 @@ toJSON = genericToJSON serializeOptions instance FromJSON FilterConfig where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower data Configuration = Configuration { documentationUri :: Maybe URI, @@ -111,7 +111,7 @@ toJSON = genericToJSON serializeOptions instance FromJSON Configuration where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower empty :: Configuration empty = diff --git a/src/Web/Scim/Capabilities/MetaSchema/Group.hs b/src/Web/Scim/Capabilities/MetaSchema/Group.hs --- a/src/Web/Scim/Capabilities/MetaSchema/Group.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Group.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs --- a/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs --- a/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Capabilities/MetaSchema/Schema.hs b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs --- a/src/Web/Scim/Capabilities/MetaSchema/Schema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Capabilities/MetaSchema/User.hs b/src/Web/Scim/Capabilities/MetaSchema/User.hs --- a/src/Web/Scim/Capabilities/MetaSchema/User.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/User.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Class/Auth.hs b/src/Web/Scim/Class/Auth.hs --- a/src/Web/Scim/Class/Auth.hs +++ b/src/Web/Scim/Class/Auth.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Class/Group.hs b/src/Web/Scim/Class/Group.hs --- a/src/Web/Scim/Class/Group.hs +++ b/src/Web/Scim/Class/Group.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -60,7 +60,7 @@ deriving (Show, Eq, Generic) instance FromJSON Member where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Member where toJSON = genericToJSON serializeOptions @@ -73,7 +73,7 @@ deriving (Show, Eq, Generic) instance FromJSON Group where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Group where toJSON = genericToJSON serializeOptions @@ -87,25 +87,25 @@ gsGetGroup :: route :- Capture "id" (GroupId tag) - :> Get '[SCIM] (StoredGroup tag), + :> Get '[SCIM] (StoredGroup tag), gsPostGroup :: route :- ReqBody '[SCIM] Group - :> PostCreated '[SCIM] (StoredGroup tag), + :> PostCreated '[SCIM] (StoredGroup tag), gsPutGroup :: route :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Group - :> Put '[SCIM] (StoredGroup tag), + :> ReqBody '[SCIM] Group + :> Put '[SCIM] (StoredGroup tag), gsPatchGroup :: route :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Aeson.Value - :> Patch '[SCIM] (StoredGroup tag), + :> ReqBody '[SCIM] Aeson.Value + :> Patch '[SCIM] (StoredGroup tag), gsDeleteGroup :: route :- Capture "id" (GroupId tag) - :> DeleteNoContent + :> DeleteNoContent } deriving (Generic) @@ -171,7 +171,7 @@ groupServer :: forall tag m. - (Show (GroupId tag), GroupDB tag m) => + GroupDB tag m => Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m)) groupServer authData = diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -3,7 +3,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -49,29 +49,29 @@ { usGetUsers :: route :- QueryParam "filter" Filter - :> Get '[SCIM] (ListResponse (StoredUser tag)), + :> Get '[SCIM] (ListResponse (StoredUser tag)), usGetUser :: route :- Capture "id" (UserId tag) - :> Get '[SCIM] (StoredUser tag), + :> Get '[SCIM] (StoredUser tag), usPostUser :: route :- ReqBody '[SCIM] (User tag) - :> PostCreated '[SCIM] (StoredUser tag), + :> PostCreated '[SCIM] (StoredUser tag), usPutUser :: route :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (User tag) - :> Put '[SCIM] (StoredUser tag), + :> ReqBody '[SCIM] (User tag) + :> Put '[SCIM] (StoredUser tag), usPatchUser :: route :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (PatchOp tag) - :> Patch '[SCIM] (StoredUser tag), + :> ReqBody '[SCIM] (PatchOp tag) + :> Patch '[SCIM] (StoredUser tag), usDeleteUser :: route :- Capture "id" (UserId tag) - :> DeleteNoContent + :> DeleteNoContent } deriving (Generic) diff --git a/src/Web/Scim/Client.hs b/src/Web/Scim/Client.hs --- a/src/Web/Scim/Client.hs +++ b/src/Web/Scim/Client.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -75,7 +75,7 @@ ) scimClients :: HasScimClient tag => ClientEnv -> Site tag (AsClientT IO) -scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO return +scimClients env = genericClientHoist $ \x -> runClientM x env >>= either throwIO pure -- config @@ -130,7 +130,7 @@ HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> - (User tag) -> + User tag -> IO (StoredUser tag) postUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> r)) :<|> (_ :<|> (_ :<|> _))) -> r @@ -139,7 +139,7 @@ ClientEnv -> Maybe (AuthData tag) -> UserId tag -> - (User tag) -> + User tag -> IO (StoredUser tag) putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r @@ -164,16 +164,12 @@ -- groups getGroups :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> IO (ListResponse (StoredGroup tag)) getGroups = error "groups are not authenticated at the moment; implement that first!" getGroup :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> GroupId tag -> @@ -181,8 +177,6 @@ getGroup = error "groups are not authenticated at the moment; implement that first!" postGroup :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> Group -> @@ -190,8 +184,6 @@ postGroup = error "groups are not authenticated at the moment; implement that first!" putGroup :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> GroupId tag -> @@ -199,8 +191,6 @@ putGroup = error "groups are not authenticated at the moment; implement that first!" patchGroup :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> GroupId tag -> @@ -208,8 +198,6 @@ patchGroup = error "groups are not authenticated at the moment; implement that first!" deleteGroup :: - forall tag. - HasScimClient tag => ClientEnv -> Maybe (AuthData tag) -> GroupId tag -> diff --git a/src/Web/Scim/ContentType.hs b/src/Web/Scim/ContentType.hs --- a/src/Web/Scim/ContentType.hs +++ b/src/Web/Scim/ContentType.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -14,7 +14,10 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use list literal" #-} + -- | SCIM defines its own content type (application/scim+json). It's -- intended to be used for all requests and responses; see the first -- paragraph in the SCIM specification at @@ -37,11 +40,11 @@ instance Accept SCIM where contentTypes _ = - "application" // "scim+json" /: ("charset", "utf-8") - :| "application" // "scim+json" : - "application" // "json" /: ("charset", "utf-8") : - "application" // "json" : - [] + ("application" // "scim+json" /: ("charset", "utf-8")) + :| [ "application" // "scim+json", + "application" // "json" /: ("charset", "utf-8"), + "application" // "json" + ] instance ToJSON a => MimeRender SCIM a where mimeRender _ = mimeRender (Proxy @JSON) diff --git a/src/Web/Scim/Filter.hs b/src/Web/Scim/Filter.hs --- a/src/Web/Scim/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -57,7 +57,7 @@ ) where -import Control.Applicative (optional, (<|>)) +import Control.Applicative (optional) import Data.Aeson as Aeson import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson @@ -176,7 +176,7 @@ -- @ pAttrPath :: [Schema] -> Parser AttrPath pAttrPath supportedSchemas = do - schema <- (Just <$> (pSchema supportedSchemas <* char ':')) <|> pure Nothing + schema <- optional (pSchema supportedSchemas <* char ':') AttrPath schema <$> pAttrName <*> optional pSubAttr -- | subAttr = "." ATTRNAME @@ -193,8 +193,8 @@ pCompValue = choice [ ValNull <$ string "null", - ValBool True <$ (stringCI "true"), - ValBool False <$ (stringCI "false"), + ValBool True <$ stringCI "true", + ValBool False <$ stringCI "false", ValNumber <$> Aeson.scientific, ValString <$> Aeson.jstring ] diff --git a/src/Web/Scim/Handler.hs b/src/Web/Scim/Handler.hs --- a/src/Web/Scim/Handler.hs +++ b/src/Web/Scim/Handler.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Schema/AuthenticationScheme.hs b/src/Web/Scim/Schema/AuthenticationScheme.hs --- a/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -67,7 +67,7 @@ instance FromJSON AuthenticationSchemeEncoding where -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower ---------------------------------------------------------------------------- -- Scheme encodings diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -1,9 +1,11 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -21,12 +23,12 @@ module Web.Scim.Schema.Common where import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.CaseInsensitive as CI -import qualified Data.Char as Char -import qualified Data.HashMap.Lazy as HML -import qualified Data.HashMap.Strict as HM +import Data.List (nub, (\\)) import Data.String.Conversions (cs) -import Data.Text hiding (dropWhile) +import Data.Text (Text, pack, unpack) import qualified Network.URI as Network data WithId id a = WithId @@ -37,7 +39,7 @@ instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where toJSON (WithId i v) = case toJSON v of - (Object o) -> Object (HML.insert "id" (toJSON i) o) + (Object o) -> Object (KeyMap.insert "id" (toJSON i) o) other -> other instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where @@ -83,17 +85,37 @@ parseOptions :: Options parseOptions = defaultOptions - { fieldLabelModifier = toKeyword . fmap Char.toLower + { fieldLabelModifier = toKeyword . CI.foldCase } -- | Turn all keys in a JSON object to lowercase recursively. This is applied to the aeson --- 'Value' to be parsed; 'parseOptions' is applied to the keys passed to '(.:)' etc. +-- 'Value' to be parsed; 'parseOptions' is applied to the keys passed to '(.:)' etc. If an +-- object contains two fields that only differ in casing, 'Left' is returned with a list of +-- the offending fields. -- +-- NB: be careful to not mix 'Data.Text.{toLower,toCaseFold}', 'Data.Char.toLower', and +-- 'Data.CaseInsensitive.foldCase'. They're not all the same thing! +-- https://github.com/basvandijk/case-insensitive/issues/31 +-- -- (FUTUREWORK: The "recursively" part is a bit of a waste and could be dropped, but we would -- have to spend more effort in making sure it is always called manually in nested parsers.) -jsonLower :: Value -> Value -jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o +jsonLower :: forall m. m ~ Either [Text] => Value -> m Value +jsonLower (Object (KeyMap.toList -> olist)) = + Object . KeyMap.fromList <$> (nubCI >> mapM lowerPair olist) where - lowerPair (key, val) = (toLower key, jsonLower val) -jsonLower (Array x) = Array (jsonLower <$> x) -jsonLower x = x + nubCI :: m () + nubCI = + let unnubbed = Key.toText . fst <$> olist + in case unnubbed \\ nub unnubbed of + [] -> pure () + bad@(_ : _) -> Left bad + lowerPair :: (Key.Key, Value) -> m (Key.Key, Value) + lowerPair (key, val) = (lowerKey key,) <$> jsonLower val +jsonLower (Array x) = Array <$> mapM jsonLower x +jsonLower same@(String _) = Right same -- (only object attributes, not all texts in the value side of objects!) +jsonLower same@(Number _) = Right same +jsonLower same@(Bool _) = Right same +jsonLower same@Null = Right same + +lowerKey :: Key.Key -> Key.Key +lowerKey = Key.fromText . CI.foldCase . Key.toText diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Schema/ListResponse.hs b/src/Web/Scim/Schema/ListResponse.hs --- a/src/Web/Scim/Schema/ListResponse.hs +++ b/src/Web/Scim/Schema/ListResponse.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -59,7 +59,7 @@ len = length list instance FromJSON a => FromJSON (ListResponse a) where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON a => ToJSON (ListResponse a) where toJSON ListResponse {..} = diff --git a/src/Web/Scim/Schema/Meta.hs b/src/Web/Scim/Schema/Meta.hs --- a/src/Web/Scim/Schema/Meta.hs +++ b/src/Web/Scim/Schema/Meta.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -18,7 +18,7 @@ module Web.Scim.Schema.Meta where import Data.Aeson -import qualified Data.HashMap.Lazy as HML +import qualified Data.Aeson.KeyMap as KeyMap import Data.Text (Text, pack, unpack) import qualified Data.Text as Text import Data.Time.Clock @@ -67,7 +67,7 @@ toJSON = genericToJSON serializeOptions instance FromJSON Meta where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower data WithMeta a = WithMeta { meta :: Meta, @@ -77,7 +77,7 @@ instance (ToJSON a) => ToJSON (WithMeta a) where toJSON (WithMeta m v) = case toJSON v of - (Object o) -> Object (HML.insert "meta" (toJSON m) o) + (Object o) -> Object (KeyMap.insert "meta" (toJSON m) o) other -> other instance (FromJSON a) => FromJSON (WithMeta a) where diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs --- a/src/Web/Scim/Schema/PatchOp.hs +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -19,16 +19,18 @@ import Control.Applicative import Control.Monad.Except +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText, (.:), (.:?), (.=)) import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) import Data.Bifunctor (first) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text, toCaseFold, toLower) +import qualified Data.CaseInsensitive as CI +import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Web.Scim.AttrName (AttrName (..)) import Web.Scim.Filter (AttrPath (..), SubAttr (..), ValuePath (..), pAttrPath, pSubAttr, pValuePath, rAttrPath, rSubAttr, rValuePath) +import Web.Scim.Schema.Common (lowerKey) import Web.Scim.Schema.Error import Web.Scim.Schema.Schema (Schema (PatchOp20)) import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) @@ -85,7 +87,7 @@ -- can't control what errors FromJSON throws :/ instance UserTypes tag => FromJSON (PatchOp tag) where parseJSON = withObject "PatchOp" $ \v -> do - let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v + let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v schemas' :: [Schema] <- o .: "schemas" guard $ PatchOp20 `elem` schemas' operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON (supportedSchemas @tag)) o "operations" @@ -100,19 +102,19 @@ operationFromJSON :: [Schema] -> Value -> Aeson.Parser Operation operationFromJSON schemas' = withObject "Operation" $ \v -> do - let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v + let o = KeyMap.fromList . map (first lowerKey) . KeyMap.toList $ v Operation <$> (o .: "op") - <*> (Aeson.explicitParseFieldMaybe (pathFromJSON schemas') o "path") + <*> Aeson.explicitParseFieldMaybe (pathFromJSON schemas') o "path" <*> (o .:? "value") pathFromJSON :: [Schema] -> Value -> Aeson.Parser Path pathFromJSON schemas' = - withText "Path" $ either fail pure . (parsePath schemas') + withText "Path" $ either fail pure . parsePath schemas' instance ToJSON Operation where toJSON (Operation op' path' value') = - object $ ("op" .= op') : concat [optionalField "path" path', optionalField "value" value'] + object $ ("op" .= op') : optionalField "path" path' ++ optionalField "value" value' where optionalField fname = \case Nothing -> [] @@ -120,7 +122,7 @@ instance FromJSON Op where parseJSON = withText "Op" $ \op' -> - case toCaseFold op' of + case CI.foldCase op' of "add" -> pure Add "replace" -> pure Replace "remove" -> pure Remove @@ -139,9 +141,9 @@ class Patchable a where applyOperation :: (MonadError ScimError m) => a -> Operation -> m a -instance Patchable (HM.HashMap Text Text) where +instance Patchable (KeyMap.KeyMap Text) where applyOperation theMap (Operation Remove (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) _) = - pure $ HM.delete attrName theMap + pure $ KeyMap.delete (Key.fromText attrName) theMap applyOperation theMap (Operation _AddOrReplace (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) (Just (String val))) = - pure $ HM.insert attrName val theMap + pure $ KeyMap.insert (Key.fromText attrName) val theMap applyOperation _ _ = throwError $ badRequest InvalidValue $ Just "Unsupported operation" diff --git a/src/Web/Scim/Schema/ResourceType.hs b/src/Web/Scim/Schema/ResourceType.hs --- a/src/Web/Scim/Schema/ResourceType.hs +++ b/src/Web/Scim/Schema/ResourceType.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -56,7 +56,7 @@ toJSON = genericToJSON serializeOptions instance FromJSON Resource where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower ---------------------------------------------------------------------------- -- Available resource endpoints diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -40,6 +40,26 @@ | PatchOp20 | CustomSchema Text deriving (Show, Eq) + +-- | 'Schema' is *almost* a straight-forward enum type, except for 'CustomSchema'. +-- Enumerations are nice because they let you write quickcheck generators as @elements +-- [minBound..]@. 'fakeEnumSchema' is a work-around. +fakeEnumSchema :: [Schema] +fakeEnumSchema = + [ User20, + ServiceProviderConfig20, + Group20, + Schema20, + ResourceType20, + ListResponse20, + Error20, + PatchOp20, + CustomSchema "", + CustomSchema "asdf", + CustomSchema "123", + CustomSchema "aos8wejv09837", + CustomSchema "aos8wejv09837wfeu09wuee0976t0213!!'#@" + ] instance FromJSON Schema where parseJSON = withText "schema" $ \t -> pure (fromSchemaUri t) diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -3,11 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -74,9 +73,10 @@ import Control.Monad.Except import Data.Aeson -import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.List ((\\)) -import Data.Text (Text, pack, toLower) +import Data.Text (Text, pack) import qualified Data.Text as Text import GHC.Generics (Generic) import Lens.Micro @@ -180,7 +180,7 @@ instance FromJSON (UserExtra tag) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields - let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj + let o = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList $ obj schemas <- o .:? "schemas" <&> \case Nothing -> [User20] @@ -211,7 +211,7 @@ instance ToJSON (UserExtra tag) => ToJSON (User tag) where toJSON User {..} = let mainObject = - HM.fromList $ + KeyMap.fromList $ concat [ ["schemas" .= schemas], ["userName" .= userName], @@ -238,8 +238,8 @@ extraObject = case toJSON extra of Null -> mempty Object x -> x - other -> HM.fromList ["extra" .= other] - in Object (HM.union mainObject extraObject) + other -> KeyMap.fromList ["extra" .= other] + in Object (KeyMap.union mainObject extraObject) where -- Omit a field if it's Nothing optionalField fname = \case @@ -315,12 +315,14 @@ (\x -> user {externalId = x}) <$> resultToScimError (fromJSON value) "active" -> (\x -> user {active = x}) <$> resultToScimError (fromJSON value) - _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active")) + "roles" -> + (\x -> user {roles = x}) <$> resultToScimError (fromJSON value) + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active, roles")) applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) applyUserOperation user (Operation Replace Nothing (Just value)) = do case value of - Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid", "active"]) -> do + Object hm | null ((AttrName . Key.toText <$> KeyMap.keys hm) \\ ["username", "displayname", "externalid", "active", "roles"]) -> do (u :: User tag) <- resultToScimError $ fromJSON value pure $ user @@ -329,7 +331,7 @@ externalId = externalId u, active = active u } - _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active")) + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active, roles")) applyUserOperation _ (Operation Replace _ Nothing) = throwError (badRequest InvalidValue (Just "No value was provided")) applyUserOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) @@ -339,6 +341,7 @@ "displayname" -> pure $ user {displayName = Nothing} "externalid" -> pure $ user {externalId = Nothing} "active" -> pure $ user {active = Nothing} + "roles" -> pure $ user {roles = []} _ -> pure user applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) @@ -348,7 +351,7 @@ | isUserSchema schema = applyUserOperation user op | isSupportedCustomSchema schema = (\x -> user {extra = x}) <$> applyOperation (extra user) op | otherwise = - throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> (Text.intercalate ", " $ map getSchemaUri (supportedSchemas @tag)) + throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> Text.intercalate ", " (map getSchemaUri (supportedSchemas @tag)) where isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) applyOperation user op = applyUserOperation user op diff --git a/src/Web/Scim/Schema/User/Address.hs b/src/Web/Scim/Schema/User/Address.hs --- a/src/Web/Scim/Schema/User/Address.hs +++ b/src/Web/Scim/Schema/User/Address.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -36,7 +36,7 @@ deriving (Show, Eq, Generic) instance FromJSON Address where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Address where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/Certificate.hs b/src/Web/Scim/Schema/User/Certificate.hs --- a/src/Web/Scim/Schema/User/Certificate.hs +++ b/src/Web/Scim/Schema/User/Certificate.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -29,7 +29,7 @@ deriving (Show, Eq, Generic) instance FromJSON Certificate where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Certificate where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/Email.hs b/src/Web/Scim/Schema/User/Email.hs --- a/src/Web/Scim/Schema/User/Email.hs +++ b/src/Web/Scim/Schema/User/Email.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -44,7 +44,7 @@ deriving (Show, Eq, Generic) instance FromJSON Email where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Email where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/IM.hs b/src/Web/Scim/Schema/User/IM.hs --- a/src/Web/Scim/Schema/User/IM.hs +++ b/src/Web/Scim/Schema/User/IM.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -29,7 +29,7 @@ deriving (Show, Eq, Generic) instance FromJSON IM where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON IM where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/Name.hs b/src/Web/Scim/Schema/User/Name.hs --- a/src/Web/Scim/Schema/User/Name.hs +++ b/src/Web/Scim/Schema/User/Name.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -36,7 +36,7 @@ emptyName = Name Nothing Nothing Nothing Nothing Nothing Nothing instance FromJSON Name where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Name where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/Phone.hs b/src/Web/Scim/Schema/User/Phone.hs --- a/src/Web/Scim/Schema/User/Phone.hs +++ b/src/Web/Scim/Schema/User/Phone.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -29,7 +29,7 @@ deriving (Show, Eq, Ord, Generic) instance FromJSON Phone where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Phone where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/User/Photo.hs b/src/Web/Scim/Schema/User/Photo.hs --- a/src/Web/Scim/Schema/User/Photo.hs +++ b/src/Web/Scim/Schema/User/Photo.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -29,7 +29,7 @@ deriving (Show, Eq, Generic) instance FromJSON Photo where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = either (fail . show) (genericParseJSON parseOptions) . jsonLower instance ToJSON Photo where toJSON = genericToJSON serializeOptions diff --git a/src/Web/Scim/Schema/UserTypes.hs b/src/Web/Scim/Schema/UserTypes.hs --- a/src/Web/Scim/Schema/UserTypes.hs +++ b/src/Web/Scim/Schema/UserTypes.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/src/Web/Scim/Server.hs b/src/Web/Scim/Server.hs --- a/src/Web/Scim/Server.hs +++ b/src/Web/Scim/Server.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -70,13 +70,13 @@ users :: route :- Header "Authorization" (AuthData tag) - :> "Users" - :> UserAPI tag, + :> "Users" + :> UserAPI tag, groups :: route :- Header "Authorization" (AuthData tag) - :> "Groups" - :> GroupAPI tag + :> "Groups" + :> GroupAPI tag } deriving (Generic) @@ -85,7 +85,7 @@ siteServer :: forall tag m. - (DB tag m, Show (GroupId tag)) => + DB tag m => Configuration -> Site tag (AsServerT (ScimHandler m)) siteServer conf = @@ -94,7 +94,6 @@ users = \authData -> toServant (userServer @tag authData), groups = \authData -> toServant (groupServer @tag authData) } - where ---------------------------------------------------------------------------- -- Server-starting utilities diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -3,7 +3,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -27,8 +27,9 @@ import Control.Monad.Reader import Control.Monad.STM (STM, atomically) import Data.Aeson +import qualified Data.CaseInsensitive as CI import Data.Hashable -import Data.Text (Text, pack, toCaseFold) +import Data.Text (Text, pack) import Data.Time.Calendar import Data.Time.Clock import GHC.Exts (sortWith) @@ -103,7 +104,7 @@ instance UserDB Mock TestServer where getUsers () mbFilter = do - m <- userDB <$> ask + m <- asks userDB users <- liftSTM $ ListT.toList $ STMMap.listT m let check user = case mbFilter of Nothing -> pure True @@ -115,20 +116,20 @@ fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) getUser () uid = do - m <- userDB <$> ask + m <- asks userDB liftSTM (STMMap.lookup uid m) >>= \case Nothing -> throwScim (notFound "User" (pack (show uid))) Just x -> pure x postUser () user = do - m <- userDB <$> ask + m <- asks userDB uid <- Id <$> liftSTM (STMMap.size m) let newUser = WithMeta (createMeta UserResource) $ WithId uid user liftSTM $ STMMap.insert newUser uid m - return newUser + pure newUser putUser () uid user = do - m <- userDB <$> ask + m <- asks userDB liftSTM (STMMap.lookup uid m) >>= \case Nothing -> throwScim (notFound "User" (pack (show uid))) Just stored -> do @@ -137,7 +138,7 @@ pure newUser deleteUser () uid = do - m <- userDB <$> ask + m <- asks userDB liftSTM (STMMap.lookup uid m) >>= \case Nothing -> throwScim (notFound "User" (pack (show uid))) Just _ -> liftSTM $ STMMap.delete uid m @@ -154,25 +155,25 @@ instance GroupDB Mock TestServer where getGroups () = do - m <- groupDB <$> ask + m <- asks groupDB groups <- liftSTM $ ListT.toList $ STMMap.listT m - return $ fromList . sortWith (Common.id . thing) $ snd <$> groups + pure $ fromList . sortWith (Common.id . thing) $ snd <$> groups getGroup () gid = do - m <- groupDB <$> ask + m <- asks groupDB liftSTM (STMMap.lookup gid m) >>= \case Nothing -> throwScim (notFound "Group" (pack (show gid))) Just grp -> pure grp postGroup () grp = do - m <- groupDB <$> ask + m <- asks groupDB gid <- Id <$> liftSTM (STMMap.size m) let newGroup = WithMeta (createMeta GroupResource) $ WithId gid grp liftSTM $ STMMap.insert newGroup gid m - return newGroup + pure newGroup putGroup () gid grp = do - m <- groupDB <$> ask + m <- asks groupDB liftSTM (STMMap.lookup gid m) >>= \case Nothing -> throwScim (notFound "Group" (pack (show gid))) Just stored -> do @@ -183,7 +184,7 @@ patchGroup _ _ _ = throwScim (serverError "PATCH /Users not implemented") deleteGroup () gid = do - m <- groupDB <$> ask + m <- asks groupDB liftSTM (STMMap.lookup gid m) >>= \case Nothing -> throwScim (notFound "Group" (pack (show gid))) Just _ -> liftSTM $ STMMap.delete gid m @@ -241,13 +242,13 @@ filterUser :: Filter -> User extra -> Either Text Bool filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user | isUserSchema schema' = - case (subAttr, val) of - (Nothing, (ValString str)) - | attrib == "userName" -> - Right (compareStr op (toCaseFold (userName user)) (toCaseFold str)) - (Nothing, _) - | attrib == "userName" -> - Left "usernames can only be compared with strings" - (_, _) -> - Left "Only search on usernames is currently supported" + case (subAttr, val) of + (Nothing, ValString str) + | attrib == "userName" -> + Right (compareStr op (CI.foldCase (userName user)) (CI.foldCase str)) + (Nothing, _) + | attrib == "userName" -> + Left "usernames can only be compared with strings" + (_, _) -> + Left "Only search on usernames is currently supported" | otherwise = Left "Invalid schema. Only user schema is supported" diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -4,7 +4,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -264,7 +264,7 @@ -- Delete User delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204 delete' queryConfig ("/Users/" <> testuid) "" `shouldEventuallyRespondWith` 404 - it "Group operations" $ \_ -> pending + it "Group operations" $ const pending sampleUser1 :: Text -> L.ByteString sampleUser1 userName1 = diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -1,10 +1,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -52,13 +53,14 @@ import qualified Control.Retry as Retry import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.QQ import Data.Aeson.Types (JSONPathElement (Key)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as L -import qualified Data.HashMap.Strict as SMap import Data.Proxy import Data.Text import Data.UUID as UUID @@ -81,17 +83,17 @@ -- FUTUREWORK: make this a PR upstream. (while we're at it, we can also patch 'WaiSession' -- and 'request' to keep track of the 'SRequest', and add that to the error message here with -- the response.) -shouldRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation +shouldRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldRespondWith action matcher = either (liftIO . expectationFailure) pure =<< doesRespondWith action matcher -doesRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiSession (Either String ()) +doesRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiSession st (Either String ()) doesRespondWith action matcher = do r <- action let extmsg = " details: " <> show r <> "\n" pure $ maybe (Right ()) (Left . (<> extmsg)) (match r matcher) -shouldEventuallyRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation +shouldEventuallyRespondWith :: HasCallStack => WaiSession st SResponse -> ResponseMatcher -> WaiExpectation st shouldEventuallyRespondWith action matcher = either (liftIO . expectationFailure) pure =<< Retry.retrying @@ -101,6 +103,7 @@ data AcceptanceConfig tag = AcceptanceConfig { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag), + -- TODO: add a destructor, something like: @destroy :: CustomEnv tag -> IO ()@, genUserName :: IO Text, -- | some acceptance tests match against a fully rendered -- response body, which will not work when running the test @@ -148,31 +151,31 @@ a' = maybe a (\(t, l) -> if l == '/' then t else a) $ BS8.unsnoc a b' = maybe b (\(h, t) -> if h == '/' then t else b) $ BS8.uncons b -post :: ByteString -> L.ByteString -> WaiSession SResponse +post :: ByteString -> L.ByteString -> WaiSession st SResponse post path = request methodPost path [(hContentType, "application/scim+json")] -put :: ByteString -> L.ByteString -> WaiSession SResponse +put :: ByteString -> L.ByteString -> WaiSession st SResponse put path = request methodPut path [(hContentType, "application/scim+json")] -patch :: ByteString -> L.ByteString -> WaiSession SResponse +patch :: ByteString -> L.ByteString -> WaiSession st SResponse patch path = request methodPatch path [(hContentType, "application/scim+json")] -request' :: Method -> AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +request' :: Method -> AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse request' method (AcceptanceQueryConfig prefix token) path = request method (prefix path) [(hAuthorization, token), (hContentType, "application/scim+json")] -get' :: AcceptanceQueryConfig tag -> ByteString -> WaiSession SResponse +get' :: AcceptanceQueryConfig tag -> ByteString -> WaiSession st SResponse get' cfg path = request' methodGet cfg path "" -post' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +post' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse post' = request' methodPost -put' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +put' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse put' = request' methodPut -patch' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +patch' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse patch' = request' methodPatch -delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession st SResponse delete' = request' methodDelete ---------------------------------------------------------------------------- @@ -230,16 +233,16 @@ -- Copied from https://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where parseJSON = withObject ("Field " <> show key) $ \obj -> - case SMap.lookup key obj of + case KeyMap.lookup key obj of Nothing -> fail $ "key " ++ show key ++ " not present" Just v -> Field <$> parseJSON v Key key where - key = pack $ symbolVal (Proxy :: Proxy s) + key = Key.fromString $ symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where toJSON (Field x) = object [key .= x] where - key = pack $ symbolVal (Proxy :: Proxy s) + key = Key.fromString $ symbolVal (Proxy :: Proxy s) ---------------------------------------------------------------------------- -- Tag diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs --- a/test/Test/AcceptanceSpec.hs +++ b/test/Test/AcceptanceSpec.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -28,7 +28,6 @@ import Data.Text (Text) import Network.Wai.Test (SResponse (..)) import Servant -import Servant.API.Generic import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) @@ -44,9 +43,9 @@ shouldSatisfy :: (Show a, FromJSON a) => - WaiSession SResponse -> + WaiSession st SResponse -> (a -> Bool) -> - WaiExpectation + WaiExpectation st shouldSatisfy resp predicate = do maybeDecoded <- eitherDecode . simpleBody <$> resp case maybeDecoded of @@ -69,7 +68,7 @@ ] spec :: Spec -spec = beforeAll app $ do +spec = with app $ do describe "GET /Schemas" $ do it "lists schemas" $ do get "/Schemas" `shouldRespondWith` 200 diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE QuasiQuotes #-} - -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -37,7 +35,7 @@ testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO spec :: Spec -spec = beforeAll ((\s -> app @Mock empty (nt s)) <$> testStorage) $ do +spec = with ((\s -> app @Mock empty (nt s)) <$> testStorage) $ do describe "/ServiceProviderConfig" $ do it "is accessible without authentication" $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -43,7 +43,7 @@ (nt storage) spec :: Spec -spec = beforeAll app $ do +spec = with app $ do describe "GET & POST /Groups" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` emptyList @@ -54,17 +54,21 @@ it "responds with 404 for unknown group" $ do get "/9999" `shouldRespondWith` 404 it "retrieves stored group" $ do + post "/" adminGroup `shouldRespondWith` 201 -- the test implementation stores groups with uid [0,1..n-1] get "/0" `shouldRespondWith` admins describe "PUT /Groups/:id" $ do it "adds member to existing group" $ do + post "/" adminGroup `shouldRespondWith` 201 put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 it "does not create new group" $ do put "/9999" adminGroup `shouldRespondWith` 404 describe "DELETE /Groups/:id" $ do it "responds with 404 for unknown group" $ do + post "/" adminGroup `shouldRespondWith` 201 delete "/Users/unknown" `shouldRespondWith` 404 it "deletes a stored group" $ do + post "/" adminGroup `shouldRespondWith` 201 delete "/0" `shouldRespondWith` 204 -- group should be gone get "/0" `shouldRespondWith` 404 diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -2,7 +2,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -39,7 +39,7 @@ pure $ mkapp @Mock (Proxy @(UserAPI Mock)) (toServant (userServer auth)) (nt storage) spec :: Spec -spec = beforeAll app $ do +spec = with app $ do describe "GET & POST /Users" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` emptyList @@ -49,17 +49,23 @@ get "/" `shouldRespondWith` allUsers describe "filtering" $ do it "can filter by username" $ do + post "/" newBarbara `shouldRespondWith` 201 get "/?filter=userName eq \"bjensen\"" `shouldRespondWith` onlyBarbara it "is case-insensitive regarding syntax" $ do + post "/" newBarbara `shouldRespondWith` 201 get "/?filter=USERName EQ \"bjensen\"" `shouldRespondWith` onlyBarbara it "is case-insensitive regarding usernames" $ do + post "/" newBarbara `shouldRespondWith` 201 get "/?filter=userName eq \"BJensen\"" `shouldRespondWith` onlyBarbara it "handles malformed filter syntax" $ do + post "/" newBarbara `shouldRespondWith` 201 get "/?filter=userName eqq \"bjensen\"" `shouldRespondWith` 400 -- TODO: would be nice to check the error message as well it "handles type errors in comparisons" $ do + post "/" newBarbara `shouldRespondWith` 201 get "/?filter=userName eq true" `shouldRespondWith` 400 + describe "GET /Users/:id" $ do it "responds with 404 for unknown user" $ do get "/9999" `shouldRespondWith` 404 @@ -68,12 +74,15 @@ xit "responds with 401 for unparseable user ID" $ do get "/unparseable" `shouldRespondWith` 401 it "retrieves stored user" $ do + post "/" newBarbara `shouldRespondWith` 201 -- the test implementation stores users with uid [0,1..n-1] get "/0" `shouldRespondWith` barbara describe "PUT /Users/:id" $ do it "overwrites the user" $ do + post "/" newBarbara `shouldRespondWith` 201 put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 it "does not create new users" $ do + post "/" newBarbara `shouldRespondWith` 201 put "/9999" newBarbara `shouldRespondWith` 404 -- TODO(arianvp): Perhaps we want to make this an acceptance spec. describe "PATCH /Users/:id" $ do @@ -82,6 +91,7 @@ -- TODO(arianvp): We need to merge multi-value fields, but not supported yet -- TODO(arianvp): Add and Replace tests currently identical, because of lack of multi-value it "adds all fields if no target" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -116,6 +126,7 @@ { matchStatus = 200 } it "adds fields if they didn't exist yet" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -147,6 +158,7 @@ { matchStatus = 200 } it "replaces individual simple fields" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -183,6 +195,7 @@ -- not limit by type what fields it lenses in to. It is a very untyped -- thingy currently. it "PatchOp is atomic. Either fully applies or not at all" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -202,6 +215,7 @@ describe "Replace" $ do -- TODO(arianvp): Implement and test multi-value fields properly it "adds all fields if no target" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -236,6 +250,7 @@ { matchStatus = 200 } it "adds fields if they didn't exist yet" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -267,6 +282,7 @@ { matchStatus = 200 } it "replaces individual simple fields" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -298,6 +314,7 @@ { matchStatus = 200 } it "PatchOp is atomic. Either fully applies or not at all" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -316,6 +333,7 @@ get "/0" `shouldRespondWith` smallUserGet {matchStatus = 200} describe "Remove" $ do it "fails if no target" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" barbUpdate0 -- reset patch "/0" @@ -329,6 +347,7 @@ { matchStatus = 400 } it "fails if removing immutable" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" barbUpdate0 -- reset patch "/0" @@ -342,6 +361,7 @@ { matchStatus = 400 } it "deletes the specified attribute" $ do + post "/" newBarbara `shouldRespondWith` 201 _ <- put "/0" smallUser -- reset patch "/0" @@ -369,6 +389,7 @@ it "responds with 404 for unknown user" $ do delete "/9999" `shouldRespondWith` 404 it "deletes a stored user" $ do + post "/" newBarbara `shouldRespondWith` 201 delete "/0" `shouldRespondWith` 204 -- user should be gone get "/0" `shouldRespondWith` 404 diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -1,9 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE QuasiQuotes #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/MiscSpec.hs b/test/Test/MiscSpec.hs --- a/test/Test/MiscSpec.hs +++ b/test/Test/MiscSpec.hs @@ -1,9 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE QuasiQuotes #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/Schema/AuthenticationSchemeSpec.hs b/test/Test/Schema/AuthenticationSchemeSpec.hs --- a/test/Test/Schema/AuthenticationSchemeSpec.hs +++ b/test/Test/Schema/AuthenticationSchemeSpec.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/Schema/GroupSpec.hs b/test/Test/Schema/GroupSpec.hs --- a/test/Test/Schema/GroupSpec.hs +++ b/test/Test/Schema/GroupSpec.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -46,15 +46,15 @@ genMember :: Gen GroupClass.Member genMember = GroupClass.Member - <$> (Gen.text (Range.constant 0 20) Gen.unicode) - <*> (Gen.text (Range.constant 0 20) Gen.unicode) - <*> (Gen.text (Range.constant 0 20) Gen.unicode) + <$> Gen.text (Range.constant 0 20) Gen.unicode + <*> Gen.text (Range.constant 0 20) Gen.unicode + <*> Gen.text (Range.constant 0 20) Gen.unicode genGroup :: Gen GroupClass.Group genGroup = GroupClass.Group <$> Gen.list (Range.linear 0 10) genSchema - <*> (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.text (Range.constant 0 20) Gen.unicode <*> Gen.list (Range.linear 0 10) genMember genSchema :: Gen Text diff --git a/test/Test/Schema/MetaSchemaSpec.hs b/test/Test/Schema/MetaSchemaSpec.hs --- a/test/Test/Schema/MetaSchemaSpec.hs +++ b/test/Test/Schema/MetaSchemaSpec.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -48,7 +45,7 @@ describe "MetaSchema" $ do -- the extra 'decode' in the golden tests is to make attribute order not count for Eq. it "`Supported ()` golden test" $ do - decode @Value (encode (Supported (ScimBool True) ())) `shouldBe` decode @Value ("{\"supported\":true}") + decode @Value (encode (Supported (ScimBool True) ())) `shouldBe` decode @Value "{\"supported\":true}" it "`Supported a` golden test" $ do decode @Value (encode (Supported (ScimBool True) (FilterConfig 3))) `shouldBe` decode @Value "{\"supported\":true,\"maxResults\":3}" it "`Supported ()` roundtrips" $ do @@ -98,5 +95,6 @@ genSupported :: forall a. Gen a -> Gen (Supported a) genSupported gen = do - Supported <$> (ScimBool <$> Gen.bool) + Supported + <$> (ScimBool <$> Gen.bool) <*> gen diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs --- a/test/Test/Schema/PatchOpSpec.hs +++ b/test/Test/Schema/PatchOpSpec.hs @@ -3,7 +3,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -21,13 +21,12 @@ module Test.Schema.PatchOpSpec where import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Result (Error, Success), Value (String), fromJSON, toJSON) import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (parseOnly) import Data.Either (isLeft) import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import HaskellWorks.Hspec.Hedgehog (require) @@ -82,24 +81,24 @@ spec :: Spec spec = do - describe "Patchable" $ do + describe "Patchable" $ describe "HashMap Text Text" $ do it "supports `Add` operation" $ do - let theMap :: HashMap Text Text = HM.empty + let theMap = KeyMap.empty @Text operation = Operation Add (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value" - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key" "value") it "supports `Replace` operation" $ do - let theMap :: HashMap Text Text = HM.singleton "key" "value1" + let theMap = KeyMap.singleton @Text "key" "value1" operation = Operation Replace (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value2" - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value2") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key" "value2") it "supports `Delete` operation" $ do - let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] + let theMap = KeyMap.fromList @Text [("key1", "value1"), ("key2", "value2")] operation = Operation Remove (Just $ NormalPath (AttrPath Nothing (AttrName "key1") Nothing)) Nothing - applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key2" "value2") + applyOperation theMap operation `shouldBe` Right (KeyMap.singleton "key2" "value2") it "gracefully rejects invalid/unsupported operations" $ do - let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] - key1Path = (AttrPath Nothing (AttrName "key1") Nothing) - key2Path = (AttrPath Nothing (AttrName "key2") Nothing) + let theMap = KeyMap.fromList @Text [("key1", "value1"), ("key2", "value2")] + key1Path = AttrPath Nothing (AttrName "key1") Nothing + key2Path = AttrPath Nothing (AttrName "key2") Nothing invalidOperations = [ Operation Add (Just $ NormalPath key1Path) Nothing, -- Nothing to add Operation Replace (Just $ NormalPath key1Path) Nothing, -- Nothing to replace @@ -108,7 +107,7 @@ ] mapM_ (\o -> applyOperation theMap o `shouldSatisfy` isLeft) invalidOperations describe "urn:ietf:params:scim:api:messages:2.0:PatchOp" $ do - describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ do + describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ it "rejects an empty schemas list" $ do fromJSON @(PatchOp PatchTestTag) [scim| { @@ -116,11 +115,11 @@ "operations": [] }|] `shouldSatisfy` (not . isSuccess) - --TODO(arianvp): We don't support arbitrary path names (yet) + -- TODO(arianvp): We don't support arbitrary path names (yet) it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag it "case-insensitive" $ require $ mk_prop_caseInsensitive (genSimplePatchOp @PatchTestTag) - it "rejects invalid operations" $ do + it "rejects invalid operations" $ fromJSON @(PatchOp PatchTestTag) [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], @@ -128,9 +127,9 @@ }|] `shouldSatisfy` (not . isSuccess) -- TODO(arianvp/akshay): Implement if required - xit "rejects unknown paths" $ do + xit "rejects unknown paths" $ Aeson.parse (pathFromJSON [User20]) (Aeson.String "unknown.field") `shouldSatisfy` (not . isSuccess) - it "rejects invalid paths" $ do + it "rejects invalid paths" $ Aeson.parse (pathFromJSON [User20]) "unknown]field" `shouldSatisfy` (not . isSuccess) describe "Examples from https://tools.ietf.org/html/rfc7644#section-3.5.2 Figure 8" $ do let examples = @@ -140,4 +139,4 @@ "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]", "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" ] - for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p) `shouldBe` Right (decodeUtf8 p) + for_ examples $ \p -> it ("parses " ++ show p) $ rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p `shouldBe` Right (decodeUtf8 p) diff --git a/test/Test/Schema/ResourceSpec.hs b/test/Test/Schema/ResourceSpec.hs --- a/test/Test/Schema/ResourceSpec.hs +++ b/test/Test/Schema/ResourceSpec.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -1,10 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -25,10 +26,10 @@ where import Data.Aeson +import qualified Data.Aeson.KeyMap as KeyMap import Data.Either (isLeft, isRight) import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HM -import Data.Text (Text, toLower) +import Data.Text (Text) import HaskellWorks.Hspec.Hedgehog (require) import Hedgehog import qualified Hedgehog.Gen as Gen @@ -40,7 +41,7 @@ import Text.Email.Validate (emailAddress) import qualified Web.Scim.Class.User as UserClass import Web.Scim.Filter (AttrPath (..)) -import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..)) +import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..), lowerKey) import qualified Web.Scim.Schema.ListResponse as ListResponse import Web.Scim.Schema.Meta (ETag (Strong, Weak), Meta (..), WithMeta (..)) import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..), Path (..)) @@ -64,14 +65,14 @@ type PatchTag = TestTag Text () () UserExtraPatch -type UserExtraPatch = HM.HashMap Text Text +type UserExtraPatch = KeyMap.KeyMap Text spec :: Spec spec = do describe "applyPatch" $ do it "only applies patch for supported fields" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras for_ [ ("username", String "lol"), @@ -85,7 +86,7 @@ User.applyPatch user patchOp `shouldSatisfy` isRight it "does not support multi-value attributes" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras for_ [ ("schemas", toJSON @[Schema] mempty), @@ -103,7 +104,6 @@ ("photos", toJSON @[Photo] mempty), ("addresses", toJSON @[Address] mempty), ("entitlements", toJSON @[Text] mempty), - ("roles", toJSON @[Text] mempty), ("x509Certificates", toJSON @[Certificate] mempty) ] $ \(key, upd) -> do @@ -112,12 +112,12 @@ User.applyPatch user patchOp `shouldSatisfy` isLeft it "applies patch to `extra`" $ do let schemas' = [] - let extras = HM.empty + let extras = KeyMap.empty let user :: User PatchTag = User.empty schemas' "hello" extras let Right programmingLanguagePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "urn:hscim:test:programmingLanguage" let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell")) let patchOp = PatchOp [operation] - User.extra <$> (User.applyPatch user patchOp) `shouldBe` Right (HM.singleton "programmingLanguage" "haskell") + User.extra <$> User.applyPatch user patchOp `shouldBe` Right (KeyMap.singleton "programmingLanguage" "haskell") describe "JSON serialization" $ do it "handles all fields" $ do require prop_roundtrip @@ -129,7 +129,7 @@ it "treats 'null' and '[]' as absence of fields" $ eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser it "allows casing variations in field names" $ do - require $ mk_prop_caseInsensitive (genUser) + require $ mk_prop_caseInsensitive genUser require $ mk_prop_caseInsensitive (ListResponse.fromList . (: []) <$> genStoredUser) eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser it "doesn't require the 'schemas' field" $ @@ -157,12 +157,12 @@ genStoredUser = do m <- genMeta i <- Gen.element @_ @Text ["wef", "asdf", "@", "#", "1"] - u <- genUser - pure $ WithMeta m (WithId i u) + WithMeta m . WithId i <$> genUser genMeta :: Gen Meta genMeta = - Meta <$> Gen.enumBounded + Meta + <$> Gen.enumBounded <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2019-01-01 09:55:59 UTC"] <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2022-01-01 09:55:59 UTC"] <*> (Gen.element [Weak, Strong] <*> Gen.text (Range.constant 0 20) Gen.unicode) @@ -172,7 +172,7 @@ -- lists in the first place genUser :: Gen (User (TestTag Text () () NoUserExtra)) genUser = do - schemas' <- pure [User20] -- TODO random schemas or? + let schemas' = [User20] -- TODO random schemas or? userName' <- Gen.text (Range.constant 0 20) Gen.unicode externalId' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode name' <- Gen.maybe genName @@ -185,14 +185,14 @@ locale' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode active' <- Gen.maybe $ (ScimBool <$> Gen.bool) password' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode - emails' <- pure [] -- Gen.list (Range.constant 0 20) genEmail - phoneNumbers' <- pure [] -- Gen.list (Range.constant 0 20) genPhone - ims' <- pure [] -- Gen.list (Range.constant 0 20) genIM - photos' <- pure [] -- Gen.list (Range.constant 0 20) genPhoto - addresses' <- pure [] -- Gen.list (Range.constant 0 20) genAddress - entitlements' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 20) Gen.unicode) - roles' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 10) Gen.unicode) - x509Certificates' <- pure [] -- Gen.list (Range.constant 0 20) genCertificate + let emails' = [] -- Gen.list (Range.constant 0 20) genEmail + let phoneNumbers' = [] -- Gen.list (Range.constant 0 20) genPhone + let ims' = [] -- Gen.list (Range.constant 0 20) genIM + let photos' = [] -- Gen.list (Range.constant 0 20) genPhoto + let addresses' = [] -- Gen.list (Range.constant 0 20) genAddress + let entitlements' = [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 20) Gen.unicode) + let roles' = [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 10) Gen.unicode) + let x509Certificates' = [] -- Gen.list (Range.constant 0 20) genCertificate pure $ User { schemas = schemas', @@ -443,7 +443,7 @@ Nothing -> pure UserExtraEmpty Just (lowercase -> o2) -> UserExtraObject <$> o2 .: "test" where - lowercase = HM.fromList . map (over _1 toLower) . HM.toList + lowercase = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList instance ToJSON UserExtraTest where toJSON UserExtraEmpty = object [] @@ -456,7 +456,7 @@ -- | A 'User' with extra fields present. extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest) extendedUser e = - (User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) + User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e -- | Encoding of @extendedUser UserExtraEmpty@. extendedUserEmptyJson :: Value diff --git a/test/Test/Schema/Util.hs b/test/Test/Schema/Util.hs --- a/test/Test/Schema/Util.hs +++ b/test/Test/Schema/Util.hs @@ -1,8 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} + -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2022 Wire Swiss GmbH -- -- 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 @@ -25,10 +28,13 @@ where import Data.Aeson -import qualified Data.HashMap.Strict as HM -import Data.Text (Text, toLower, toUpper) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap as KeyMap +import Data.Foldable.WithIndex (ifoldl') +import Data.Text (Text, toCaseFold, toLower, toUpper) import Hedgehog import Hedgehog.Gen as Gen +import Lens.Micro (over) import Network.URI.Static import Web.Scim.Schema.Common (URI (..)) @@ -43,12 +49,16 @@ val <- forAll gen fromJSON (withCasing toUpper $ toJSON val) === Success val fromJSON (withCasing toLower $ toJSON val) === Success val + fromJSON (withCasing toCaseFold $ toJSON val) === Success val where withCasing :: (Text -> Text) -> Value -> Value withCasing toCasing = \case - Object obj -> Object $ HM.foldlWithKey' (\u k v -> HM.insert (toCasing k) (withCasing toCasing v) u) HM.empty obj + Object obj -> Object $ ifoldl' (\k u v -> KeyMap.insert (over keyTextL toCasing k) (withCasing toCasing v) u) KeyMap.empty obj Array arr -> Array $ withCasing toCasing <$> arr same@(Number _) -> same same@(String _) -> same same@(Bool _) -> same same@Null -> same + +keyTextL :: Functor f => (Text -> f Text) -> Key -> f Key +keyTextL f key = fmap Key.fromText (f (Key.toText key))