hscim client

libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs

@@ -29,6 +29,7 @@ where
 import Data.Aeson
 import qualified Data.HashMap.Lazy as HML
 import Data.Text (Text)
+import Data.Typeable (Typeable, cast)
 import Servant hiding (URI)
 import Servant.API.Generic
 import Servant.Server.Generic
@@ -39,7 +40,7 @@ import Web.Scim.Capabilities.MetaSchema.Schema
 import Web.Scim.Capabilities.MetaSchema.User
 import Web.Scim.ContentType
 import Web.Scim.Handler
-import Web.Scim.Schema.AuthenticationScheme
+import qualified Web.Scim.Schema.AuthenticationScheme as AuthScheme
 import Web.Scim.Schema.Common
 import Web.Scim.Schema.Error hiding (schemas)
 import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas)
@@ -58,6 +59,16 @@ instance ToJSON a => ToJSON (Supported a) where
     (Object o) -> Object $ HML.insert "supported" (Bool b) o
     _ -> Object $ HML.fromList [("supported", Bool b)]
 
+instance (Typeable a, FromJSON a) => FromJSON (Supported a) where
+  parseJSON val = do
+    Supported
+      <$> withObject "Supported a" (.: "supported") val
+      <*> let -- allow special case for empty subConfig (`()` does not parse from json objects)
+              val' = case cast @() @a () of
+                Just _ -> Array mempty
+                Nothing -> val
+           in parseJSON @a val'
+
 data BulkConfig = BulkConfig
   { maxOperations :: Int,
     maxPayloadSize :: Int
@@ -67,6 +78,10 @@ data BulkConfig = BulkConfig
 instance ToJSON BulkConfig where
   toJSON = genericToJSON serializeOptions
 
+instance FromJSON BulkConfig where
+  parseJSON = withObject "BulkConfig" $ \obj -> do
+    BulkConfig <$> obj .: "maxOperations" <*> obj .: "maxPayloadSize"
+
 data FilterConfig = FilterConfig
   { maxResults :: Int
   }
@@ -75,6 +90,9 @@ data FilterConfig = FilterConfig
 instance ToJSON FilterConfig where
   toJSON = genericToJSON serializeOptions
 
+instance FromJSON FilterConfig where
+  parseJSON = genericParseJSON serializeOptions
+
 data Configuration = Configuration
   { documentationUri :: Maybe URI,
     schemas :: [Schema],
@@ -84,13 +102,16 @@ data Configuration = Configuration
     changePassword :: Supported (),
     sort :: Supported (),
     etag :: Supported (),
-    authenticationSchemes :: [AuthenticationSchemeEncoding]
+    authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding]
   }
   deriving (Show, Eq, Generic)
 
 instance ToJSON Configuration where
   toJSON = genericToJSON serializeOptions
 
+instance FromJSON Configuration where
+  parseJSON = genericParseJSON serializeOptions
+
 empty :: Configuration
 empty =
   Configuration
@@ -108,7 +129,7 @@ empty =
       changePassword = Supported (ScimBool False) (),
       sort = Supported (ScimBool False) (),
       etag = Supported (ScimBool False) (),
-      authenticationSchemes = [authHttpBasicEncoding]
+      authenticationSchemes = [AuthScheme.authHttpBasicEncoding]
     }
 
 configServer ::

libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs

@@ -19,7 +19,7 @@
 
 module Web.Scim.Schema.AuthenticationScheme
   ( AuthenticationScheme (..),
-    AuthenticationSchemeEncoding,
+    AuthenticationSchemeEncoding (..),
     authHttpBasicEncoding,
   )
 where
@@ -65,6 +65,9 @@ data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding
 instance ToJSON AuthenticationSchemeEncoding where
   toJSON = genericToJSON serializeOptions
 
+instance FromJSON AuthenticationSchemeEncoding where
+  parseJSON = genericParseJSON serializeOptions
+
 -- NB: "typ" will be converted to "type" thanks to 'serializeOptions'
 
 ----------------------------------------------------------------------------

