2 Module : Gargantext.API.Admin.Auth
3 Description : Server API Auth Module
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
10 Main authorization of Gargantext are managed in this module
12 -- 1: Implement the Server / Client JWT authentication
13 -> Client towards Python Backend
14 -> Server towards Purescript Front-End
16 -- 2: Implement the Auth API backend
17 https://github.com/haskell-servant/servant-auth
23 {-# LANGUAGE ScopedTypeVariables #-}
24 {-# LANGUAGE TemplateHaskell #-}
26 module Gargantext.API.Admin.Auth
29 import Control.Lens (view)
30 import Data.Aeson.TH (deriveJSON)
32 import Data.Text (Text)
33 import Data.Text.Lazy (toStrict)
34 import Data.Text.Lazy.Encoding (decodeUtf8)
35 import GHC.Generics (Generic)
36 import Gargantext.API.Admin.Settings
37 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
38 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..), arbitraryUsername, arbitraryPassword)
39 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
40 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
41 import Gargantext.Database.Query.Tree.Root (getRoot)
42 import Gargantext.Database.Schema.Node (NodePoly(_node_id))
43 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId)
44 import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool)
45 import Gargantext.Prelude hiding (reverse)
46 import Gargantext.Database.Query.Table.User
48 import Servant.Auth.Server
49 import Test.QuickCheck (elements, oneof)
50 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
51 import qualified Gargantext.Core.Auth as Auth
53 ---------------------------------------------------
55 -- | Main types for AUTH API
56 data AuthRequest = AuthRequest { _authReq_username :: Username
57 , _authReq_password :: GargPassword
61 -- TODO: Use an HTTP error to wrap AuthInvalid
62 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
63 , _authRes_inval :: Maybe AuthInvalid
67 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
70 data AuthValid = AuthValid { _authVal_token :: Token
71 , _authVal_tree_id :: TreeId
78 -- | Main functions of authorization
80 -- | Main types of authorization
81 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
84 makeTokenForUser :: (HasSettings env, HasJoseError err)
85 => NodeId -> Cmd' env err Token
86 makeTokenForUser uid = do
87 jwtS <- view $ settings . jwtSettings
88 e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
89 -- TODO-SECURITY here we can implement token expiration ^^.
90 either joseError (pure . toStrict . decodeUtf8) e
91 -- TODO not sure about the encoding...
93 checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err)
96 -> Cmd' env err CheckAuth
97 checkAuthRequest u (GargPassword p) = do
98 candidate <- head <$> getUsersWith u
100 Nothing -> pure InvalidUser
101 Just (UserLight _id _u _email h) ->
102 case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
103 Auth.PasswordCheckFail -> pure InvalidPassword
104 Auth.PasswordCheckSuccess -> do
105 muId <- head <$> getRoot (UserName u)
106 case _node_id <$> muId of
107 Nothing -> pure InvalidUser
109 token <- makeTokenForUser uid
110 pure $ Valid token uid
112 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err)
113 => AuthRequest -> Cmd' env err AuthResponse
114 auth (AuthRequest u p) = do
115 checkAuthRequest' <- checkAuthRequest u p
116 case checkAuthRequest' of
117 InvalidUser -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
118 InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
119 Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
121 newtype AuthenticatedUser = AuthenticatedUser
122 { _authUser_id :: NodeId
125 $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
127 instance ToSchema AuthenticatedUser where
128 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
130 instance ToJWT AuthenticatedUser
131 instance FromJWT AuthenticatedUser
133 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
135 -- TODO-SECURITY why is the CookieSettings necessary?
136 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
139 instance FromBasicAuthData AuthenticatedUser where
140 fromBasicAuthData authData authCheckFunction = authCheckFunction authData
142 authCheck :: forall env. env
144 -> IO (AuthResult AuthenticatedUser)
145 authCheck _env (BasicAuthData login password) = pure $
146 maybe Indefinite Authenticated $ TODO
150 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
151 instance ToSchema AuthRequest where
152 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
154 instance Arbitrary AuthRequest where
155 arbitrary = elements [ AuthRequest u p
156 | u <- arbitraryUsername
157 , p <- arbitraryPassword
160 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
161 instance ToSchema AuthResponse where
162 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
163 instance Arbitrary AuthResponse where
164 arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
165 , flip AuthResponse Nothing . Just <$> arbitrary ]
167 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
168 instance ToSchema AuthInvalid where
169 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
170 instance Arbitrary AuthInvalid where
171 arbitrary = elements [ AuthInvalid m
172 | m <- [ "Invalid user", "Invalid password"]
175 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
176 instance ToSchema AuthValid where
177 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
178 instance Arbitrary AuthValid where
179 arbitrary = elements [ AuthValid to tr
180 | to <- ["token0", "token1"]
184 data PathId = PathNode NodeId | PathNodeNode ListId DocId
186 withAccessM :: (CmdM env err m, HasServerError err)
191 withAccessM uId (PathNode id) m = do
192 d <- id `isDescendantOf` NodeId uId
193 if d then m else m -- serverError err401
195 withAccessM uId (PathNodeNode cId docId) m = do
196 _a <- isIn cId docId -- TODO use one query for all ?
197 _d <- cId `isDescendantOf` NodeId uId
202 withAccess :: forall env err m api.
203 (GargServerC env err m, HasServer api '[]) =>
204 Proxy api -> Proxy m ->
206 ServerT api m -> ServerT api m
207 withAccess p _ uId id = hoistServer p f
209 f :: forall a. m a -> m a
210 f = withAccessM uId id
212 {- | Collaborative Schema
213 User at his root can create Teams Folder
214 User can create Team in Teams Folder.
215 User can invite User in Team as NodeNode only if Team in his parents.
216 All users can access to the Team folder as if they were owner.