Deriving generally the error code for a BackendErrorCode

gargantext.cabal

@@ -53,6 +53,7 @@ library
       Gargantext.API.Dev
       Gargantext.API.Errors
       Gargantext.API.Errors.Class
+      Gargantext.API.Errors.TH
       Gargantext.API.Errors.Types
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams

src/Gargantext/API/Errors.hs

 {-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE TemplateHaskell  #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Errors (
@@ -17,17 +18,14 @@ import Prelude
 
 import Gargantext.API.Errors.Class as Class
 import Gargantext.API.Errors.Types as Types
+import Gargantext.API.Errors.TH (deriveHttpStatusCode)
 import Gargantext.Database.Query.Table.Node.Error hiding (nodeError)
 import Servant.Server
 import qualified Data.Aeson as JSON
 import qualified Network.HTTP.Types.Status as HTTP
 import qualified Data.Text as T
 
-backendErrorTypeToErrStatus :: BackendErrorType -> HTTP.Status
-backendErrorTypeToErrStatus = \case
-  BE_node_error_root_not_found   -> HTTP.status404
-  BE_node_error_corpus_not_found -> HTTP.status404
-  BE_tree_error_root_not_found   -> HTTP.status404
+$(deriveHttpStatusCode ''BackendErrorCode)
 
 -- | Transforms a backend internal error into something that the frontend
 -- can consume. This is the only representation we offer to the outside world,
@@ -90,15 +88,15 @@ frontendErrorToServerError :: FrontendError -> ServerError
 frontendErrorToServerError fe@(FrontendError diag ty _) =
   ServerError { errHTTPCode     = HTTP.statusCode $ backendErrorTypeToErrStatus ty
               , errReasonPhrase = T.unpack diag
-              , errBody = JSON.encode fe
-              , errHeaders = mempty
+              , errBody         = JSON.encode fe
+              , errHeaders      = mempty
               }
 
 showAsServantJSONErr :: BackendInternalError -> ServerError
-showAsServantJSONErr (InternalNodeError err@(NoListFound {})) = err404 { errBody = JSON.encode err }
-showAsServantJSONErr (InternalNodeError err@NoRootFound{}) = err404 { errBody = JSON.encode err }
-showAsServantJSONErr (InternalNodeError err@NoCorpusFound) = err404 { errBody = JSON.encode err }
-showAsServantJSONErr (InternalNodeError err@NoUserFound{}) = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@(NoListFound {}))  = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoRootFound{})     = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoCorpusFound)     = err404 { errBody = JSON.encode err }
+showAsServantJSONErr (InternalNodeError err@NoUserFound{})     = err404 { errBody = JSON.encode err }
 showAsServantJSONErr (InternalNodeError err@(DoesNotExist {})) = err404 { errBody = JSON.encode err }
-showAsServantJSONErr (InternalServerError err) = err
-showAsServantJSONErr a = err500 { errBody = JSON.encode a }
+showAsServantJSONErr (InternalServerError err)                 = err
+showAsServantJSONErr a                                         = err500 { errBody = JSON.encode a }

src/Gargantext/API/Errors/TH.hs

