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 MonoLocalBinds      #-}
  24 {-# LANGUAGE ScopedTypeVariables #-}
  25
  26 module Gargantext.API.Admin.Auth
  27   ( auth
  28   , withAccess
  29   )
  30   where
  31
  32 import Control.Lens (view)
  33 import Data.Text.Lazy (toStrict)
  34 import Data.Text.Lazy.Encoding (decodeUtf8)
  35 import Servant
  36 import Servant.Auth.Server
  37 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  38
  39 import Gargantext.API.Admin.Auth.Types
  40 import Gargantext.API.Admin.Types
  41 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC)
  42 import Gargantext.Core.Mail.Types (HasMail)
  43 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
  44 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
  45 import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
  46 import Gargantext.Database.Query.Table.User
  47 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
  48 import Gargantext.Database.Query.Tree.Root (getRoot)
  49 import Gargantext.Database.Schema.Node (NodePoly(_node_id))
  50 import Gargantext.Prelude hiding (reverse)
  51
  52 ---------------------------------------------------
  53
  54 -- | Main functions of authorization
  55
  56 makeTokenForUser :: (HasSettings env, HasJoseError err)
  57                  => NodeId -> Cmd' env err Token
  58 makeTokenForUser uid = do
  59   jwtS <- view $ settings . jwtSettings
  60   e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
  61   -- TODO-SECURITY here we can implement token expiration ^^.
  62   either joseError (pure . toStrict . decodeUtf8) e
  63   -- TODO not sure about the encoding...
  64
  65 checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
  66                  => Username
  67                  -> GargPassword
  68                  -> Cmd' env err CheckAuth
  69 checkAuthRequest u (GargPassword p) = do
  70   candidate <- head <$> getUsersWith u
  71   case candidate of
  72     Nothing -> pure InvalidUser
  73     Just (UserLight id _u _email (GargPassword h)) ->
  74       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
  75         Auth.PasswordCheckFail    -> pure InvalidPassword
  76         Auth.PasswordCheckSuccess -> do
  77           muId <- head <$> getRoot (UserName u)
  78           case _node_id <$> muId of
  79             Nothing  -> pure InvalidUser
  80             Just uid -> do
  81               token <- makeTokenForUser uid
  82               pure $ Valid token uid id
  83
  84 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
  85      => AuthRequest -> Cmd' env err AuthResponse
  86 auth (AuthRequest u p) = do
  87   checkAuthRequest' <- checkAuthRequest u p
  88   case checkAuthRequest' of
  89     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
  90     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
  91     Valid to trId uId   -> pure $ AuthResponse (Just $ AuthValid to trId uId) Nothing
  92
  93 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
  94
  95 {-
  96 instance FromBasicAuthData AuthenticatedUser where
  97   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
  98
  99 authCheck :: forall env. env
 100           -> BasicAuthData
 101           -> IO (AuthResult AuthenticatedUser)
 102 authCheck _env (BasicAuthData login password) = pure $
 103   maybe Indefinite Authenticated $ TODO
 104 -}
 105
 106 withAccessM :: (CmdM env err m, HasServerError err)
 107             => UserId
 108             -> PathId
 109             -> m a
 110             -> m a
 111 withAccessM uId (PathNode id) m = do
 112   d <- id `isDescendantOf` NodeId uId
 113   if d then m else m -- serverError err401
 114
 115 withAccessM uId (PathNodeNode cId docId) m = do
 116   _a <- isIn cId docId -- TODO use one query for all ?
 117   _d <- cId `isDescendantOf` NodeId uId
 118   if True -- a && d
 119      then m
 120      else m
 121
 122 withAccess :: forall env err m api.
 123               (GargServerC env err m, HasServer api '[]) =>
 124               Proxy api -> Proxy m -> UserId -> PathId ->
 125               ServerT api m -> ServerT api m
 126 withAccess p _ uId id = hoistServer p f
 127   where
 128     f :: forall a. m a -> m a
 129     f = withAccessM uId id
 130
 131 {- | Collaborative Schema
 132 User at his root can create Teams Folder
 133 User can create Team in Teams Folder.
 134 User can invite User in Team as NodeNode only if Team in his parents.
 135 All users can access to the Team folder as if they were owner.
 136 -}