libs/hscim/src/Web/Scim/Server.hs

@@ -25,6 +25,7 @@ module Web.Scim.Server
 
     -- * API tree
     SiteAPI,
+    Site (..),
     siteServer,
 
     -- ** API subtrees, useful for tests

libs/hscim/test/Test/Schema/MetaSchemaSpec.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Test.Schema.MetaSchemaSpec
+  ( spec,
+  )
+where
+
+import Data.Aeson
+import Data.Text (Text)
+import HaskellWorks.Hspec.Hedgehog (require)
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Network.URI.Static (uri)
+import Test.Hspec
+import Web.Scim.Capabilities.MetaSchema
+import Web.Scim.Schema.AuthenticationScheme
+import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..))
+import Web.Scim.Schema.Schema (Schema (..))
+import Prelude hiding (filter)
+
+prop_roundtrip :: (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property
+prop_roundtrip gen = property $ do
+  config <- forAll gen
+  tripping config toJSON fromJSON
+
+spec :: Spec
+spec = do
+  describe "MetaSchema" $ do
+    it "`Supported ()` roundtrips" $ do
+      require (prop_roundtrip (genSupported (pure ())))
+    it "`BulkConfig` roundtrips" $ do
+      require (prop_roundtrip genBulkConfig)
+    it "`FilterConfig` roundtrips" $ do
+      require (prop_roundtrip genFilterConfig)
+    it "`AuthenticationSchemeEncoding` roundtrips" $ do
+      require (prop_roundtrip genAuthenticationSchemeEncoding)
+    it "`Configuration` roundtrips" $ do
+      require (prop_roundtrip genConfiguration)
+
+genConfiguration :: Gen Configuration
+genConfiguration = do
+  documentationUri <- Gen.maybe genUri
+  schemas <- pure [User20]
+  patch <- genSupported (pure ())
+  bulk <- genSupported genBulkConfig
+  filter <- genSupported genFilterConfig
+  changePassword <- genSupported (pure ())
+  sort <- genSupported (pure ())
+  etag <- genSupported (pure ())
+  authenticationSchemes <- Gen.list (Range.linear 0 100) genAuthenticationSchemeEncoding
+  pure Configuration {..}
+
+genBulkConfig :: Gen BulkConfig
+genBulkConfig = do
+  maxOperations <- Gen.int (Range.linear 0 100)
+  maxPayloadSize <- Gen.int (Range.linear 0 100)
+  pure BulkConfig {..}
+
+genFilterConfig :: Gen FilterConfig
+genFilterConfig = do
+  maxResults <- Gen.int (Range.linear 0 100)
+  pure FilterConfig {..}
+
+genAuthenticationSchemeEncoding :: Gen AuthenticationSchemeEncoding
+genAuthenticationSchemeEncoding = do
+  typ <- genSimpleText
+  name <- genSimpleText
+  description <- genSimpleText
+  specUri <- Gen.maybe genUri
+  documentationUri <- Gen.maybe genUri
+  pure AuthenticationSchemeEncoding {..}
+
+genSupported :: forall a. Gen a -> Gen (Supported a)
+genSupported gen = do
+  supported :: ScimBool <- ScimBool <$> Gen.bool
+  subConfig :: a <- gen
+  pure Supported {..}
+
+genUri :: Gen URI
+genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]]
+
+genSimpleText :: Gen Text
+genSimpleText = Gen.element ["one", "green", "sharp"]

libs/hscim/test/Test/Schema/UserSpec.hs

@@ -160,7 +160,7 @@ genName =
     <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
 
 genUri :: Gen URI
-genUri = Gen.element [URI [uri|https://example.com|]]
+genUri = Gen.element [URI [uri|https://example.com|], URI [uri|gopher://glab.io|], URI [uri|ssh://nothing/blorg|]]
 
 -- TODO(arianvp) Generate the lists too, but first need better support for SCIM
 -- lists in the first place