-- 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.Capabilities.MetaSchema
  ( ConfigSite,
    configServer,
    Supported (..),
    BulkConfig (..),
    FilterConfig (..),
    Configuration (..),
    empty,
  )
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
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
import Web.Scim.ContentType
import Web.Scim.Handler
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)
import Web.Scim.Schema.ResourceType hiding (schema)
import Web.Scim.Schema.Schema
import Prelude hiding (filter)

data Supported a = Supported
  { supported :: ScimBool,
    subConfig :: a
  }
  deriving (Show, Eq, Generic)

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)]

-- | See module "Test.Schema.MetaSchemaSpec" for golden tests that explain this instance
-- better.
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
  }
  deriving (Show, Eq, Generic)

instance ToJSON BulkConfig where
  toJSON = genericToJSON serializeOptions

instance FromJSON BulkConfig where
  parseJSON = genericParseJSON parseOptions . jsonLower

data FilterConfig = FilterConfig
  { maxResults :: Int
  }
  deriving (Show, Eq, Generic)

instance ToJSON FilterConfig where
  toJSON = genericToJSON serializeOptions

instance FromJSON FilterConfig where
  parseJSON = genericParseJSON parseOptions . jsonLower

data Configuration = Configuration
  { documentationUri :: Maybe URI,
    schemas :: [Schema],
    patch :: Supported (),
    bulk :: Supported BulkConfig,
    filter :: Supported FilterConfig,
    changePassword :: Supported (),
    sort :: Supported (),
    etag :: Supported (),
    authenticationSchemes :: [AuthScheme.AuthenticationSchemeEncoding]
  }
  deriving (Show, Eq, Generic)

instance ToJSON Configuration where
  toJSON = genericToJSON serializeOptions

instance FromJSON Configuration where
  parseJSON = genericParseJSON parseOptions . jsonLower

empty :: Configuration
empty =
  Configuration
    { documentationUri = Nothing,
      schemas =
        [ User20,
          ServiceProviderConfig20,
          Group20,
          Schema20,
          ResourceType20
        ],
      patch = Supported (ScimBool True) (),
      bulk = Supported (ScimBool False) $ BulkConfig 0 0,
      filter = Supported (ScimBool False) $ FilterConfig 0,
      changePassword = Supported (ScimBool False) (),
      sort = Supported (ScimBool False) (),
      etag = Supported (ScimBool False) (),
      authenticationSchemes = [AuthScheme.authHttpBasicEncoding]
    }

configServer ::
  Monad m =>
  Configuration ->
  ConfigSite (AsServerT (ScimHandler m))
configServer config =
  ConfigSite
    { spConfig = pure config,
      getSchemas =
        pure $
          ListResponse.fromList
            [ userSchema,
              spConfigSchema,
              groupSchema,
              metaSchema,
              resourceSchema
            ],
      schema = \uri -> case getSchema (fromSchemaUri uri) of
        Nothing -> throwScim (notFound "Schema" uri)
        Just s -> pure s,
      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] (ListResponse Resource)
  }
  deriving (Generic)