src/Gargantext/API/Auth.hs

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