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 MonoLocalBinds      #-}
  24 {-# LANGUAGE ScopedTypeVariables #-}
  25 {-# LANGUAGE TypeOperators      #-}
  26
  27 module Gargantext.API.Admin.Auth
  28   ( auth
  29   , forgotPassword
  30   , forgotPasswordAsync
  31   , withAccess
  32   , ForgotPasswordAPI
  33   , ForgotPasswordAsyncParams
  34   , ForgotPasswordAsyncAPI
  35   )
  36   where
  37
  38 import Control.Lens (view, (#))
  39 --import Control.Monad.Logger.Aeson
  40 import Data.Aeson
  41 import Data.Swagger (ToSchema(..))
  42 import Data.Text (Text)
  43 import Data.Text.Lazy (toStrict)
  44 import qualified Data.Text.Lazy.Encoding as LE
  45 import Data.UUID (UUID, fromText, toText)
  46 import Data.UUID.V4 (nextRandom)
  47 import GHC.Generics (Generic)
  48 import Servant
  49 import Servant.Auth.Server
  50 --import qualified Text.Blaze.Html5.Attributes as HA
  51
  52 import qualified Gargantext.Prelude.Crypto.Auth as Auth
  53
  54 import Gargantext.API.Admin.Auth.Types
  55 import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
  56 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  57 import Gargantext.API.Admin.Types
  58 import Gargantext.API.Job (jobLogSuccess)
  59 import Gargantext.API.Prelude (HasJoseError(..), joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM, GargError)
  60 import Gargantext.Core.Mail (MailModel(..), mail)
  61 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
  62 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
  63 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  64 import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId)
  65 import Gargantext.Database.Prelude (Cmd', CmdM, HasConnectionPool, HasConfig)
  66 import Gargantext.Database.Query.Table.User
  67 import Gargantext.Database.Query.Tree (isDescendantOf, isIn)
  68 import Gargantext.Database.Query.Tree.Root (getRoot)
  69 import Gargantext.Database.Schema.Node (NodePoly(_node_id))
  70 import Gargantext.Prelude hiding (reverse)
  71 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
  72 import Gargantext.Utils.Jobs (serveJobsAPI)
  73
  74 ---------------------------------------------------
  75
  76 -- | Main functions of authorization
  77
  78 makeTokenForUser :: (HasSettings env, HasJoseError err)
  79                  => NodeId -> Cmd' env err Token
  80 makeTokenForUser uid = do
  81   jwtS <- view $ settings . jwtSettings
  82   e <- liftBase $ makeJWT (AuthenticatedUser uid) jwtS Nothing
  83   -- TODO-SECURITY here we can implement token expiration ^^.
  84   either joseError (pure . toStrict . LE.decodeUtf8) e
  85   -- TODO not sure about the encoding...
  86
  87 checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
  88                  => Username
  89                  -> GargPassword
  90                  -> Cmd' env err CheckAuth
  91 checkAuthRequest u (GargPassword p) = do
  92   candidate <- head <$> getUsersWith u
  93   case candidate of
  94     Nothing -> pure InvalidUser
  95     Just (UserLight { userLight_password = GargPassword h, .. }) ->
  96       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
  97         Auth.PasswordCheckFail    -> pure InvalidPassword
  98         Auth.PasswordCheckSuccess -> do
  99           muId <- head <$> getRoot (UserName u)
 100           case _node_id <$> muId of
 101             Nothing  -> pure InvalidUser
 102             Just uid -> do
 103               token <- makeTokenForUser uid
 104               pure $ Valid token uid userLight_id
 105
 106 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
 107      => AuthRequest -> Cmd' env err AuthResponse
 108 auth (AuthRequest u p) = do
 109   checkAuthRequest' <- checkAuthRequest u p
 110   case checkAuthRequest' of
 111     InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
 112     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
 113     Valid to trId uId   -> pure $ AuthResponse (Just $ AuthValid to trId uId) Nothing
 114
 115 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 116
 117 {-
 118 instance FromBasicAuthData AuthenticatedUser where
 119   fromBasicAuthData authData authCheckFunction = authCheckFunction authData
 120
 121 authCheck :: forall env. env
 122           -> BasicAuthData
 123           -> IO (AuthResult AuthenticatedUser)
 124 authCheck _env (BasicAuthData login password) = pure $
 125   maybe Indefinite Authenticated $ TODO
 126 -}
 127
 128 withAccessM :: (CmdM env err m, HasServerError err)
 129             => UserId
 130             -> PathId
 131             -> m a
 132             -> m a
 133 withAccessM uId (PathNode id) m = do
 134   d <- id `isDescendantOf` NodeId uId
 135   if d then m else m -- serverError err401
 136
 137 withAccessM uId (PathNodeNode cId docId) m = do
 138   _a <- isIn cId docId -- TODO use one query for all ?
 139   _d <- cId `isDescendantOf` NodeId uId
 140   if True -- a && d
 141      then m
 142      else m
 143
 144 withAccess :: forall env err m api.
 145               (GargServerC env err m, HasServer api '[]) =>
 146               Proxy api -> Proxy m -> UserId -> PathId ->
 147               ServerT api m -> ServerT api m
 148 withAccess p _ uId id = hoistServer p f
 149   where
 150     f :: forall a. m a -> m a
 151     f = withAccessM uId id
 152
 153 {- | Collaborative Schema
 154 User at his root can create Teams Folder
 155 User can create Team in Teams Folder.
 156 User can invite User in Team as NodeNode only if Team in his parents.
 157 All users can access to the Team folder as if they were owner.
 158 -}
 159
 160 newtype ForgotPasswordAsyncParams =
 161   ForgotPasswordAsyncParams { email :: Text }
 162   deriving (Generic, Show)
 163 instance FromJSON ForgotPasswordAsyncParams where
 164   parseJSON = genericParseJSON defaultOptions
 165 instance ToJSON ForgotPasswordAsyncParams where
 166   toJSON = genericToJSON defaultOptions
 167 instance ToSchema ForgotPasswordAsyncParams
 168
 169 type ForgotPasswordAPI = Summary "Forgot password POST API"
 170                            :> ReqBody '[JSON] ForgotPasswordRequest
 171                            :> Post '[JSON] ForgotPasswordResponse
 172                          :<|> Summary "Forgot password GET API"
 173                            :> QueryParam "uuid" Text
 174                            :> Get '[JSON] ForgotPasswordGet
 175
 176
 177 forgotPassword :: GargServer ForgotPasswordAPI
 178      -- => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 179 forgotPassword = forgotPasswordPost :<|> forgotPasswordGet
 180
 181 forgotPasswordPost :: ( HasConnectionPool env, HasConfig env, HasMail env)
 182      => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
 183 forgotPasswordPost (ForgotPasswordRequest email) = do
 184   us <- getUsersWithEmail email
 185   case us of
 186     [u] -> forgotUserPassword u
 187     _ -> pure ()
 188
 189   -- NOTE Sending anything else here could leak information about
 190   -- users' emails
 191   pure $ ForgotPasswordResponse "ok"
 192
 193 forgotPasswordGet :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
 194      => Maybe Text -> Cmd' env err ForgotPasswordGet
 195 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 196 forgotPasswordGet (Just uuid) = do
 197   let mUuid = fromText uuid
 198   case mUuid of
 199     Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
 200     Just uuid' -> do
 201       -- fetch user
 202       us <- getUsersWithForgotPasswordUUID uuid'
 203       case us of
 204         [u] -> forgotPasswordGetUser u
 205         _ -> throwError $ _ServerError # err404 { errBody = "Not found" }
 206
 207 ---------------------
 208
 209 forgotPasswordGetUser :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env, HasServerError err)
 210      => UserLight -> Cmd' env err ForgotPasswordGet
 211 forgotPasswordGetUser (UserLight { .. }) = do
 212   -- pick some random password
 213   password <- liftBase gargPass
 214
 215   -- set it as user's password
 216   hashed <- liftBase $ Auth.hashPassword $ Auth.mkPassword password
 217   let hashed' = Auth.unPasswordHash hashed
 218   let userPassword = UserLight { userLight_password = GargPassword hashed', .. }
 219   _ <- updateUserPassword userPassword
 220
 221   -- display this briefly in the html
 222
 223   -- clear the uuid so that the page can't be refreshed
 224   _ <- updateUserForgotPasswordUUID $ UserLight { userLight_forgot_password_uuid = Nothing, .. }
 225
 226   pure $ ForgotPasswordGet password
 227
 228 forgotUserPassword :: (HasConnectionPool env, HasConfig env, HasMail env)
 229      => UserLight -> Cmd' env err ()
 230 forgotUserPassword (UserLight { .. }) = do
 231   --printDebug "[forgotUserPassword] userLight_id" userLight_id
 232   --logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
 233   -- generate uuid for email
 234   uuid <- generateForgotPasswordUUID
 235
 236   let userUUID = UserLight { userLight_forgot_password_uuid = Just $ toText uuid, .. }
 237
 238   -- save user with that uuid
 239   _ <- updateUserForgotPasswordUUID userUUID
 240
 241   -- send email with uuid link
 242   cfg <- view $ mailSettings
 243   mail cfg (ForgotPassword { user = userUUID })
 244
 245   -- on uuid link enter: change user password and present it to the
 246   -- user
 247
 248   pure ()
 249
 250 --------------------------
 251
 252 -- Generate a unique (in whole DB) UUID for passwords.
 253 generateForgotPasswordUUID :: (HasConnectionPool env, HasConfig env, HasMail env)
 254   => Cmd' env err UUID
 255 generateForgotPasswordUUID = do
 256   uuid <- liftBase $ nextRandom
 257   us <- getUsersWithForgotPasswordUUID uuid
 258   case us of
 259     [] -> pure uuid
 260     _ -> generateForgotPasswordUUID
 261
 262 ----------------------------
 263
 264 -- NOTE THe async endpoint is better for the "forget password"
 265 -- request, because the delay in email sending etc won't reveal to
 266 -- malicious users emails of our users in the db
 267 type ForgotPasswordAsyncAPI = Summary "Forgot password asnc"
 268                               :> AsyncJobs JobLog '[JSON] ForgotPasswordAsyncParams JobLog
 269
 270 forgotPasswordAsync :: ServerT ForgotPasswordAsyncAPI (GargM Env GargError)
 271 forgotPasswordAsync =
 272   serveJobsAPI ForgotPasswordJob $ \p log' ->
 273     forgotPasswordAsync' p (liftBase . log')
 274
 275 forgotPasswordAsync' :: (FlowCmdM env err m)
 276   => ForgotPasswordAsyncParams
 277   -> (JobLog -> m ())
 278   -> m JobLog
 279 forgotPasswordAsync' (ForgotPasswordAsyncParams { email }) logStatus = do
 280   let jobLog = JobLog { _scst_succeeded = Just 1
 281                       , _scst_failed    = Just 0
 282                       , _scst_remaining = Just 1
 283                       , _scst_events    = Just []
 284                       }
 285   logStatus jobLog
 286
 287   printDebug "[forgotPasswordAsync'] email" email
 288
 289   _ <- forgotPasswordPost $ ForgotPasswordRequest { _fpReq_email = email }
 290
 291   pure $ jobLogSuccess jobLog