More Okta work (#10)

* Use UUIDs

* Add a comment

* Add missing fields to 'ListResponse'

* Serve a single user

* Give the user an email

* Resource types

* Address comments

package.yaml

@@ -46,6 +46,8 @@ dependencies:
   - http-types
   - stm-containers
   - http-media
+  - uuid
+  - template-haskell
 
 ghc-options: -Wall
 

server/Main.hs

@@ -1,17 +1,87 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 module Main where
 
+import           Web.SCIM.Util
 import           Web.SCIM.Server
 import           Web.SCIM.Server.Mock
-import           Web.SCIM.Class.Auth (Admin (..))
-import           Web.SCIM.Capabilities.MetaSchema (empty)
+import           Web.SCIM.Schema.Meta hiding (meta)
+import           Web.SCIM.Schema.Common as Common
+import           Web.SCIM.Schema.ResourceType hiding (name)
+import           Web.SCIM.Schema.User as User
+import           Web.SCIM.Schema.User.Name
+import           Web.SCIM.Schema.User.Email as E
+import           Web.SCIM.Class.Auth
+import           Web.SCIM.Capabilities.MetaSchema as MetaSchema
 
+import           Data.Time
 import           Network.Wai.Handler.Warp
 import qualified STMContainers.Map as STMMap
 import           Control.Monad.STM (atomically)
+import           Data.UUID as UUID
+import           Text.Email.Validate
 
 main :: IO ()
 main = do
-  auth <- STMMap.newIO
-  atomically $ STMMap.insert (Admin "admin", "password") "admin" auth
-  storage <- TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure auth
-  run 9000 =<< app empty (nt storage)
+  storage <- TestStorage <$> mkUserDB <*> STMMap.newIO <*> mkAuthDB
+  run 9000 =<< app MetaSchema.empty (nt storage)
+
+-- | Create a UserDB with a single user:
+--
+-- @
+-- UserID: sample-user
+-- @
+mkUserDB :: IO UserStorage
+mkUserDB = do
+  db <- STMMap.newIO
+  now <- getCurrentTime
+  let meta = Meta
+        { resourceType = UserResource
+        , created = now
+        , lastModified = now
+        , version = Weak "0" -- we don't support etags
+        , location = Common.URI [relativeUri|/Users/sample-user|]
+        }
+  -- Note: Okta required at least one email, 'active', 'name.familyName',
+  -- and 'name.givenName'. We might want to be able to express these
+  -- constraints in code (and in the schema we serve) without turning this
+  -- library into something that is Okta-specific.
+  let email = Email
+        { E.typ = Just "work"
+        , E.value = maybe (error "couldn't parse email") EmailAddress2
+                      (emailAddress "elton@wire.com")
+        , E.primary = Nothing
+        }
+  let user = User.empty
+        { userName = "elton"
+        , name = Just Name
+            { formatted = Just "Elton John"
+            , familyName = Just "John"
+            , givenName = Just "Elton"
+            , middleName = Nothing
+            , honorificPrefix = Nothing
+            , honorificSuffix = Nothing
+            }
+        , active = Just True
+        , emails = Just [email]
+        }
+  atomically $ STMMap.insert (WithMeta meta (WithId "elton" user)) "elton" db
+  pure db
+
+-- | Create an AuthDB with a single admin:
+--
+-- @
+-- UUID: 00000500-0000-0000-0000-000000000001
+-- pass: password
+-- @
+--
+-- The authorization header for this admin (which you can regenerate by
+-- following the logic in 'authHeader'):
+--
+-- @Basic MDAwMDA1MDAtMDAwMC0wMDAwLTAwMDAtMDAwMDAwMDAwMDAxOnBhc3N3b3Jk@
+mkAuthDB :: IO AdminStorage
+mkAuthDB = do
+  db <- STMMap.newIO
+  let uuid = UUID.fromWords 0x500 0 0 1
+  atomically $ STMMap.insert (Admin uuid, "password") uuid db
+  pure db

src/Web/SCIM/Capabilities/MetaSchema.hs

@@ -15,6 +15,7 @@ module Web.SCIM.Capabilities.MetaSchema (
 
 import           Web.SCIM.Schema.Schema
 import           Web.SCIM.Schema.Common
+import           Web.SCIM.Schema.ResourceType hiding (schema)
 import           Web.SCIM.Schema.AuthenticationScheme
 import           Web.SCIM.Schema.ListResponse as ListResponse
 import           Web.SCIM.Capabilities.MetaSchema.User
@@ -69,7 +70,7 @@ data Configuration = Configuration
   , changePassword :: Supported ()
   , sort :: Supported ()
   , etag :: Supported ()
-  , authenticationSchemes :: [AuthenticationScheme]
+  , authenticationSchemes :: [AuthenticationSchemeEncoding]
   } deriving (Show, Eq, Generic)
 
 instance ToJSON Configuration where
@@ -90,7 +91,7 @@ empty = Configuration
   , changePassword = Supported False ()
   , sort = Supported False ()
   , etag = Supported False ()
-  , authenticationSchemes = [AuthHttpBasic]
+  , authenticationSchemes = [authHttpBasicEncoding]
   }
 
 configServer :: MonadError ServantErr m =>
