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 -}