+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Gargantext.API.Errors.TH (
+  deriveHttpStatusCode
+  ) where
+
+import           Prelude
+
+import           Network.HTTP.Types
+import qualified Data.Map.Strict                as Map
+import qualified Data.Text                      as T
+import qualified Language.Haskell.TH            as TH
+import Gargantext.API.Errors.Types
+import qualified Network.HTTP.Types as HTTP
+
+-- | A static map of the HTTP status code we support.
+supported_http_status_map :: Map.Map T.Text (TH.Q TH.Exp)
+supported_http_status_map = Map.fromList
+  [ ("200", TH.varE 'status200)
+  , ("400", TH.varE 'status400)
+  , ("403", TH.varE 'status403)
+  , ("404", TH.varE 'status404)
+  , ("500", TH.varE 'status500)
+  ]
+
+
+deriveHttpStatusCode :: TH.Name -> TH.Q [TH.Dec]
+deriveHttpStatusCode appliedType = do
+  info <- TH.reify appliedType
+  case info of
+    TH.TyConI (TH.DataD _ _ _ _ ctors _)
+      -> case extract_names ctors of
+           Left ctor   -> error $ "Only enum-like constructors supported: " ++ show ctor
+           Right names -> case parse_error_codes names of
+             Left n -> error $ "Couldn't extract error code from : " ++ TH.nameBase n
+                             ++ ". Make sure it's in the form XX_<validHttpStatusCode>__<textual_diagnostic>"
+             Right codes -> do
+               let static_matches = flip map codes $ \(n, stE, _txt) ->
+                     TH.match (TH.conP n [])
+                              (TH.normalB [| $(stE) |])
+                              []
+
+               [d| backendErrorTypeToErrStatus :: BackendErrorCode -> HTTP.Status
+                   backendErrorTypeToErrStatus = $(TH.lamCaseE static_matches) |]
+    err
+      -> error $ "Cannot call deriveHttpStatusCode on: " ++ show err
+
+extract_names :: [TH.Con] -> Either TH.Con [TH.Name]
+extract_names = mapM go
+  where
+    go :: TH.Con -> Either TH.Con TH.Name
+    go = \case
+      (TH.NormalC n []) -> Right n
+      e                 -> Left e
+
+parse_error_codes :: [TH.Name]
+                  -> Either TH.Name [(TH.Name, TH.Q TH.Exp, T.Text)]
+parse_error_codes = mapM go
+  where
+
+    do_parse = \n_txt ->
+      let sts_tl = T.drop 3 n_txt
+          code   = T.take 3 sts_tl
+          msg    = T.drop 5 sts_tl
+      in (code, msg)
+
+    go :: TH.Name -> Either TH.Name (TH.Name, TH.Q TH.Exp, T.Text)
+    go n = case Map.lookup code supported_http_status_map of
+             Nothing -> Left n
+             Just st -> Right (n, st, msg)
+      where
+        (code, msg) = do_parse $ (T.pack $ TH.nameBase n)

src/Gargantext/API/Errors/Types.hs

@@ -17,7 +17,7 @@ module Gargantext.API.Errors.Types (
   FrontendError(..)
 
   -- * The internal backend type and an enumeration of all possible backend error types
-  , BackendErrorType(..)
+  , BackendErrorCode(..)
   , BackendInternalError(..)
   , ToFrontendErrorData(..)
 
@@ -117,23 +117,23 @@ instance HasJoseError BackendInternalError where
   _JoseError = _InternalJoseError
 
 -- | A (hopefully and eventually) exhaustive list of backend errors.
-data BackendErrorType
+data BackendErrorCode
   =
   -- node errors
-    BE_node_error_root_not_found
-  | BE_node_error_corpus_not_found
+    EC_404__node_error_root_not_found
+  | EC_404__node_error_corpus_not_found
   -- tree errors
-  | BE_tree_error_root_not_found
+  | EC_404__tree_error_root_not_found
   deriving (Show, Read, Eq, Enum, Bounded)
 
-$(genSingletons [''BackendErrorType])
+$(genSingletons [''BackendErrorCode])
 
 -- | 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_type       :: !BackendErrorCode
     , fe_data       :: ToFrontendErrorData b
     } -> FrontendError
 
@@ -156,30 +156,30 @@ class ( SingI payload
       ) => IsFrontendErrorData payload where
   isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload
 
-instance IsFrontendErrorData 'BE_node_error_root_not_found where
+instance IsFrontendErrorData 'EC_404__node_error_root_not_found where
   isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'BE_node_error_corpus_not_found where
+instance IsFrontendErrorData 'EC_404__node_error_corpus_not_found where
   isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'BE_tree_error_root_not_found where
+instance IsFrontendErrorData 'EC_404__tree_error_root_not_found where
   isFrontendErrorData _ = Dict
 
 ----------------------------------------------------------------------------
--- This data family maps a 'BackendErrorType' into a concrete payload.
+-- This data family maps a 'BackendErrorCode' into a concrete payload.
 ----------------------------------------------------------------------------
 
 data NoFrontendErrorData = NoFrontendErrorData
 
-data family ToFrontendErrorData (payload :: BackendErrorType) :: Type
+data family ToFrontendErrorData (payload :: BackendErrorCode) :: Type
 
-data instance ToFrontendErrorData 'BE_node_error_root_not_found =
+data instance ToFrontendErrorData 'EC_404__node_error_root_not_found =
   FE_node_error_root_not_found
   deriving (Show, Eq, Generic)
 
-data instance ToFrontendErrorData 'BE_node_error_corpus_not_found =
+data instance ToFrontendErrorData 'EC_404__node_error_corpus_not_found =
   FE_node_error_corpus_not_found
   deriving (Show, Eq, Generic)
 
-data instance ToFrontendErrorData 'BE_tree_error_root_not_found =
+data instance ToFrontendErrorData 'EC_404__tree_error_root_not_found =
   RootNotFound { _rnf_rootId :: RootId }
   deriving (Show, Eq, Generic)
 
@@ -187,22 +187,22 @@ data instance ToFrontendErrorData 'BE_tree_error_root_not_found =
 -- JSON instances. It's important to have nice and human readable instances.
 ----------------------------------------------------------------------------
 
-instance ToJSON (ToFrontendErrorData 'BE_node_error_root_not_found) where
+instance ToJSON (ToFrontendErrorData 'EC_404__node_error_root_not_found) where
   toJSON _ = JSON.Null
 
-instance FromJSON (ToFrontendErrorData 'BE_node_error_root_not_found) where
+instance FromJSON (ToFrontendErrorData 'EC_404__node_error_root_not_found) where
   parseJSON _ = pure FE_node_error_root_not_found
 
-instance ToJSON (ToFrontendErrorData 'BE_node_error_corpus_not_found) where
+instance ToJSON (ToFrontendErrorData 'EC_404__node_error_corpus_not_found) where
   toJSON _ = JSON.Null
 
-instance FromJSON (ToFrontendErrorData 'BE_node_error_corpus_not_found) where
+instance FromJSON (ToFrontendErrorData 'EC_404__node_error_corpus_not_found) where
   parseJSON _ = pure FE_node_error_corpus_not_found
 
-instance ToJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
+instance ToJSON (ToFrontendErrorData 'EC_404__tree_error_root_not_found) where
   toJSON RootNotFound{..} = object [ "root_id" .= toJSON _rnf_rootId ]
 
-instance FromJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
+instance FromJSON (ToFrontendErrorData 'EC_404__tree_error_root_not_found) where
   parseJSON = withObject "RootNotFound" $ \o -> do
     _rnf_rootId <- o .: "root_id"
     pure RootNotFound{..}
@@ -214,11 +214,11 @@ mkFrontendErr et = mkFrontendErr' mempty et
 
 mkFrontendErr' :: forall payload. IsFrontendErrorData payload
                => T.Text
-               -> ToFrontendErrorData (payload :: BackendErrorType)
+               -> ToFrontendErrorData (payload :: BackendErrorCode)
                -> FrontendError
 mkFrontendErr' diag pl = FrontendError diag (fromSing $ sing @payload) pl
 
-instance Arbitrary BackendErrorType where
+instance Arbitrary BackendErrorCode where
   arbitrary = arbitraryBoundedEnum
 
 instance Arbitrary FrontendError where
@@ -227,24 +227,24 @@ instance Arbitrary FrontendError where
     txt <- arbitrary
     genFrontendErr txt et
 
-genFrontendErr :: T.Text -> BackendErrorType -> Gen FrontendError
+genFrontendErr :: T.Text -> BackendErrorCode -> Gen FrontendError
 genFrontendErr txt be = case be of
-  BE_node_error_root_not_found
+  EC_404__node_error_root_not_found
     -> pure $ mkFrontendErr' txt FE_node_error_root_not_found
-  BE_node_error_corpus_not_found
+  EC_404__node_error_corpus_not_found
     -> pure $ mkFrontendErr' txt FE_node_error_corpus_not_found
-  BE_tree_error_root_not_found
+  EC_404__tree_error_root_not_found
     -> do rootId <- arbitrary
           pure $ mkFrontendErr' txt (RootNotFound rootId)
 
-instance ToJSON BackendErrorType where
+instance ToJSON BackendErrorCode where
   toJSON = JSON.String . T.pack . drop 3 . show
 
-instance FromJSON BackendErrorType where
-  parseJSON (String s) = case readMaybe (T.unpack $ "BE_" <> s) of
+instance FromJSON BackendErrorCode where
+  parseJSON (String s) = case readMaybe (T.unpack $ "EC_" <> s) of
     Just v     -> pure v
-    Nothing    -> fail $ "FromJSON BackendErrorType unexpected value: " <> T.unpack s
-  parseJSON ty = typeMismatch "BackendErrorType" ty
+    Nothing    -> fail $ "FromJSON BackendErrorCode unexpected value: " <> T.unpack s
+  parseJSON ty = typeMismatch "BackendErrorCode" ty
 
 instance ToJSON FrontendError where
   toJSON (FrontendError diag ty dt) =
@@ -256,14 +256,14 @@ instance ToJSON FrontendError where
 instance FromJSON FrontendError where
   parseJSON = withObject "FrontendError" $ \o -> do
     (fe_diagnostic :: T.Text)      <- o .: "diagnostic"
-    (fe_type :: BackendErrorType)  <- o .: "type"
+    (fe_type :: BackendErrorCode)  <- o .: "type"
     case fe_type of
-      BE_node_error_root_not_found         -> do
-        (fe_data :: ToFrontendErrorData 'BE_node_error_root_not_found) <- o .: "data"
+      EC_404__node_error_root_not_found         -> do
+        (fe_data :: ToFrontendErrorData 'EC_404__node_error_root_not_found) <- o .: "data"
         pure FrontendError{..}
-      BE_node_error_corpus_not_found       -> do
-        (fe_data :: ToFrontendErrorData 'BE_node_error_corpus_not_found) <- o .: "data"
+      EC_404__node_error_corpus_not_found       -> do
+        (fe_data :: ToFrontendErrorData 'EC_404__node_error_corpus_not_found) <- o .: "data"
         pure FrontendError{..}
-      BE_tree_error_root_not_found -> do
-        (fe_data :: ToFrontendErrorData 'BE_tree_error_root_not_found) <- o .: "data"
+      EC_404__tree_error_root_not_found -> do
+        (fe_data :: ToFrontendErrorData 'EC_404__tree_error_root_not_found) <- o .: "data"
         pure FrontendError{..}

test/Test/Offline/JSON.hs

@@ -29,7 +29,7 @@ jsonRoundtrip a =
   counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
 
 class (Show a, FromJSON a, ToJSON a, Eq a, Enum a, Bounded a) => EnumBoundedJSON a
-instance EnumBoundedJSON BackendErrorType
+instance EnumBoundedJSON BackendErrorCode
 
 jsonEnumRoundtrip :: forall a. Dict EnumBoundedJSON a -> Property
 jsonEnumRoundtrip d = case d of
@@ -45,7 +45,7 @@ tests = testGroup "JSON" [
   , testProperty "Datafield roundtrips"     (jsonRoundtrip @Datafield)
   , testProperty "WithQuery roundtrips"     (jsonRoundtrip @WithQuery)
   , testProperty "FrontendError roundtrips" (jsonRoundtrip @FrontendError)
-  , testProperty "BackendErrorType roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorType))
+  , testProperty "BackendErrorCode roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorCode))
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
   , testGroup "Phylo" [
     testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)