@@ -105,12 +106,15 @@ configServer config = ConfigSite
                             , resourceSchema
                             ]
   , schema = either throwError pure . note err404 . (getSchema <=< fromSchemaUri)
-  , resourceTypes = pure ""
+  , resourceTypes = pure $
+      ListResponse.fromList [ usersResource
+                            , groupsResource
+                            ]
   }
 
 data ConfigSite route = ConfigSite
   { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration
   , getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value)
   , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value
-  , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] Text
+  , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource)
   } deriving (Generic)

src/Web/SCIM/Class/Auth.hs

@@ -8,13 +8,13 @@ module Web.SCIM.Class.Auth
     ) where
 
 import Data.Aeson
-import Data.Text
 import GHC.Generics
 import Servant.Auth.Server
+import Data.UUID
 
 -- | Someone who is allowed to provision users via SCIM.
 data Admin = Admin
-  { name :: Text   -- TODO: change to UUID
+  { adminId :: UUID
   } deriving (Eq, Show, Read, Generic)
 
 instance ToJSON Admin
@@ -24,7 +24,7 @@ instance FromJWT Admin
 
 -- | Unfortunately, we have to pass an "authentication callback" to Servant
 -- by instantiating a zero-argument type family. This can only be done once
--- per application.
+-- per application, which is not the best possible design.
 type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult Admin)
 
 instance FromBasicAuthData Admin where

src/Web/SCIM/Schema/AuthenticationScheme.hs

@@ -2,6 +2,8 @@
 
 module Web.SCIM.Schema.AuthenticationScheme
   ( AuthenticationScheme(..)
+  , AuthenticationSchemeEncoding
+  , authHttpBasicEncoding
   ) where
 
 import Web.SCIM.Schema.Common
@@ -11,6 +13,9 @@ import Data.Text
 import GHC.Generics
 import Network.URI.Static
 
+----------------------------------------------------------------------------
+-- Types
+
 -- | Possible authentication schemes. The specification defines the values
 -- "oauth", "oauth2", "oauthbearertoken", "httpbasic", and "httpdigest".
 data AuthenticationScheme
@@ -44,12 +49,15 @@ instance ToJSON AuthenticationSchemeEncoding where
   toJSON = genericToJSON serializeOptions
   -- NB: "typ" will be converted to "type" thanks to 'serializeOptions'
 
-instance ToJSON AuthenticationScheme where
-  toJSON AuthHttpBasic = toJSON AuthenticationSchemeEncoding
-    { typ = "httpbasic"
-    , name = "HTTP Basic"
-    , description = "Authentication via the HTTP Basic standard"
-    , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|]
-    , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|]
-    }
-  toJSON x = error ("not implemented: toJSON " ++ show x)
+----------------------------------------------------------------------------
+-- Scheme encodings
+
+-- | The description of the 'AuthHttpBasic' scheme.
+authHttpBasicEncoding :: AuthenticationSchemeEncoding
+authHttpBasicEncoding = AuthenticationSchemeEncoding
+  { typ = "httpbasic"
+  , name = "HTTP Basic"
+  , description = "Authentication via the HTTP Basic standard"
+  , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|]
+  , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|]
+  }

src/Web/SCIM/Schema/ListResponse.hs

@@ -7,18 +7,33 @@ import GHC.Generics (Generic)
 import Web.SCIM.Schema.Common
 import Web.SCIM.Schema.Schema
 
+-- | A "pagination" type used as a wrapper whenever a SCIM endpoint has to
+-- return a list.
+--
+-- Pagination is not actually supported anywhere in the code yet; whenever
+-- there are several results we always return them all as one page, and we
+-- don't support different values of 'startIndex'.
+--
+-- FUTUREWORK: Support for pagination might be added once we have to handle
+-- organizations with lots of users.
 data ListResponse a = ListResponse
   { schemas :: [Schema]
   , totalResults :: Int
+  , itemsPerPage :: Int
+  , startIndex :: Int
   , resources :: [a]
   } deriving (Show, Eq, Generic)
 
 fromList :: [a] -> ListResponse a
 fromList list = ListResponse
   { schemas = [ListResponse2_0]
-  , totalResults = length list
+  , totalResults = len
+  , itemsPerPage = len
+  , startIndex = 0
   , resources = list
   }
