Error module hierarchy

gargantext.cabal

@@ -52,6 +52,7 @@ library
       Gargantext.API.Auth.PolicyCheck
       Gargantext.API.Dev
       Gargantext.API.Errors
+      Gargantext.API.Errors.Types
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams
       Gargantext.API.Ngrams.Prelude

src/Gargantext/API/Errors.hs

-{-# LANGUAGE ConstraintKinds          #-}
-{-# LANGUAGE KindSignatures           #-}
-{-# LANGUAGE LambdaCase               #-}
-{-# LANGUAGE PolyKinds                #-}
-{-# LANGUAGE RecordWildCards          #-}
-{-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE StandaloneDeriving       #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TemplateHaskell          #-}
-{-# LANGUAGE TypeApplications         #-}
-{-# LANGUAGE TypeFamilies             #-}
-{-# LANGUAGE TypeFamilyDependencies   #-}
+{-# LANGUAGE LambdaCase #-}
 
-module Gargantext.API.Errors where
+module Gargantext.API.Errors (
+  module Types
 
-import Control.Exception
-import Data.Aeson as JSON
-import Data.Aeson.Types (typeMismatch)
-import Data.Kind
-import Data.Singletons.TH
-import Data.Typeable
-import GHC.Generics
-import GHC.Stack
-import Gargantext.Database.Admin.Types.Node
-import Prelude
-import Test.QuickCheck
-import Test.QuickCheck.Instances.Text ()
-import qualified Data.Text as T
-import qualified Network.HTTP.Types as HTTP
+  -- * Conversion functions
+  , backendErrorTypeToErrStatus
+  ) where
 
--- | A 'WithStacktrace' carries an error alongside its
--- 'CallStack', to be able to print the correct source location
--- of where the error originated.
-data WithStacktrace e =
-  WithStacktrace {
-    ct_callStack :: !CallStack
-  , ct_error     :: !e
-  } deriving Show
-
-instance Exception e => Exception (WithStacktrace e) where
-  displayException WithStacktrace{..}
-    = displayException ct_error <> "\n" <> prettyCallStack ct_callStack
-
--- | A (hopefully and eventually) exhaustive list of backend errors.
-data BackendErrorType
-  = BE_phylo_corpus_not_ready
-  | BE_node_not_found
-  | BE_tree_error_root_not_found
-  deriving (Show, Eq, Enum, Bounded)
-
-$(genSingletons [''BackendErrorType])
-
--- | 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.
-data FrontendError where
-  FrontendError :: forall b. IsFrontendErrorData b =>
-    { fe_diagnostic :: !T.Text
-    , fe_type       :: !BackendErrorType
-    , fe_data       :: ToFrontendErrorData b
-    } -> FrontendError
-
-deriving instance Show FrontendError
-instance Eq FrontendError where
-  f1 == f2 = case (f1, f2) of
-    (FrontendError fe_diagnostic_1 fe_type_1 (fe_data_1 :: ToFrontendErrorData b1),
-     FrontendError fe_diagnostic_2 fe_type_2 (fe_data_2 :: ToFrontendErrorData b2))
-       -> fe_diagnostic_1 == fe_diagnostic_2 && fe_type_1 == fe_type_2 &&
-          case eqT @b1 @b2 of
-            Nothing   -> False
-            Just Refl -> fe_data_1 == fe_data_2
-
-data Dict (c :: k -> Constraint) (a :: k) where
-  Dict :: c a => Dict c a
-
-deriving instance Show (Dict c a)
-
-class ( SingI payload
-      , ToJSON (ToFrontendErrorData payload)
-      , FromJSON (ToFrontendErrorData payload)
-      , Show (ToFrontendErrorData payload)
-      , Eq (ToFrontendErrorData payload)
-      , Typeable payload
-      ) => IsFrontendErrorData payload where
-  isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload
-
-instance IsFrontendErrorData 'BE_phylo_corpus_not_ready where
-  isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'BE_node_not_found where
-  isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'BE_tree_error_root_not_found where
-  isFrontendErrorData _ = Dict
-
-----------------------------------------------------------------------------
--- This data family maps a 'BackendErrorType' into a concrete payload.
-----------------------------------------------------------------------------
-
-data family ToFrontendErrorData (payload :: BackendErrorType) :: Type
-
-data instance ToFrontendErrorData 'BE_phylo_corpus_not_ready =
-  PhyloCorpusNotReady { _pcnr_corpusId :: CorpusId }
-  deriving (Show, Eq, Generic)
-
-data instance ToFrontendErrorData 'BE_node_not_found         =
-  NodeNotFound { _nnf_nodeId :: NodeId }
-  deriving (Show, Eq, Generic)
-
-data instance ToFrontendErrorData 'BE_tree_error_root_not_found =
-  RootNotFound { _rnf_rootId :: RootId }
-  deriving (Show, Eq, Generic)
-
-----------------------------------------------------------------------------
--- JSON instances. It's important to have nice and human readable instances.
-----------------------------------------------------------------------------
-
-instance ToJSON (ToFrontendErrorData 'BE_phylo_corpus_not_ready) where
-  toJSON PhyloCorpusNotReady{..} =
-    object [ "corpus_id" .= toJSON _pcnr_corpusId ]
-
-instance FromJSON (ToFrontendErrorData 'BE_phylo_corpus_not_ready) where
-  parseJSON = withObject "PhyloCorpusNotReady" $ \o -> do
-    _pcnr_corpusId <- o .: "corpus_id"
-    pure PhyloCorpusNotReady{..}
-
-instance ToJSON (ToFrontendErrorData 'BE_node_not_found) where
-  toJSON NodeNotFound{..} = object [ "node_id" .= toJSON _nnf_nodeId ]
-
-instance FromJSON (ToFrontendErrorData 'BE_node_not_found) where
-  parseJSON = withObject "NodeNotFound" $ \o -> do
-    _nnf_nodeId <- o .: "node_id"
-    pure NodeNotFound{..}
-
-instance ToJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
-  toJSON RootNotFound{..} = object [ "root_id" .= toJSON _rnf_rootId ]
-
-instance FromJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
-  parseJSON = withObject "RootNotFound" $ \o -> do
-    _rnf_rootId <- o .: "root_id"
-    pure RootNotFound{..}
-
-mkFrontendErr :: IsFrontendErrorData payload
-              => Proxy (payload :: BackendErrorType)
-              -> ToFrontendErrorData payload
-              -> FrontendError
-mkFrontendErr et = mkFrontendErr' mempty et
-
-mkFrontendErr' :: IsFrontendErrorData payload
-               => T.Text
-               -> Proxy (payload :: BackendErrorType)
-               -> ToFrontendErrorData payload
-               -> FrontendError
-mkFrontendErr' diag (Proxy :: Proxy payload) pl = FrontendError diag (fromSing $ sing @payload) pl
-
-instance Arbitrary BackendErrorType where
-  arbitrary = arbitraryBoundedEnum
+import Gargantext.API.Errors.Types as Types
+import qualified Network.HTTP.Types.Status as HTTP
 
 backendErrorTypeToErrStatus :: BackendErrorType -> HTTP.Status
 backendErrorTypeToErrStatus = \case
   BE_phylo_corpus_not_ready    -> HTTP.status500
   BE_node_not_found            -> HTTP.status500
   BE_tree_error_root_not_found -> HTTP.status404
-
-instance Arbitrary FrontendError where
-  arbitrary = do
-    et  <- arbitrary
-    txt <- arbitrary
-    genFrontendErr txt et
-
-genFrontendErr :: T.Text -> BackendErrorType -> Gen FrontendError
-genFrontendErr txt be = case be of
-  BE_phylo_corpus_not_ready
-    -> do corpusId <- arbitrary
-          pure $ mkFrontendErr' txt (Proxy @'BE_phylo_corpus_not_ready) (PhyloCorpusNotReady corpusId)
-  BE_node_not_found
-    -> do nodeId <- arbitrary
-          pure $ mkFrontendErr' txt (Proxy @'BE_node_not_found) (NodeNotFound nodeId)
-  BE_tree_error_root_not_found
-    -> do rootId <- arbitrary
-          pure $ mkFrontendErr' txt (Proxy @'BE_tree_error_root_not_found) (RootNotFound rootId)
-
--- | This compiles if we use the correct payload type, or otherwise it won't:
--- >>> mkFrontendErr (Proxy @'BE_phylo_corpus_not_ready) NodeNotFound
-myTest :: FrontendError
-myTest = mkFrontendErr (Proxy @'BE_phylo_corpus_not_ready) (PhyloCorpusNotReady 42)
-
-instance ToJSON BackendErrorType where
-  toJSON = \case
-    BE_phylo_corpus_not_ready    -> JSON.String "phylo_corpus_not_ready"
-    BE_node_not_found            -> JSON.String "node_not_found"
-    BE_tree_error_root_not_found -> JSON.String "tree_error_root_not_found"
-
-instance FromJSON BackendErrorType where
-  parseJSON (String s) = case s of
-    "phylo_corpus_not_ready"    -> pure BE_phylo_corpus_not_ready
-    "node_not_found"            -> pure BE_node_not_found
-    "tree_error_root_not_found" -> pure BE_tree_error_root_not_found
-    unexpected               -> fail $ "FromJSON BackendErrorType unexpected value: " <> T.unpack unexpected
-  parseJSON ty = typeMismatch "BackendErrorType" ty
-
-instance ToJSON FrontendError where
-  toJSON (FrontendError diag ty dt) =
-    JSON.object [ "diagnostic" .= toJSON diag
-                , "type"       .= toJSON ty
-                , "data"       .= toJSON dt
-                ]
-
-instance FromJSON FrontendError where
-  parseJSON = withObject "FrontendError" $ \o -> do
-    (fe_diagnostic :: T.Text)      <- o .: "diagnostic"
-    (fe_type :: BackendErrorType)  <- o .: "type"
-    case fe_type of
-      BE_phylo_corpus_not_ready -> do
-        (fe_data :: ToFrontendErrorData 'BE_phylo_corpus_not_ready) <- o .: "data"
-        pure FrontendError{..}
-      BE_node_not_found         -> do
-        (fe_data :: ToFrontendErrorData 'BE_node_not_found) <- o .: "data"
-        pure FrontendError{..}
-      BE_tree_error_root_not_found -> do
-        (fe_data :: ToFrontendErrorData 'BE_tree_error_root_not_found) <- o .: "data"
-        pure FrontendError{..}

src/Gargantext/API/Errors/Types.hs

+{-# LANGUAGE ConstraintKinds          #-}
+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE PolyKinds                #-}
+{-# LANGUAGE RecordWildCards          #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TypeApplications         #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TypeFamilyDependencies   #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module Gargantext.API.Errors.Types (
+  -- * The main frontend error type
+  FrontendError(..)
+
+  -- * The enumeration of all possible backend error types
+  , BackendErrorType(..)
+
+  -- * Constructing frontend errors
+  , mkFrontendErr
+  , mkFrontendErr'
+
+  -- * Evidence carrying
+  , Dict(..)
+  , IsFrontendErrorData(..)
+
+  -- * Attaching callstacks to exceptions
+  , WithStacktrace(..)
+  ) where
+
+import Control.Exception
+import Data.Aeson as JSON
+import Data.Aeson.Types (typeMismatch)
+import Data.Kind
+import Data.Singletons.TH
+import Data.Typeable
+import GHC.Generics
+import GHC.Stack
+import Gargantext.Database.Admin.Types.Node
+import Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Instances.Text ()
+import qualified Data.Text as T
+
+-- | A 'WithStacktrace' carries an error alongside its
+-- 'CallStack', to be able to print the correct source location
+-- of where the error originated.
+data WithStacktrace e =
+  WithStacktrace {
+    ct_callStack :: !CallStack
+  , ct_error     :: !e
+  } deriving Show
+
+instance Exception e => Exception (WithStacktrace e) where
+  displayException WithStacktrace{..}
+    = displayException ct_error <> "\n" <> prettyCallStack ct_callStack
+
+-- | A (hopefully and eventually) exhaustive list of backend errors.
+data BackendErrorType
+  = BE_phylo_corpus_not_ready
+  | BE_node_not_found
+  | BE_tree_error_root_not_found
+  deriving (Show, Eq, Enum, Bounded)
+
+$(genSingletons [''BackendErrorType])
+
+-- | 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.
+data FrontendError where
+  FrontendError :: forall b. IsFrontendErrorData b =>
+    { fe_diagnostic :: !T.Text
+    , fe_type       :: !BackendErrorType
+    , fe_data       :: ToFrontendErrorData b
+    } -> FrontendError
+
+deriving instance Show FrontendError
+instance Eq FrontendError where
+  f1 == f2 = case (f1, f2) of
+    (FrontendError fe_diagnostic_1 fe_type_1 (fe_data_1 :: ToFrontendErrorData b1),
+     FrontendError fe_diagnostic_2 fe_type_2 (fe_data_2 :: ToFrontendErrorData b2))
+       -> fe_diagnostic_1 == fe_diagnostic_2 && fe_type_1 == fe_type_2 &&
+          case eqT @b1 @b2 of
+            Nothing   -> False
+            Just Refl -> fe_data_1 == fe_data_2
+
+data Dict (c :: k -> Constraint) (a :: k) where
+  Dict :: c a => Dict c a
+
+deriving instance Show (Dict c a)
+
+class ( SingI payload
+      , ToJSON (ToFrontendErrorData payload)
+      , FromJSON (ToFrontendErrorData payload)
+      , Show (ToFrontendErrorData payload)
+      , Eq (ToFrontendErrorData payload)
+      , Typeable payload
+      ) => IsFrontendErrorData payload where
+  isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload
+
+instance IsFrontendErrorData 'BE_phylo_corpus_not_ready where
+  isFrontendErrorData _ = Dict
+instance IsFrontendErrorData 'BE_node_not_found where
+  isFrontendErrorData _ = Dict
+instance IsFrontendErrorData 'BE_tree_error_root_not_found where
+  isFrontendErrorData _ = Dict
+
+----------------------------------------------------------------------------
+-- This data family maps a 'BackendErrorType' into a concrete payload.
+----------------------------------------------------------------------------
+
+data family ToFrontendErrorData (payload :: BackendErrorType) :: Type
+
+data instance ToFrontendErrorData 'BE_phylo_corpus_not_ready =
+  PhyloCorpusNotReady { _pcnr_corpusId :: CorpusId }
+  deriving (Show, Eq, Generic)
+
+data instance ToFrontendErrorData 'BE_node_not_found         =
+  NodeNotFound { _nnf_nodeId :: NodeId }
+  deriving (Show, Eq, Generic)
+
+data instance ToFrontendErrorData 'BE_tree_error_root_not_found =
+  RootNotFound { _rnf_rootId :: RootId }
+  deriving (Show, Eq, Generic)
+
+----------------------------------------------------------------------------
+-- JSON instances. It's important to have nice and human readable instances.
+----------------------------------------------------------------------------
+
+instance ToJSON (ToFrontendErrorData 'BE_phylo_corpus_not_ready) where
+  toJSON PhyloCorpusNotReady{..} =
+    object [ "corpus_id" .= toJSON _pcnr_corpusId ]
+
+instance FromJSON (ToFrontendErrorData 'BE_phylo_corpus_not_ready) where
+  parseJSON = withObject "PhyloCorpusNotReady" $ \o -> do
+    _pcnr_corpusId <- o .: "corpus_id"
+    pure PhyloCorpusNotReady{..}
+
+instance ToJSON (ToFrontendErrorData 'BE_node_not_found) where
+  toJSON NodeNotFound{..} = object [ "node_id" .= toJSON _nnf_nodeId ]
+
+instance FromJSON (ToFrontendErrorData 'BE_node_not_found) where
+  parseJSON = withObject "NodeNotFound" $ \o -> do
+    _nnf_nodeId <- o .: "node_id"
+    pure NodeNotFound{..}
+
+instance ToJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
+  toJSON RootNotFound{..} = object [ "root_id" .= toJSON _rnf_rootId ]
+
+instance FromJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
+  parseJSON = withObject "RootNotFound" $ \o -> do
+    _rnf_rootId <- o .: "root_id"
+    pure RootNotFound{..}
+
+mkFrontendErr :: IsFrontendErrorData payload
+              => Proxy (payload :: BackendErrorType)
+              -> ToFrontendErrorData payload
+              -> FrontendError
+mkFrontendErr et = mkFrontendErr' mempty et
+
+mkFrontendErr' :: IsFrontendErrorData payload
+               => T.Text
+               -> Proxy (payload :: BackendErrorType)
+               -> ToFrontendErrorData payload
+               -> FrontendError
+mkFrontendErr' diag (Proxy :: Proxy payload) pl = FrontendError diag (fromSing $ sing @payload) pl
+
+instance Arbitrary BackendErrorType where
+  arbitrary = arbitraryBoundedEnum
+
+instance Arbitrary FrontendError where
+  arbitrary = do
+    et  <- arbitrary
+    txt <- arbitrary
+    genFrontendErr txt et
+
+genFrontendErr :: T.Text -> BackendErrorType -> Gen FrontendError
+genFrontendErr txt be = case be of
+  BE_phylo_corpus_not_ready
+    -> do corpusId <- arbitrary
+          pure $ mkFrontendErr' txt (Proxy @'BE_phylo_corpus_not_ready) (PhyloCorpusNotReady corpusId)
+  BE_node_not_found
+    -> do nodeId <- arbitrary
+          pure $ mkFrontendErr' txt (Proxy @'BE_node_not_found) (NodeNotFound nodeId)
+  BE_tree_error_root_not_found
+    -> do rootId <- arbitrary
+          pure $ mkFrontendErr' txt (Proxy @'BE_tree_error_root_not_found) (RootNotFound rootId)
+
+-- | This compiles if we use the correct payload type, or otherwise it won't:
+-- >>> mkFrontendErr (Proxy @'BE_phylo_corpus_not_ready) NodeNotFound
+_myTest :: FrontendError
+_myTest = mkFrontendErr (Proxy @'BE_phylo_corpus_not_ready) (PhyloCorpusNotReady 42)
+
+instance ToJSON BackendErrorType where
+  toJSON = \case
+    BE_phylo_corpus_not_ready    -> JSON.String "phylo_corpus_not_ready"
+    BE_node_not_found            -> JSON.String "node_not_found"
+    BE_tree_error_root_not_found -> JSON.String "tree_error_root_not_found"
+
+instance FromJSON BackendErrorType where
+  parseJSON (String s) = case s of
+    "phylo_corpus_not_ready"    -> pure BE_phylo_corpus_not_ready
+    "node_not_found"            -> pure BE_node_not_found
+    "tree_error_root_not_found" -> pure BE_tree_error_root_not_found
+    unexpected               -> fail $ "FromJSON BackendErrorType unexpected value: " <> T.unpack unexpected
+  parseJSON ty = typeMismatch "BackendErrorType" ty
+
+instance ToJSON FrontendError where
+  toJSON (FrontendError diag ty dt) =
+    JSON.object [ "diagnostic" .= toJSON diag
+                , "type"       .= toJSON ty
+                , "data"       .= toJSON dt
+                ]
+
+instance FromJSON FrontendError where
+  parseJSON = withObject "FrontendError" $ \o -> do
+    (fe_diagnostic :: T.Text)      <- o .: "diagnostic"
+    (fe_type :: BackendErrorType)  <- o .: "type"
+    case fe_type of
+      BE_phylo_corpus_not_ready -> do
+        (fe_data :: ToFrontendErrorData 'BE_phylo_corpus_not_ready) <- o .: "data"
+        pure FrontendError{..}
+      BE_node_not_found         -> do
+        (fe_data :: ToFrontendErrorData 'BE_node_not_found) <- o .: "data"
+        pure FrontendError{..}
+      BE_tree_error_root_not_found -> do
+        (fe_data :: ToFrontendErrorData 'BE_tree_error_root_not_found) <- o .: "data"
+        pure FrontendError{..}