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