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