]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Admin/Auth.hs
[Social List] increments with listIds either Private or Shared, need group filtering...
[gargantext.git] / src / Gargantext / API / Admin / Auth.hs
1 {-|
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
8 Portability : POSIX
9
10 Main authorization of Gargantext are managed in this module
11
12 -- 1: Implement the Server / Client JWT authentication
13 -> Client towards Python Backend
14 -> Server towards Purescript Front-End
15
16 -- 2: Implement the Auth API backend
17 https://github.com/haskell-servant/servant-auth
18
19 TODO-ACCESS Critical
20
21 -}
22
23 {-# LANGUAGE ScopedTypeVariables #-}
24 {-# LANGUAGE TemplateHaskell #-}
25
26 module Gargantext.API.Admin.Auth
27 where
28
29 import Control.Lens (view)
30 import Data.Aeson.TH (deriveJSON)
31 import Data.Swagger
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 Servant
37 import Servant.Auth.Server
38 import Test.QuickCheck (elements, oneof)
39 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
40 import qualified Gargantext.Prelude.Crypto.Auth as Auth
41
42 import Gargantext.API.Admin.Types
43 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
44 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..), arbitraryUsername, arbitraryPassword)
45 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
46 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
47 import Gargantext.Database.Query.Tree.Root (getRoot)
48 import Gargantext.Database.Schema.Node (NodePoly(_node_id))
49 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId, ListId, DocId)
50 import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
51 import Gargantext.Prelude hiding (reverse)
52 import Gargantext.Database.Query.Table.User
53
54 ---------------------------------------------------
55
56 -- | Main types for AUTH API
57 data AuthRequest = AuthRequest { _authReq_username :: Username
58 , _authReq_password :: GargPassword
59 }
60 deriving (Generic)
61
62 -- TODO: Use an HTTP error to wrap AuthInvalid
63 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
64 , _authRes_inval :: Maybe AuthInvalid
65 }
66 deriving (Generic)
67
68 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
69 deriving (Generic)
70
71 data AuthValid = AuthValid { _authVal_token :: Token
72 , _authVal_tree_id :: TreeId
73 }
74 deriving (Generic)
75
76 type Token = Text
77 type TreeId = NodeId
78
79 -- | Main functions of authorization
80
81 -- | Main types of authorization
82 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
83 deriving (Eq)
84
85 makeTokenForUser :: (HasSettings env, HasJoseError err)
86 => NodeId -> Cmd' env err Token
87 makeTokenForUser uid = do
88 jwtS <- view $ settings . jwtSettings
89 e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
90 -- TODO-SECURITY here we can implement token expiration ^^.
91 either joseError (pure . toStrict . decodeUtf8) e
92 -- TODO not sure about the encoding...
93
94 checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
95 => Username
96 -> GargPassword
97 -> Cmd' env err CheckAuth
98 checkAuthRequest u (GargPassword p) = do
99 candidate <- head <$> getUsersWith u
100 case candidate of
101 Nothing -> pure InvalidUser
102 Just (UserLight _id _u _email h) ->
103 case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
104 Auth.PasswordCheckFail -> pure InvalidPassword
105 Auth.PasswordCheckSuccess -> do
106 muId <- head <$> getRoot (UserName u)
107 case _node_id <$> muId of
108 Nothing -> pure InvalidUser
109 Just uid -> do
110 token <- makeTokenForUser uid
111 pure $ Valid token uid
112
113 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env)
114 => AuthRequest -> Cmd' env err AuthResponse
115 auth (AuthRequest u p) = do
116 checkAuthRequest' <- checkAuthRequest u p
117 case checkAuthRequest' of
118 InvalidUser -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
119 InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
120 Valid to trId -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
121
122 newtype AuthenticatedUser = AuthenticatedUser
123 { _authUser_id :: NodeId
124 } deriving (Generic)
125
126 $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
127
128 instance ToSchema AuthenticatedUser where
129 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
130
131 instance ToJWT AuthenticatedUser
132 instance FromJWT AuthenticatedUser
133
134 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
135
136 -- TODO-SECURITY why is the CookieSettings necessary?
137 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
138
139 {-
140 instance FromBasicAuthData AuthenticatedUser where
141 fromBasicAuthData authData authCheckFunction = authCheckFunction authData
142
143 authCheck :: forall env. env
144 -> BasicAuthData
145 -> IO (AuthResult AuthenticatedUser)
146 authCheck _env (BasicAuthData login password) = pure $
147 maybe Indefinite Authenticated $ TODO
148 -}
149
150 -- | Instances
151 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
152 instance ToSchema AuthRequest where
153 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
154
155 instance Arbitrary AuthRequest where
156 arbitrary = elements [ AuthRequest u p
157 | u <- arbitraryUsername
158 , p <- arbitraryPassword
159 ]
160
161 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
162 instance ToSchema AuthResponse where
163 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
164 instance Arbitrary AuthResponse where
165 arbitrary = oneof [ AuthResponse Nothing . Just <$> arbitrary
166 , flip AuthResponse Nothing . Just <$> arbitrary ]
167
168 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
169 instance ToSchema AuthInvalid where
170 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
171 instance Arbitrary AuthInvalid where
172 arbitrary = elements [ AuthInvalid m
173 | m <- [ "Invalid user", "Invalid password"]
174 ]
175
176 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
177 instance ToSchema AuthValid where
178 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
179 instance Arbitrary AuthValid where
180 arbitrary = elements [ AuthValid to tr
181 | to <- ["token0", "token1"]
182 , tr <- [1..3]
183 ]
184
185 data PathId = PathNode NodeId | PathNodeNode ListId DocId
186
187 withAccessM :: (CmdM env err m, HasServerError err)
188 => UserId
189 -> PathId
190 -> m a
191 -> m a
192 withAccessM uId (PathNode id) m = do
193 d <- id `isDescendantOf` NodeId uId
194 if d then m else m -- serverError err401
195
196 withAccessM uId (PathNodeNode cId docId) m = do
197 _a <- isIn cId docId -- TODO use one query for all ?
198 _d <- cId `isDescendantOf` NodeId uId
199 if True -- a && d
200 then m
201 else m
202
203 withAccess :: forall env err m api.
204 (GargServerC env err m, HasServer api '[]) =>
205 Proxy api -> Proxy m -> UserId -> PathId ->
206 ServerT api m -> ServerT api m
207 withAccess p _ uId id = hoistServer p f
208 where
209 f :: forall a. m a -> m a
210 f = withAccessM uId id
211
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.
217 -}