-- 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 Web.Scim.Schema.Schema where

import Data.Aeson (FromJSON, ToJSON, Value, parseJSON, toJSON, withText)
import Data.Attoparsec.ByteString (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as Parser
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Web.Scim.Capabilities.MetaSchema.Group
import Web.Scim.Capabilities.MetaSchema.ResourceType
import Web.Scim.Capabilities.MetaSchema.SPConfig
import Web.Scim.Capabilities.MetaSchema.Schema
import Web.Scim.Capabilities.MetaSchema.User

-- | All schemas that we support.
data Schema
  = User20
  | ServiceProviderConfig20
  | Group20
  | Schema20
  | ResourceType20
  | ListResponse20
  | Error20
  | PatchOp20
  | CustomSchema Text
  deriving (Int -> Schema -> ShowS
[Schema] -> ShowS
Schema -> String
(Int -> Schema -> ShowS)
-> (Schema -> String) -> ([Schema] -> ShowS) -> Show Schema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Schema] -> ShowS
$cshowList :: [Schema] -> ShowS
show :: Schema -> String
$cshow :: Schema -> String
showsPrec :: Int -> Schema -> ShowS
$cshowsPrec :: Int -> Schema -> ShowS
Show, Schema -> Schema -> Bool
(Schema -> Schema -> Bool)
-> (Schema -> Schema -> Bool) -> Eq Schema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Schema -> Schema -> Bool
$c/= :: Schema -> Schema -> Bool
== :: Schema -> Schema -> Bool
$c== :: Schema -> Schema -> Bool
Eq)

instance FromJSON Schema where
  parseJSON :: Value -> Parser Schema
parseJSON = String -> (Text -> Parser Schema) -> Value -> Parser Schema
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"schema" ((Text -> Parser Schema) -> Value -> Parser Schema)
-> (Text -> Parser Schema) -> Value -> Parser Schema
forall a b. (a -> b) -> a -> b
$ \Text
t -> Schema -> Parser Schema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Schema
fromSchemaUri Text
t)

instance ToJSON Schema where
  toJSON :: Schema -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Schema -> Text) -> Schema -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Text
getSchemaUri

-- | Get schema URI (e.g. @urn:ietf:params:scim:schemas:core:2.0:User@).
getSchemaUri :: Schema -> Text
getSchemaUri :: Schema -> Text
getSchemaUri Schema
User20 =
  Text
"urn:ietf:params:scim:schemas:core:2.0:User"
getSchemaUri Schema
ServiceProviderConfig20 =
  Text
"urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig"
getSchemaUri Schema
Group20 =
  Text
"urn:ietf:params:scim:schemas:core:2.0:Group"
getSchemaUri Schema
Schema20 =
  Text
"urn:ietf:params:scim:schemas:core:2.0:Schema"
getSchemaUri Schema
ResourceType20 =
  Text
"urn:ietf:params:scim:schemas:core:2.0:ResourceType"
getSchemaUri Schema
ListResponse20 =
  Text
"urn:ietf:params:scim:api:messages:2.0:ListResponse"
getSchemaUri Schema
Error20 =
  Text
"urn:ietf:params:scim:api:messages:2.0:Error"
getSchemaUri Schema
PatchOp20 =
  Text
"urn:ietf:params:scim:api:messages:2.0:PatchOp"
getSchemaUri (CustomSchema Text
x) =
  Text
x

-- TODO(akshay): Make everything Text, ByteStrings are unnecessary here

-- | Parser for schemas
--
-- NOTE: according to the spec, this parser needs to be case insensitive, but
-- that is literally insane. Won't implement.
pSchema :: [Schema] -> Parser Schema
pSchema :: [Schema] -> Parser Schema
pSchema [Schema]
supportedSchemas =
  [Parser Schema] -> Parser Schema
forall (f :: * -> *) a. Alternative f => [f a] -> f a
Parser.choice ([Parser Schema] -> Parser Schema)
-> [Parser Schema] -> Parser Schema
forall a b. (a -> b) -> a -> b
$
    (Schema -> Parser Schema) -> [Schema] -> [Parser Schema]
forall a b. (a -> b) -> [a] -> [b]
map (\Schema
s -> Text -> Schema
fromSchemaUri (Text -> Schema) -> (ByteString -> Text) -> ByteString -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Schema)
-> Parser ByteString ByteString -> Parser Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Parser ByteString ByteString
Parser.string (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Schema -> Text
getSchemaUri Schema
s)) [Schema]
supportedSchemas

-- | Get a schema by its URI.
--
-- NOTE: case sensitive against the spec.  Same as 'pSchema'.
--
-- TODO(arianvp): probably too lenient. want to only accept valid URNs
-- This means the CustomSchema part might go... We need to kind of
-- rethink how we're  gonna do extensions anyway, as we're gonna have to
-- support multiple extensions, which is currently a bit iffy I think
fromSchemaUri :: Text -> Schema
fromSchemaUri :: Text -> Schema
fromSchemaUri Text
s = case Text
s of
  Text
"urn:ietf:params:scim:schemas:core:2.0:User" ->
    Schema
User20
  Text
"urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" ->
    Schema
ServiceProviderConfig20
  Text
"urn:ietf:params:scim:schemas:core:2.0:Group" ->
    Schema
Group20
  Text
"urn:ietf:params:scim:schemas:core:2.0:Schema" ->
    Schema
Schema20
  Text
"urn:ietf:params:scim:schemas:core:2.0:ResourceType" ->
    Schema
ResourceType20
  Text
"urn:ietf:params:scim:api:messages:2.0:ListResponse" ->
    Schema
ListResponse20
  Text
"urn:ietf:params:scim:api:messages:2.0:Error" ->
    Schema
Error20
  Text
"urn:ietf:params:scim:api:messages:2.0:PatchOp" ->
    Schema
PatchOp20
  Text
x ->
    Text -> Schema
CustomSchema Text
x

-- | Get schema description as JSON.
getSchema :: Schema -> Maybe Value
getSchema :: Schema -> Maybe Value
getSchema Schema
ServiceProviderConfig20 =
  Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
spConfigSchema
getSchema Schema
User20 =
  Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
userSchema
getSchema Schema
Group20 =
  Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
groupSchema
getSchema Schema
Schema20 =
  Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
metaSchema
getSchema Schema
ResourceType20 =
  Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
resourceSchema
-- Schemas for these types are not in the SCIM standard.
-- FUTUREWORK: write schema definitions anyway.
getSchema Schema
ListResponse20 =
  Maybe Value
forall a. Maybe a
Nothing
getSchema Schema
Error20 =
  Maybe Value
forall a. Maybe a
Nothing
getSchema Schema
PatchOp20 =
  Maybe Value
forall a. Maybe a
Nothing
-- This is not controlled by @hscim@ so we can't write a schema.
-- FUTUREWORK: allow supplying schemas for 'CustomSchema'.
getSchema (CustomSchema Text
_) =
  Maybe Value
forall a. Maybe a
Nothing