-}
+{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Auth
- where
+ ( auth
+ , withAccess
+ )
+ where
import Control.Lens (view)
-import Data.Aeson.TH (deriveJSON)
-import Data.Swagger
-import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
-import GHC.Generics (Generic)
-import Gargantext.API.Admin.Settings
+import Servant
+import Servant.Auth.Server
+import qualified Gargantext.Prelude.Crypto.Auth as Auth
+
+import Gargantext.API.Admin.Auth.Types
+import Gargantext.API.Admin.Types
import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
-import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..), arbitraryUsername, arbitraryPassword)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
+import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
+import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
+import Gargantext.Database.Query.Table.User
import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
import Gargantext.Database.Query.Tree.Root (getRoot)
-import Gargantext.Database.Schema.Node (NodePoly(_node_id))
-import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId)
-import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
+import Gargantext.Database.Schema.Node (NodePoly(_node_id))
import Gargantext.Prelude hiding (reverse)
-import Gargantext.Database.Query.Table.User
-import Servant
-import Servant.Auth.Server
-import Test.QuickCheck (elements, oneof)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import qualified Gargantext.Core.Auth as Auth
---------------------------------------------------
--- | Main types for AUTH API
-data AuthRequest = AuthRequest { _authReq_username :: Username
- , _authReq_password :: GargPassword
- }
- deriving (Generic)
-
--- TODO: Use an HTTP error to wrap AuthInvalid
-data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
- , _authRes_inval :: Maybe AuthInvalid
- }
- deriving (Generic)
-
-data AuthInvalid = AuthInvalid { _authInv_message :: Text }
- deriving (Generic)
-
-data AuthValid = AuthValid { _authVal_token :: Token
- , _authVal_tree_id :: TreeId
- }
- deriving (Generic)
-
-type Token = Text
-type TreeId = NodeId
-
-- | Main functions of authorization
--- | Main types of authorization
-data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
- deriving (Eq)
-
makeTokenForUser :: (HasSettings env, HasJoseError err)
=> NodeId -> Cmd' env err Token
makeTokenForUser uid = do
either joseError (pure . toStrict . decodeUtf8) e
-- TODO not sure about the encoding...
-checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
+checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
=> Username
-> GargPassword
-> Cmd' env err CheckAuth
candidate <- head <$> getUsersWith u
case candidate of
Nothing -> pure InvalidUser
- Just (UserLight _id _u _email h) ->
+ Just (UserLight id _u _email (GargPassword h)) ->
case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
Auth.PasswordCheckFail -> pure InvalidPassword
Auth.PasswordCheckSuccess -> do
Nothing -> pure InvalidUser
Just uid -> do
token <- makeTokenForUser uid
- pure $ Valid token uid
+ pure $ Valid token uid id
-auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
+auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
=> AuthRequest -> Cmd' env err AuthResponse
auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p
case checkAuthRequest' of
InvalidUser -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
- Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
-
-newtype AuthenticatedUser = AuthenticatedUser
- { _authUser_id :: NodeId
- } deriving (Generic)
-
-$(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
-
-instance ToSchema AuthenticatedUser where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
-
-instance ToJWT AuthenticatedUser
-instance FromJWT AuthenticatedUser
+ Valid to trId uId -> pure $ AuthResponse (Just $ AuthValid to trId uId) Nothing
--type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
--- TODO-SECURITY why is the CookieSettings necessary?
-type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
-
{-
instance FromBasicAuthData AuthenticatedUser where
fromBasicAuthData authData authCheckFunction = authCheckFunction authData
maybe Indefinite Authenticated $ TODO
-}
--- | Instances
-$(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
-instance ToSchema AuthRequest where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
-
-instance Arbitrary AuthRequest where
- arbitrary = elements [ AuthRequest u p
- | u <- arbitraryUsername
- , p <- arbitraryPassword
- ]
-
-$(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
-instance ToSchema AuthResponse where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
-instance Arbitrary AuthResponse where
- arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
- , flip AuthResponse Nothing . Just <$> arbitrary ]
-
-$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
-instance ToSchema AuthInvalid where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
-instance Arbitrary AuthInvalid where
- arbitrary = elements [ AuthInvalid m
- | m <- [ "Invalid user", "Invalid password"]
- ]
-
-$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
-instance ToSchema AuthValid where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
-instance Arbitrary AuthValid where
- arbitrary = elements [ AuthValid to tr
- | to <- ["token0", "token1"]
- , tr <- [1..3]
- ]
-
-data PathId = PathNode NodeId | PathNodeNode ListId DocId
-
withAccessM :: (CmdM env err m, HasServerError err)
=> UserId
-> PathId
withAccess :: forall env err m api.
(GargServerC env err m, HasServer api '[]) =>
- Proxy api -> Proxy m ->
- UserId -> PathId ->
+ Proxy api -> Proxy m -> UserId -> PathId ->
ServerT api m -> ServerT api m
withAccess p _ uId id = hoistServer p f
where