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