+  where
+    len = length list
 
 instance FromJSON a => FromJSON (ListResponse a) where
   parseJSON = genericParseJSON parseOptions . jsonLower
@@ -28,5 +43,7 @@ instance ToJSON a => ToJSON (ListResponse a) where
     object [ "Resources" .= resources
            , "schemas" .= schemas
            , "totalResults" .= totalResults
+           , "itemsPerPage" .= itemsPerPage
+           , "startIndex" .= startIndex
            ]
 

src/Web/SCIM/Schema/Meta.hs

@@ -6,18 +6,11 @@ import Prelude hiding (map)
 import Data.Text (Text)
 import Data.Aeson
 import Web.SCIM.Schema.Common
+import Web.SCIM.Schema.ResourceType
 import GHC.Generics (Generic)
 import qualified Data.HashMap.Lazy as HML
 import Data.Time.Clock
 
-data ResourceType = UserResource
-                  | GroupResource
-  deriving (Eq, Show)
-
-instance ToJSON ResourceType where
-  toJSON UserResource = "User"
-  toJSON GroupResource = "Group"
-
 data ETag = Weak Text | Strong Text
   deriving (Eq, Show)
 

src/Web/SCIM/Schema/ResourceType.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Web.SCIM.Schema.ResourceType where
+
+import Prelude hiding (map)
+
+import Data.Text (Text)
+import Data.Aeson
+
+import Web.SCIM.Util
+import Web.SCIM.Schema.Common
+import Web.SCIM.Schema.Schema (Schema(..))
+
+import GHC.Generics (Generic)
+
+-- | Supported resource types. Each resource type also corresponds to an
+-- endpoint, described by 'ResourceTypeEndpoint'.
+data ResourceType
+  = UserResource
+  | GroupResource
+  deriving (Show, Eq)
+
+instance ToJSON ResourceType where
+  toJSON UserResource = "User"
+  toJSON GroupResource = "Group"
+
+-- | Definitions of endpoints, returned by @/ResourceTypes@.
+data Resource = Resource
+  { name :: Text
+  , endpoint :: URI
+  , schema :: Schema
+  } deriving (Show, Eq, Generic)
+
+instance ToJSON Resource where
+  toJSON = genericToJSON serializeOptions
+
+----------------------------------------------------------------------------
+-- Available resource endpoints
+
+usersResource :: Resource
+usersResource = Resource
+  { name = "User"
+  , endpoint = URI [relativeUri|/Users|]
+  , schema = User20
+  }
+
+groupsResource :: Resource
+groupsResource = Resource
+  { name = "Group"
+  , endpoint = URI [relativeUri|/Groups|]
+  , schema = Group20
+  }

src/Web/SCIM/Schema/User.hs

@@ -7,7 +7,7 @@ import Data.Text (Text)
 import Data.Aeson
 
 import Web.SCIM.Schema.Common
-import Web.SCIM.Schema.Schema (Schema)
+import Web.SCIM.Schema.Schema (Schema(..))
 import Web.SCIM.Schema.User.Address (Address)
 import Web.SCIM.Schema.User.Certificate (Certificate)
 import Web.SCIM.Schema.User.Email (Email)
@@ -20,7 +20,7 @@ import GHC.Generics (Generic)
 
 
 data User = User
-  { schemas :: [Schema]
+  { schemas :: [Schema]          -- TODO: not sure it should be a part of this type
   , userName :: Text
   , externalId :: Maybe Text
   , name :: Maybe Name
@@ -43,6 +43,31 @@ data User = User
   , x509Certificates :: Maybe [Certificate]
   } deriving (Show, Eq, Generic)
 
+empty :: User
+empty = User
+  { schemas = [User20]
+  , userName = ""
+  , externalId = Nothing
+  , name = Nothing
+  , displayName = Nothing
+  , nickName = Nothing
+  , profileUrl = Nothing
+  , title = Nothing
+  , userType = Nothing
+  , preferredLanguage = Nothing
+  , locale = Nothing
+  , active = Nothing
+  , password = Nothing
+  , emails = Nothing
+  , phoneNumbers = Nothing
+  , ims = Nothing
+  , photos = Nothing
+  , addresses = Nothing
+  , entitlements = Nothing
+  , roles = Nothing
+  , x509Certificates = Nothing
+  }
+
 instance FromJSON User where
   parseJSON = genericParseJSON parseOptions . jsonLower