[errors] refactor auth errors

Related to purescript-gargantext#600

src/Gargantext/API/Admin/Auth.hs

@@ -119,9 +119,11 @@ auth :: (HasSettings env, HasAuthenticationError err, DbCmd' env err m)
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
   case checkAuthRequest' of
-    InvalidUser     -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid username or password")
-    InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid username or password")
-    Valid to trId uId   -> pure $ AuthResponse (Just $ AuthValid to trId uId) Nothing
+    InvalidUser     -> do
+      throwError $ _AuthenticationError # InvalidUsernameOrPassword
+    InvalidPassword -> do
+      throwError $ _AuthenticationError # InvalidUsernameOrPassword
+    Valid to trId uId   -> pure $ AuthResponse to trId uId
 
 --type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
 

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

@@ -23,7 +23,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), ListId, DocId, UserId (..))
 import Gargantext.Prelude hiding (reverse)
 import Servant.Auth.Server
-import Test.QuickCheck (elements, oneof)
+import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import qualified Crypto.JWT as Jose
 
@@ -35,21 +35,12 @@ data AuthRequest = AuthRequest { _authReq_username :: Username
                                }
   deriving (Generic)
 
--- TODO: Use an HTTP error to wrap AuthInvalid
-data AuthResponse = AuthResponse { _authRes_valid :: Maybe AuthValid
-                                 , _authRes_inval :: Maybe AuthInvalid
+data AuthResponse = AuthResponse { _authRes_token   :: Token
+                                 , _authRes_tree_id :: TreeId
+                                 , _authRes_user_id :: UserId
                                  }
   deriving (Generic, Eq, Show)
 
-data AuthInvalid = AuthInvalid { _authInv_message :: Text }
-  deriving (Generic, Eq, Show)
-
-data AuthValid = AuthValid { _authVal_token   :: Token
-                           , _authVal_tree_id :: TreeId
-                           , _authVal_user_id :: UserId
-                           }
-  deriving (Generic, Eq, Show)
-
 type Token  = Text
 type TreeId = NodeId
 
@@ -73,6 +64,7 @@ instance FromJWT AuthenticatedUser
 
 data AuthenticationError
   = LoginFailed NodeId UserId Jose.Error
+  | InvalidUsernameOrPassword
   deriving (Show, Eq)
 
 -- TODO-SECURITY why is the CookieSettings necessary?
@@ -93,22 +85,7 @@ $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
 instance ToSchema AuthResponse where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
 instance Arbitrary AuthResponse where
-  arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
-                    , flip AuthResponse Nothing . Just <$> arbitrary ]
-
-$(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
-instance ToSchema AuthInvalid where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
-instance Arbitrary AuthInvalid where
-  arbitrary = elements [ AuthInvalid m
-                       | m <- [ "Invalid user", "Invalid password"]
-                       ]
-
-$(deriveJSON (unPrefix "_authVal_") ''AuthValid)
-instance ToSchema AuthValid where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
-instance Arbitrary AuthValid where
-  arbitrary = elements [ AuthValid to' tr u
+  arbitrary = elements [ AuthResponse to' tr u
                        | to' <- ["token0", "token1"]
                        , tr <- map UnsafeMkNodeId [1..3]
                        , u <-  map UnsafeMkUserId [1..3]
@@ -140,5 +117,4 @@ $(deriveJSON (unPrefix "_fpGet_") ''ForgotPasswordGet)
 instance ToSchema ForgotPasswordGet where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpGet_")
 
-makeLenses ''AuthValid
 makeLenses ''AuthResponse

src/Gargantext/API/Errors.hs

@@ -93,6 +93,8 @@ authErrorToFrontendError = \case
   -- externally).
   LoginFailed nid uid _
     -> mkFrontendErr' "Invalid username/password, or invalid session token." $ FE_login_failed_error nid uid
+  InvalidUsernameOrPassword
+    -> mkFrontendErr' "Invalid username or password." $ FE_login_failed_invalid_username_or_password
 
 nodeErrorToFrontendError :: NodeError -> FrontendError
 nodeErrorToFrontendError ne = case ne of

src/Gargantext/API/Errors/Types.hs

@@ -260,6 +260,11 @@ data instance ToFrontendErrorData 'EC_403__login_failed_error =
   deriving (Show, Eq, Generic)
 
 
+data instance ToFrontendErrorData 'EC_403__login_failed_invalid_username_or_password =
+  FE_login_failed_invalid_username_or_password
+  deriving (Show, Eq, Generic)
+
+
 --
 -- Tree errors
 --
@@ -472,6 +477,15 @@ instance FromJSON (ToFrontendErrorData 'EC_403__login_failed_error) where
     lfe_node_id <- o .: "node_id"
     pure FE_login_failed_error{..}
 
+
+instance ToJSON (ToFrontendErrorData 'EC_403__login_failed_invalid_username_or_password) where
+  toJSON FE_login_failed_invalid_username_or_password =
+    object []
+
+instance FromJSON (ToFrontendErrorData 'EC_403__login_failed_invalid_username_or_password) where
+  parseJSON = withObject "FE_login_failed_invalid_username_or_password" $ \_o -> do
+    pure FE_login_failed_invalid_username_or_password
+
 --
 -- internal server errors
 --
@@ -638,6 +652,10 @@ genFrontendErr be = do
             uid <- arbitrary
             pure $ mkFrontendErr' txt $ FE_login_failed_error nid uid
 
+    EC_403__login_failed_invalid_username_or_password
+      -> do
+            pure $ mkFrontendErr' txt $ FE_login_failed_invalid_username_or_password
+
     -- internal error
     EC_500__internal_server_error
       -> do err <- arbitrary
@@ -753,6 +771,10 @@ instance FromJSON FrontendError where
         (fe_data :: ToFrontendErrorData 'EC_403__login_failed_error) <- o .: "data"
         pure FrontendError{..}
 
+      EC_403__login_failed_invalid_username_or_password -> do
+        (fe_data :: ToFrontendErrorData 'EC_403__login_failed_invalid_username_or_password) <- o .: "data"
+        pure FrontendError{..}
+
       -- internal server error
       EC_500__internal_server_error -> do
         (fe_data :: ToFrontendErrorData 'EC_500__internal_server_error) <- o .: "data"

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

@@ -36,6 +36,7 @@ data BackendErrorCode
   | EC_400__validation_error
   -- authentication errors
   | EC_403__login_failed_error
+  | EC_403__login_failed_invalid_username_or_password
   -- tree errors
   | EC_404__tree_root_not_found
   | EC_404__tree_empty_root

src/Gargantext/Core/Types/Individu.hs

@@ -29,7 +29,9 @@ import Prelude qualified
 
 -- FIXME UserName used twice
 data User = UserDBId UserId | UserName Text | RootId NodeId
-  deriving (Eq)
+  deriving (Show, Eq, Generic)
+
+instance ToJSON User
 
 renderUser :: User -> T.Text
 renderUser = \case

src/Gargantext/Database/Action/Share.hs

@@ -72,7 +72,7 @@ membersOfQuery (_NodeId -> teamId) = proc () -> do
   (nn, n, u) <- nodeNode_node_User -< ()
   restrict -< (nn ^. nn_node2_id) .== sqlInt4 teamId
   returnA -< ( user_username <$> u
-             , view node_id <$> n)
+             , view node_id <$> n )
 
 
 nodeNode_node_User :: O.Select ( NodeNodeRead

src/Gargantext/Database/Query/Table/Node/Error.hs

@@ -30,11 +30,9 @@ import Control.Lens (Prism', (#), (^?))
 import Data.Aeson
 import Data.Text qualified as T
 import Gargantext.Core.Types.Individu
-
-import Prelude hiding (null, id, map, sum, show)
-
 import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..), ContextId, UserId, ParentId)
 import Gargantext.Prelude hiding (sum, head)
+import Prelude hiding (null, id, map, sum, show)
 import Prelude qualified
 
 data NodeCreationError
@@ -42,6 +40,9 @@ data NodeCreationError
   | UserParentDoesNotExist  UserId
   | UserHasNegativeId       UserId
   | InsertNodeFailed        UserId ParentId
+  deriving (Show, Eq, Generic)
+
+instance ToJSON NodeCreationError
 
 renderNodeCreationFailed :: NodeCreationError -> T.Text
 renderNodeCreationFailed = \case
@@ -56,13 +57,16 @@ data NodeLookupError
   | UserDoesNotExist     UserId
   | UserNameDoesNotExist Username
   | UserHasTooManyRoots UserId [NodeId]
+  deriving (Show, Eq, Generic)
+
+instance ToJSON NodeLookupError
 
 renderNodeLookupFailed :: NodeLookupError -> T.Text
 renderNodeLookupFailed = \case
   NodeDoesNotExist nid   -> "node with id " <> T.pack (show nid) <> " couldn't be found."
   NodeParentDoesNotExist nid -> "no parent for node with id " <> T.pack (show nid) <> "."
   UserDoesNotExist uid -> "user with id " <> T.pack (show uid) <> " couldn't be found."
-  UserNameDoesNotExist uname -> "user with username '" <> uname <> " couldn't be found."
+  UserNameDoesNotExist uname -> "user with username '" <> uname <> "' couldn't be found."
   UserHasTooManyRoots uid roots -> "user with id " <> T.pack (show uid) <> " has too many roots: [" <> T.intercalate "," (map (T.pack . show) roots)
 
 ------------------------------------------------------------------------
@@ -95,11 +99,29 @@ instance Prelude.Show NodeError
     show (DoesNotExist n)   = "Node does not exist (" <> show n <> ")"
 
 instance ToJSON NodeError where
+  toJSON (DoesNotExist n) =
+    object [ ( "error", "Node does not exist" )
+           , ( "node", toJSON n ) ]
   toJSON (NoListFound listId) =
     object [ ( "error", "No list found" )
            , ( "listId", toJSON listId ) ]
+  toJSON (NodeError e) =
+    object [ ( "error", "Node error" )
+           , ( "exception", toJSON $ T.pack $ show e ) ]
+  toJSON (NoUserFound ur) =
+    object [ ( "error", "No user found" )
+           , ( "user", toJSON ur ) ]
+  toJSON (NodeCreationFailed reason) =
+    object [ ( "error", "Node creation failed" )
+           , ( "reason", toJSON reason ) ]
+  toJSON (NodeLookupFailed reason) =
+    object [ ( "error", "Node lookup failed" )
+           , ( "reason", toJSON reason ) ]
+  toJSON (NoContextFound n) =
+    object [ ( "error", "No context found" )
+           , ( "node", toJSON n ) ]
   toJSON err =
-    object [ ( "error", String $ T.pack $ show err ) ]
+    object [ ( "error", toJSON $ T.pack $ show err ) ]
 
 class HasNodeError e where
   _NodeError :: Prism' e NodeError