{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Server.Auth
    ( AuthMethod
    , Token (..)
    , UserLoginData (..)
    , UserRegisterData (..)
    , UserUpdate (..)
    ) where

import Control.Lens
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.HashMap.Strict.InsOrd as HM
import Data.OpenApi
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Servant.API
import Servant.Auth.Server
import Servant.OpenApi
import qualified UserManagement.Group as Group
import qualified UserManagement.User as User

-- | Cookie means that Auth is implemented via two Cookies.
--   One HTTP-only JWT Cookie, which is managed by the browser
--   and a XSRF Cookie, which has to be mirrored in a "X-XSRF-TOKEN" Header
type AuthMethod = '[Cookie]

data Token = Token
    { Token -> UserID
subject :: User.UserID
    , Token -> Bool
isSuperadmin :: Bool
    }
    deriving ((forall x. Token -> Rep Token x)
-> (forall x. Rep Token x -> Token) -> Generic Token
forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Token -> Rep Token x
from :: forall x. Token -> Rep Token x
$cto :: forall x. Rep Token x -> Token
to :: forall x. Rep Token x -> Token
Generic, [Token] -> Encoding
[Token] -> Value
Token -> Bool
Token -> Encoding
Token -> Value
(Token -> Value)
-> (Token -> Encoding)
-> ([Token] -> Value)
-> ([Token] -> Encoding)
-> (Token -> Bool)
-> ToJSON Token
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Token -> Value
toJSON :: Token -> Value
$ctoEncoding :: Token -> Encoding
toEncoding :: Token -> Encoding
$ctoJSONList :: [Token] -> Value
toJSONList :: [Token] -> Value
$ctoEncodingList :: [Token] -> Encoding
toEncodingList :: [Token] -> Encoding
$comitField :: Token -> Bool
omitField :: Token -> Bool
ToJSON, Token -> ClaimsSet
(Token -> ClaimsSet) -> ToJWT Token
forall a. (a -> ClaimsSet) -> ToJWT a
$cencodeJWT :: Token -> ClaimsSet
encodeJWT :: Token -> ClaimsSet
ToJWT, Maybe Token
Value -> Parser [Token]
Value -> Parser Token
(Value -> Parser Token)
-> (Value -> Parser [Token]) -> Maybe Token -> FromJSON Token
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Token
parseJSON :: Value -> Parser Token
$cparseJSONList :: Value -> Parser [Token]
parseJSONList :: Value -> Parser [Token]
$comittedField :: Maybe Token
omittedField :: Maybe Token
FromJSON, ClaimsSet -> Either Text Token
(ClaimsSet -> Either Text Token) -> FromJWT Token
forall a. (ClaimsSet -> Either Text a) -> FromJWT a
$cdecodeJWT :: ClaimsSet -> Either Text Token
decodeJWT :: ClaimsSet -> Either Text Token
FromJWT)

data UserLoginData = UserLoginData
    { UserLoginData -> Text
loginEmail :: Text
    , UserLoginData -> Text
loginPassword :: Text
    }
    deriving ((forall x. UserLoginData -> Rep UserLoginData x)
-> (forall x. Rep UserLoginData x -> UserLoginData)
-> Generic UserLoginData
forall x. Rep UserLoginData x -> UserLoginData
forall x. UserLoginData -> Rep UserLoginData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserLoginData -> Rep UserLoginData x
from :: forall x. UserLoginData -> Rep UserLoginData x
$cto :: forall x. Rep UserLoginData x -> UserLoginData
to :: forall x. Rep UserLoginData x -> UserLoginData
Generic, Maybe UserLoginData
Value -> Parser [UserLoginData]
Value -> Parser UserLoginData
(Value -> Parser UserLoginData)
-> (Value -> Parser [UserLoginData])
-> Maybe UserLoginData
-> FromJSON UserLoginData
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserLoginData
parseJSON :: Value -> Parser UserLoginData
$cparseJSONList :: Value -> Parser [UserLoginData]
parseJSONList :: Value -> Parser [UserLoginData]
$comittedField :: Maybe UserLoginData
omittedField :: Maybe UserLoginData
FromJSON, Typeable UserLoginData
Typeable UserLoginData =>
(Proxy UserLoginData -> Declare (Definitions Schema) NamedSchema)
-> ToSchema UserLoginData
Proxy UserLoginData -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy UserLoginData -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy UserLoginData -> Declare (Definitions Schema) NamedSchema
ToSchema)

data UserRegisterData = UserRegisterData
    { UserRegisterData -> Text
registerName :: Text
    , UserRegisterData -> Text
registerEmail :: Text
    , UserRegisterData -> Text
registerPassword :: Text
    , UserRegisterData -> Maybe GroupID
groupID :: Maybe Group.GroupID
    }
    deriving ((forall x. UserRegisterData -> Rep UserRegisterData x)
-> (forall x. Rep UserRegisterData x -> UserRegisterData)
-> Generic UserRegisterData
forall x. Rep UserRegisterData x -> UserRegisterData
forall x. UserRegisterData -> Rep UserRegisterData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserRegisterData -> Rep UserRegisterData x
from :: forall x. UserRegisterData -> Rep UserRegisterData x
$cto :: forall x. Rep UserRegisterData x -> UserRegisterData
to :: forall x. Rep UserRegisterData x -> UserRegisterData
Generic, Maybe UserRegisterData
Value -> Parser [UserRegisterData]
Value -> Parser UserRegisterData
(Value -> Parser UserRegisterData)
-> (Value -> Parser [UserRegisterData])
-> Maybe UserRegisterData
-> FromJSON UserRegisterData
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserRegisterData
parseJSON :: Value -> Parser UserRegisterData
$cparseJSONList :: Value -> Parser [UserRegisterData]
parseJSONList :: Value -> Parser [UserRegisterData]
$comittedField :: Maybe UserRegisterData
omittedField :: Maybe UserRegisterData
FromJSON, Typeable UserRegisterData
Typeable UserRegisterData =>
(Proxy UserRegisterData
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema UserRegisterData
Proxy UserRegisterData -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy UserRegisterData -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy UserRegisterData -> Declare (Definitions Schema) NamedSchema
ToSchema)

data UserUpdate = UserUpdate
    { UserUpdate -> Maybe Text
newName :: Maybe Text
    , UserUpdate -> Maybe Text
newEmail :: Maybe Text
    }
    deriving ((forall x. UserUpdate -> Rep UserUpdate x)
-> (forall x. Rep UserUpdate x -> UserUpdate) -> Generic UserUpdate
forall x. Rep UserUpdate x -> UserUpdate
forall x. UserUpdate -> Rep UserUpdate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserUpdate -> Rep UserUpdate x
from :: forall x. UserUpdate -> Rep UserUpdate x
$cto :: forall x. Rep UserUpdate x -> UserUpdate
to :: forall x. Rep UserUpdate x -> UserUpdate
Generic, [UserUpdate] -> Encoding
[UserUpdate] -> Value
UserUpdate -> Bool
UserUpdate -> Encoding
UserUpdate -> Value
(UserUpdate -> Value)
-> (UserUpdate -> Encoding)
-> ([UserUpdate] -> Value)
-> ([UserUpdate] -> Encoding)
-> (UserUpdate -> Bool)
-> ToJSON UserUpdate
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: UserUpdate -> Value
toJSON :: UserUpdate -> Value
$ctoEncoding :: UserUpdate -> Encoding
toEncoding :: UserUpdate -> Encoding
$ctoJSONList :: [UserUpdate] -> Value
toJSONList :: [UserUpdate] -> Value
$ctoEncodingList :: [UserUpdate] -> Encoding
toEncodingList :: [UserUpdate] -> Encoding
$comitField :: UserUpdate -> Bool
omitField :: UserUpdate -> Bool
ToJSON, Maybe UserUpdate
Value -> Parser [UserUpdate]
Value -> Parser UserUpdate
(Value -> Parser UserUpdate)
-> (Value -> Parser [UserUpdate])
-> Maybe UserUpdate
-> FromJSON UserUpdate
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserUpdate
parseJSON :: Value -> Parser UserUpdate
$cparseJSONList :: Value -> Parser [UserUpdate]
parseJSONList :: Value -> Parser [UserUpdate]
$comittedField :: Maybe UserUpdate
omittedField :: Maybe UserUpdate
FromJSON, Typeable UserUpdate
Typeable UserUpdate =>
(Proxy UserUpdate -> Declare (Definitions Schema) NamedSchema)
-> ToSchema UserUpdate
Proxy UserUpdate -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy UserUpdate -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy UserUpdate -> Declare (Definitions Schema) NamedSchema
ToSchema)

-- | HasOpenApi instances for ProtectedAPI
--   Copied from: https://github.com/biocad/servant-openapi3/issues/42
instance (HasOpenApi api) => HasOpenApi (Auth '[] a :> api) where
    toOpenApi :: Proxy (Auth '[] a :> api) -> OpenApi
toOpenApi Proxy (Auth '[] a :> api)
Proxy = Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (Proxy api -> OpenApi) -> Proxy api -> OpenApi
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api

instance
    (HasOpenApi (Auth auths a :> api))
    => HasOpenApi (Auth (JWT : auths) a :> api)
    where
    toOpenApi :: Proxy (Auth (JWT : auths) a :> api) -> OpenApi
toOpenApi Proxy (Auth (JWT : auths) a :> api)
Proxy = OpenApi -> OpenApi
addSecurity (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall a b. (a -> b) -> a -> b
$ Proxy (Auth auths a :> api) -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (Proxy (Auth auths a :> api) -> OpenApi)
-> Proxy (Auth auths a :> api) -> OpenApi
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Auth auths a :> api)
      where
        addSecurity :: OpenApi -> OpenApi
addSecurity =
            Text -> OpenApi -> OpenApi
addSecurityRequirement Text
identifier (OpenApi -> OpenApi) -> (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SecurityScheme -> OpenApi -> OpenApi
addSecurityScheme Text
identifier SecurityScheme
securityScheme
        Text
identifier :: Text = Text
"JWT"
        securityScheme :: SecurityScheme
securityScheme =
            SecurityScheme
                { _securitySchemeType :: SecuritySchemeType
_securitySchemeType = HttpSchemeType -> SecuritySchemeType
SecuritySchemeHttp (HttpSchemeType -> SecuritySchemeType)
-> HttpSchemeType -> SecuritySchemeType
forall a b. (a -> b) -> a -> b
$ Maybe Text -> HttpSchemeType
HttpSchemeBearer (Maybe Text -> HttpSchemeType) -> Maybe Text -> HttpSchemeType
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JWT"
                , _securitySchemeDescription :: Maybe Text
_securitySchemeDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Bearer Authentication"
                }

instance
    (HasOpenApi (Auth auths a :> api))
    => HasOpenApi (Auth (Cookie : auths) a :> api)
    where
    toOpenApi :: Proxy (Auth (Cookie : auths) a :> api) -> OpenApi
toOpenApi Proxy (Auth (Cookie : auths) a :> api)
Proxy = OpenApi -> OpenApi
addSecurity (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall a b. (a -> b) -> a -> b
$ Proxy (Auth auths a :> api) -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (Proxy (Auth auths a :> api) -> OpenApi)
-> Proxy (Auth auths a :> api) -> OpenApi
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Auth auths a :> api)
      where
        addSecurity :: OpenApi -> OpenApi
addSecurity =
            Text -> OpenApi -> OpenApi
addSecurityRequirement Text
identifier (OpenApi -> OpenApi) -> (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SecurityScheme -> OpenApi -> OpenApi
addSecurityScheme Text
identifier SecurityScheme
securityScheme
        Text
identifier :: Text = Text
"JWT + XSRF-Cookie"
        securityScheme :: SecurityScheme
securityScheme =
            SecurityScheme
                { _securitySchemeType :: SecuritySchemeType
_securitySchemeType = HttpSchemeType -> SecuritySchemeType
SecuritySchemeHttp (HttpSchemeType -> SecuritySchemeType)
-> HttpSchemeType -> SecuritySchemeType
forall a b. (a -> b) -> a -> b
$ Maybe Text -> HttpSchemeType
HttpSchemeBearer (Maybe Text -> HttpSchemeType) -> Maybe Text -> HttpSchemeType
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JWT"
                , _securitySchemeDescription :: Maybe Text
_securitySchemeDescription = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Cookie Authentication"
                }

addSecurityScheme :: Text -> SecurityScheme -> OpenApi -> OpenApi
addSecurityScheme :: Text -> SecurityScheme -> OpenApi -> OpenApi
addSecurityScheme Text
securityIdentifier SecurityScheme
securityScheme OpenApi
openApi =
    OpenApi
openApi
        { _openApiComponents =
            (_openApiComponents openApi)
                { _componentsSecuritySchemes =
                    _componentsSecuritySchemes (_openApiComponents openApi)
                        <> SecurityDefinitions (HM.singleton securityIdentifier securityScheme)
                }
        }

addSecurityRequirement :: Text -> OpenApi -> OpenApi
addSecurityRequirement :: Text -> OpenApi -> OpenApi
addSecurityRequirement Text
securityRequirement =
    (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
allOperations
        ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> (([SecurityRequirement] -> Identity [SecurityRequirement])
    -> Operation -> Identity Operation)
-> ([SecurityRequirement] -> Identity [SecurityRequirement])
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SecurityRequirement] -> Identity [SecurityRequirement])
-> Operation -> Identity Operation
forall s a. HasSecurity s a => Lens' s a
Lens' Operation [SecurityRequirement]
security
        (([SecurityRequirement] -> Identity [SecurityRequirement])
 -> OpenApi -> Identity OpenApi)
-> ([SecurityRequirement] -> [SecurityRequirement])
-> OpenApi
-> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((InsOrdHashMap Text [Text] -> SecurityRequirement
SecurityRequirement (InsOrdHashMap Text [Text] -> SecurityRequirement)
-> InsOrdHashMap Text [Text] -> SecurityRequirement
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> InsOrdHashMap Text [Text]
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
HM.singleton Text
securityRequirement []) SecurityRequirement
-> [SecurityRequirement] -> [SecurityRequirement]
forall a. a -> [a] -> [a]
:)