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