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