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