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 NoImplicitPrelude   #-}
  24 {-# LANGUAGE DeriveGeneric       #-}
  25 {-# LANGUAGE DataKinds           #-}
  26 {-# LANGUAGE FlexibleContexts    #-}
  27 {-# LANGUAGE OverloadedStrings   #-}
  28 {-# LANGUAGE RankNTypes          #-}
  29 {-# LANGUAGE ScopedTypeVariables #-}
  30 {-# LANGUAGE TemplateHaskell     #-}
  31
  32 module Gargantext.API.Admin.Auth
  33       where
  34
  35 import Control.Lens (view)
  36 import Data.Aeson.TH (deriveJSON)
  37 import Data.Swagger
  38 import Data.Text (Text)
  39 import Data.Text.Lazy (toStrict)
  40 import Data.Text.Lazy.Encoding (decodeUtf8)
  41 import GHC.Generics (Generic)
  42 import Gargantext.API.Admin.Settings
  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)
  51 import Gargantext.Prelude hiding (reverse)
  52 import Gargantext.Database.Query.Table.User
  53 import Servant
  54 import Servant.Auth.Server
  55 import Test.QuickCheck (elements, oneof)
  56 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  57 import qualified Gargantext.Core.Auth as Auth
  58
  59 ---------------------------------------------------
  60
  61 -- | Main types for AUTH API
  62 data AuthRequest = AuthRequest { _authReq_username :: Username
  63                                , _authReq_password :: GargPassword
  64                                }
  65   deriving (Generic)
  66
  67 -- TODO: Use an HTTP error to wrap AuthInvalid
  68 data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
  69                                  , _authRes_inval :: Maybe AuthInvalid
  70                                  }
  71   deriving (Generic)
  72
  73 data AuthInvalid = AuthInvalid { _authInv_message :: Text }
  74   deriving (Generic)
  75
  76 data AuthValid = AuthValid { _authVal_token   :: Token
  77                            , _authVal_tree_id :: TreeId
  78                            }
  79   deriving (Generic)
  80
  81 type Token  = Text
  82 type TreeId = NodeId
  83
  84 -- | Main functions of authorization
  85
  86 -- | Main types of authorization
  87 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
  88   deriving (Eq)
  89
  90 makeTokenForUser :: (HasSettings env, HasJoseError err)
  91                  => NodeId -> Cmd' env err Token
  92 makeTokenForUser uid = do
  93   jwtS <- view $ settings . jwtSettings
  94   e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
  95   -- TODO-SECURITY here we can implement token expiration ^^.
  96   either joseError (pure . toStrict . decodeUtf8) e
  97   -- TODO not sure about the encoding...
  98
  99 checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err)
 100                  => Username
 101                  -> GargPassword
 102                  -> Cmd' env err CheckAuth
 103 checkAuthRequest u (GargPassword p) = do
 104   candidate <- head <$> getUsersWith u
 105   case candidate of
 106     Nothing -> pure InvalidUser
 107     Just (UserLight _id _u _email h) ->
 108       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
 109         Auth.PasswordCheckFail    -> pure InvalidPassword
 110         Auth.PasswordCheckSuccess -> do
 111           muId <- head <$> getRoot (UserName u)
 112           case _node_id <$> muId of
 113             Nothing  -> pure InvalidUser
 114             Just uid -> do
 115               token <- makeTokenForUser uid
 116               pure $ Valid token uid
 117
 118 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err)
 119      => AuthRequest -> Cmd' env err AuthResponse
 120 auth (AuthRequest u p) = do
 121   checkAuthRequest' <- checkAuthRequest u p
 122   case checkAuthRequest' of
 123     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
 124     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
 125     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 126
 127 newtype AuthenticatedUser = AuthenticatedUser
 128   { _authUser_id :: NodeId
 129   } deriving (Generic)
 130
 131 $(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
 132
 133 instance ToSchema AuthenticatedUser where
 134   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
 135
 136 instance ToJWT AuthenticatedUser
 137 instance FromJWT AuthenticatedUser
 138
 139 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 140
 141 -- TODO-SECURITY why is the CookieSettings necessary?
 142 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 143
 144 {-
 145 instance FromBasicAuthData AuthenticatedUser where
 146   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
 147
 148 authCheck :: forall env. env
 149           -> BasicAuthData
 150           -> IO (AuthResult AuthenticatedUser)
 151 authCheck _env (BasicAuthData login password) = pure $
 152   maybe Indefinite Authenticated $ TODO
 153 -}
 154
 155 -- | Instances
 156 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
 157 instance ToSchema AuthRequest where
 158   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
 159
 160 instance Arbitrary AuthRequest where
 161   arbitrary = elements [ AuthRequest u p
 162                        | u <- arbitraryUsername
 163                        , p <- arbitraryPassword
 164                        ]
 165
 166 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 167 instance ToSchema AuthResponse where
 168   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
 169 instance Arbitrary AuthResponse where
 170   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
 171                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 172
 173 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
 174 instance ToSchema AuthInvalid where
 175   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
 176 instance Arbitrary AuthInvalid where
 177   arbitrary = elements [ AuthInvalid m
 178                        | m <- [ "Invalid user", "Invalid password"]
 179                        ]
 180
 181 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
 182 instance ToSchema AuthValid where
 183   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
 184 instance Arbitrary AuthValid where
 185   arbitrary = elements [ AuthValid to tr
 186                        | to <- ["token0", "token1"]
 187                        , tr <- [1..3]
 188                        ]
 189
 190 data PathId = PathNode NodeId | PathNodeNode ListId DocId
 191
 192 withAccessM :: (CmdM env err m, HasServerError err)
 193             => UserId
 194             -> PathId
 195             -> m a
 196             -> m a
 197 withAccessM uId (PathNode id) m = do
 198   d <- id `isDescendantOf` NodeId uId
 199   if d then m else m -- serverError err401
 200
 201 withAccessM uId (PathNodeNode cId docId) m = do
 202   _a <- isIn cId docId -- TODO use one query for all ?
 203   _d <- cId `isDescendantOf` NodeId uId
 204   if True -- a && d
 205      then m
 206      else m
 207
 208 withAccess :: forall env err m api.
 209               (GargServerC env err m, HasServer api '[]) =>
 210               Proxy api -> Proxy m ->
 211               UserId -> PathId ->
 212               ServerT api m -> ServerT api m
 213 withAccess p _ uId id = hoistServer p f
 214   where
 215     f :: forall a. m a -> m a
 216     f = withAccessM uId id
 217
 218 {- | Collaborative Schema
 219 User at his root can create Teams Folder
 220 User can create Team in Teams Folder.
 221 User can invite User in Team as NodeNode only if Team in his parents.
 222 All users can access to the Team folder as if they were owner.
 223 -}