Support InternalAuthenticationError

src/Gargantext/API/Admin/Auth.hs

@@ -53,7 +53,7 @@ import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types
 import Gargantext.API.Auth.PolicyCheck
-import Gargantext.API.Prelude (joseError, HasServerError, GargServerC, GargServer, _ServerError, GargM)
+import Gargantext.API.Prelude (authenticationError, HasServerError, GargServerC, GargServer, _ServerError, GargM)
 import Gargantext.Core.Mail (MailModel(..), mail)
 import Gargantext.Core.Mail.Types (mailSettings)
 import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
@@ -78,7 +78,7 @@ import Gargantext.API.Errors
 
 -- | Main functions of authorization
 
-makeTokenForUser :: (HasSettings env, HasJoseError err)
+makeTokenForUser :: (HasSettings env, HasAuthenticationError err)
                  => NodeId
                  -> UserId
                  -> Cmd' env err Token
@@ -86,10 +86,10 @@ makeTokenForUser nodeId userId = do
   jwtS <- view $ settings . jwtSettings
   e <- liftBase $ makeJWT (AuthenticatedUser nodeId userId) jwtS Nothing
   -- TODO-SECURITY here we can implement token expiration ^^.
-  either joseError (pure . toStrict . LE.decodeUtf8) e
+  either (authenticationError . LoginFailed nodeId userId) (pure . toStrict . LE.decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: ( HasSettings env, HasJoseError err, DbCmd' env err m )
+checkAuthRequest :: ( HasSettings env, HasAuthenticationError err, DbCmd' env err m )
                  => Username
                  -> GargPassword
                  -> m CheckAuth
@@ -114,7 +114,7 @@ checkAuthRequest couldBeEmail (GargPassword p) = do
               token <- makeTokenForUser nodeId userLight_id
               pure $ Valid token nodeId userLight_id
 
-auth :: (HasSettings env, HasJoseError err, DbCmd' env err m)
+auth :: (HasSettings env, HasAuthenticationError err, DbCmd' env err m)
      => AuthRequest -> m AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
@@ -233,11 +233,12 @@ forgotPasswordPost (ForgotPasswordRequest email) = do
   -- users' emails
   pure $ ForgotPasswordResponse "ok"
 
-forgotPasswordGet :: (HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
+forgotPasswordGet :: (HasSettings env, CmdCommon env, HasAuthenticationError err, HasServerError err)
      => Maybe Text -> Cmd' env err ForgotPasswordGet
 forgotPasswordGet Nothing = pure $ ForgotPasswordGet ""
 forgotPasswordGet (Just uuid) = do
   let mUuid = fromText uuid
+  -- FIXME(adn) Sending out \"not found\" is leaking information here, we ought to fix it.
   case mUuid of
     Nothing -> throwError $ _ServerError # err404 { errBody = "Not found" }
     Just uuid' -> do
@@ -249,7 +250,7 @@ forgotPasswordGet (Just uuid) = do
 
 ---------------------
 
-forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasJoseError err, HasServerError err)
+forgotPasswordGetUser :: ( HasSettings env, CmdCommon env, HasAuthenticationError err, HasServerError err)
      => UserLight -> Cmd' env err ForgotPasswordGet
 forgotPasswordGetUser (UserLight { .. }) = do
   -- pick some random password

src/Gargantext/API/Admin/Auth/Types.hs

@@ -25,6 +25,7 @@ import Gargantext.Prelude hiding (reverse)
 import Servant.Auth.Server
 import Test.QuickCheck (elements, oneof)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Crypto.JWT as Jose
 
 ---------------------------------------------------
 
@@ -70,6 +71,10 @@ instance ToSchema AuthenticatedUser where
 instance ToJWT AuthenticatedUser
 instance FromJWT AuthenticatedUser
 
+data AuthenticationError
+  = LoginFailed NodeId UserId Jose.Error
+  deriving (Show, Eq)
+
 -- TODO-SECURITY why is the CookieSettings necessary?
 type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
 

src/Gargantext/API/Errors.hs

@@ -26,6 +26,7 @@ import qualified Network.HTTP.Types.Status as HTTP
 import qualified Data.Text as T
 import Gargantext.Database.Query.Tree hiding (treeError)
 import Data.Validity ( prettyValidation )
+import Gargantext.API.Admin.Auth.Types
 
 $(deriveHttpStatusCode ''BackendErrorCode)
 
@@ -43,13 +44,22 @@ backendErrorToFrontendError = \case
          $ FE_validation_error $ case prettyValidation validationError of
              Nothing -> "unknown_validation_error"
              Just v  -> T.pack v
-  InternalJoseError _joseError
-    -> undefined
+  InternalAuthenticationError authError
+    -> authErrorToFrontendError authError
   InternalServerError _internalServerError
     -> undefined
   InternalJobError _jobError
     -> undefined
 
+
+authErrorToFrontendError :: AuthenticationError -> FrontendError
+authErrorToFrontendError = \case
+  -- For now, we ignore the Jose error, as they are too specific
+  -- (i.e. they should be logged internally to Sentry rather than shared
+  -- externall).
+  LoginFailed nid uid _
+    -> mkFrontendErr' "Invalid username/password, or invalid session token." $ FE_login_failed_error nid uid
+
 nodeErrorToFrontendError :: NodeError -> FrontendError
 nodeErrorToFrontendError ne = case ne of
   NoListFound lid

src/Gargantext/API/Errors/Class.hs

@@ -2,7 +2,7 @@
 module Gargantext.API.Errors.Class where
 
 import Control.Lens
-import Crypto.JOSE.Error as Jose
+import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 
-class HasJoseError e where
-  _JoseError :: Prism' e Jose.Error
+class HasAuthenticationError e where
+  _AuthenticationError :: Prism' e AuthenticationError

src/Gargantext/API/Errors/Types.hs

@@ -61,13 +61,13 @@ import Servant (ServerError)
 import Servant.Job.Core
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Text ()
-import qualified Crypto.JWT as Jose
 import qualified Data.Text as T
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Servant.Job.Types as SJ
 import Text.Read (readMaybe)
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe
+import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 
 -- | A 'WithStacktrace' carries an error alongside its
 -- 'CallStack', to be able to print the correct source location
@@ -86,12 +86,12 @@ instance Exception e => Exception (WithStacktrace e) where
 -- | An internal error which can be emitted from the backend and later
 -- converted into a 'FrontendError', for later consumption.
 data BackendInternalError
-  = InternalNodeError       !NodeError
-  | InternalTreeError       !TreeError
-  | InternalValidationError !Validation
-  | InternalJoseError       !Jose.Error
-  | InternalServerError     !ServerError
-  | InternalJobError        !Jobs.JobError
+  = InternalNodeError           !NodeError
+  | InternalTreeError           !TreeError
+  | InternalValidationError     !Validation
+  | InternalAuthenticationError !AuthenticationError
+  | InternalServerError         !ServerError
+  | InternalJobError            !Jobs.JobError
   deriving (Show, Typeable)
 
 makePrisms ''BackendInternalError
@@ -122,8 +122,8 @@ instance HasTreeError BackendInternalError where
 instance HasServerError BackendInternalError where
   _ServerError = _InternalServerError
 
-instance HasJoseError BackendInternalError where
-  _JoseError = _InternalJoseError
+instance HasAuthenticationError BackendInternalError where
+  _AuthenticationError = _InternalAuthenticationError
 
 -- | An error that can be returned to the frontend. It carries a human-friendly
 -- diagnostic, the 'type' of the error as well as some context-specific data.
@@ -199,6 +199,17 @@ data instance ToFrontendErrorData 'EC_400__validation_error =
   FE_validation_error { validation_error :: T.Text }
   deriving (Show, Eq, Generic)
 
+--
+-- authentication errors
+--
+
+data instance ToFrontendErrorData 'EC_403__login_failed_error =
+  FE_login_failed_error { lfe_node_id :: NodeId
+                        , lfe_user_id :: UserId
+                        }
+  deriving (Show, Eq, Generic)
+
+
 --
 -- Tree errors
 --
@@ -267,6 +278,19 @@ instance FromJSON (ToFrontendErrorData 'EC_400__validation_error) where
   parseJSON (String txt) = pure $ FE_validation_error txt
   parseJSON ty           = typeMismatch "FE_validation_error" ty
 
+--
+-- authentication errors
+--
+
+instance ToJSON (ToFrontendErrorData 'EC_403__login_failed_error) where
+  toJSON FE_login_failed_error{..} =
+    object [ "user_id" .= toJSON lfe_user_id, "node_id" .= toJSON lfe_node_id ]
+
+instance FromJSON (ToFrontendErrorData 'EC_403__login_failed_error) where
+  parseJSON = withObject "FE_login_failed_error" $ \o -> do
+    lfe_user_id <- o .: "user_id"
+    lfe_node_id <- o .: "node_id"
+    pure FE_login_failed_error{..}
 
 --
 -- tree errors
@@ -317,12 +341,19 @@ genFrontendErr be = do
     EC_404__node_error_not_found
       -> do nodeId <- arbitrary
             pure $ mkFrontendErr' txt (FE_node_error_not_found nodeId)
+
     -- validation error
     EC_400__validation_error
       -> do let genValChain = oneof [ Violated <$> arbitrary, Location <$> arbitrary <*> genValChain ]
             chain <- listOf1 genValChain
             pure $ mkFrontendErr' txt $ FE_validation_error (T.pack $ fromMaybe "unknown_validation_error" $ prettyValidation $ Validation chain)
 
+    -- authentication error
+    EC_403__login_failed_error
+      -> do nid <- arbitrary
+            uid <- arbitrary
+            pure $ mkFrontendErr' txt $ FE_login_failed_error nid uid
+
     -- tree errors
     EC_404__tree_error_root_not_found
       -> pure $ mkFrontendErr' txt $ FE_tree_error_root_not_found
@@ -374,6 +405,11 @@ instance FromJSON FrontendError where
         (fe_data :: ToFrontendErrorData 'EC_400__validation_error) <- o .: "data"
         pure FrontendError{..}
 
+      -- authentication errors
+      EC_403__login_failed_error -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__login_failed_error) <- o .: "data"
+        pure FrontendError{..}
+
       -- tree errors
       EC_404__tree_error_root_not_found -> do
         (fe_data :: ToFrontendErrorData 'EC_404__tree_error_root_not_found) <- o .: "data"

src/Gargantext/API/Errors/Types/Backend.hs

@@ -23,6 +23,8 @@ data BackendErrorCode
   | EC_500__node_error_not_implemented_yet
   -- validation errors
   | EC_400__validation_error
+  -- authentication errors
+  | EC_403__login_failed_error
   -- tree errors
   | EC_404__tree_error_root_not_found
   | EC_404__tree_error_empty_root

src/Gargantext/API/Prelude.hs

@@ -21,8 +21,8 @@ module Gargantext.API.Prelude
   where
 
 import Control.Lens ((#))
-import Crypto.JOSE.Error as Jose
 import Data.Aeson.Types
+import Gargantext.API.Admin.Auth.Types (AuthenticationError)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
 import Gargantext.API.Errors.Class
@@ -40,8 +40,8 @@ import Servant
 import Servant.Job.Async
 import Servant.Job.Core (HasServerError(..), serverError)
 
-joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
-joseError = throwError . (_JoseError #)
+authenticationError :: (MonadError e m, HasAuthenticationError e) => AuthenticationError -> m a
+authenticationError = throwError . (_AuthenticationError #)
 
 type HasJobEnv' env = HasJobEnv env JobLog JobLog
 
@@ -56,13 +56,13 @@ type EnvC env =
   )
 
 type ErrC err =
-  ( HasNodeError       err
-  , HasValidationError err
-  , HasTreeError       err
-  , HasServerError     err
-  , HasJoseError       err
---  , ToJSON           err -- TODO this is arguable
-  , Exception          err
+  ( HasNodeError           err
+  , HasValidationError     err
+  , HasTreeError           err
+  , HasServerError         err
+  , HasAuthenticationError err
+--  , ToJSON               err -- TODO this is arguable
+  , Exception              err
   )
 
 type GargServerC env err m =

src/Gargantext/Database/Admin/Types/Node.hs

@@ -74,6 +74,9 @@ instance DecodeScalar UserId where
 instance ResourceId UserId where
   isPositive = (> 0) . _UserId
 
+instance Arbitrary UserId where
+  arbitrary = UnsafeMkUserId . getPositive <$> arbitrary
+
 instance DefaultFromField SqlInt4 UserId
   where
     defaultFromField = fromPGSFromField