[errors] refactor auth errors

Related to purescript-gargantext#600
parent 030f7dad
Pipeline #5472 failed with stages
in 100 minutes and 6 seconds
......@@ -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)
......
......@@ -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,18 +35,9 @@ 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
}
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
data AuthResponse = AuthResponse { _authRes_token :: Token
, _authRes_tree_id :: TreeId
, _authRes_user_id :: UserId
}
deriving (Generic, Eq, Show)
......@@ -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
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment