fix: apply code review suggestions

Author: abailly

.gitignore

@@ -99,3 +99,4 @@ cabal.project.local~
 .HTF/
 .ghc.environment.*
 /_build/
+.aider*

src/Cardano/Tools/DBQuery.hs

@@ -50,7 +50,12 @@ instance ToJSON DBQueryLog where
 data Error
   = ParseError Text
   | QueryError Text
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Error where
+  toJSON = \case
+    ParseError msg -> object ["tag" .= ("ParseError" :: Text), "message" .= msg]
+    QueryError msg -> object ["tag" .= ("QueryError" :: Text), "message" .= msg]
 
 data Query
   = GetBlock StandardPoint
@@ -65,13 +70,13 @@ runQuery :: Tracer IO DBQueryLog -> FilePath -> FilePath -> Text -> IO ()
 runQuery tracer configurationFile databaseDirectory query =
   withDB configurationFile databaseDirectory (contramap DBLog tracer) $ \db ->
     runDBQuery db query >>= \case
-      Err err -> print err
+      Err err -> LBS.putStr $ Aeson.encode err
       Found result -> LBS.putStr result
 
 runDBQuery :: DB -> Text -> IO (Result LBS.ByteString)
 runDBQuery db query = do
   case parseQuery query of
-    Left _err -> pure $ Err (MalformedQuery query)
+    Left err -> pure $ Err (MalformedQuery query)
     Right q ->
       case q of
         GetBlock point -> getBlock db point
@@ -96,4 +101,4 @@ parseQuery str =
     withPoint q point =
       maybe (Left $ ParseError $ "error parsing point: " <> point) (Right . q) $ parsePoint point
     withSlot q slot =
-      maybe (Left $ ParseError $ "error parsing point: " <> slot) (Right . q) $ makeSlot slot
+      maybe (Left $ ParseError $ "error parsing slot: " <> slot) (Right . q) $ makeSlot slot

src/Cardano/Tools/DBServer.hs

@@ -74,58 +74,36 @@ webApp db req send =
     _ -> send responseNotFound
   where
     responseNotFound = responseLBS status404 [] ""
+    responseBadRequest msg = responseLBS status400 [] msg
+    responseOk content = responseLBS status200 [("content-type", "application/json")] content
 
     handleGetSnapshots =
       listSnapshots db >>= \snapshotsPoints ->
-        send $
-          responseLBS
-            status200
-            [("content-type", "application/json")]
-            (encode snapshotsPoints)
+        send $ responseOk (encode snapshotsPoints)
 
-    handleGetHeader slot hash =
+    handleWithPoint action slot hash =
       case makePoint slot hash of
-        Nothing ->
-          send $ responseLBS status400 [] "Malformed hash or slot"
+        Nothing -> send $ responseBadRequest "Malformed hash or slot"
         Just point ->
-          getHeader db point >>= \case
+          action db point >>= \case
             Err NotFound -> send responseNotFound
-            Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
-            Found header -> send $ responseLBS status200 [("content-type", "application/text")] (LHex.encode header)
+            Err err -> send $ responseBadRequest ("Bad query: " <> toBytestring err)
+            Found result -> send $ responseOk (LHex.encode result)
+
+    handleGetHeader slot hash = handleWithPoint getHeader slot hash
 
     handleGetSnapshot slot =
       case makeSlot slot of
-        Nothing -> send $ responseLBS status400 [] "Malformed slot"
+        Nothing -> send $ responseBadRequest "Malformed slot"
         Just slot' ->
           getSnapshot db slot' >>= \case
             Err NotFound -> send responseNotFound
-            Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
-            Found snapshot ->
-              send $
-                responseLBS
-                  status200
-                  [("content-type", "application/json")]
-                  (LHex.encode snapshot)
-
-    handleGetParent slot hash =
-      case makePoint slot hash of
-        Nothing ->
-          send $ responseLBS status400 [] "Malformed hash or slot"
-        Just point ->
-          getParent db point >>= \case
-            Err NotFound -> send responseNotFound
-            Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
-            Found parent -> send $ responseLBS status200 [("content-type", "application/json")] (LHex.encode parent)
+            Err err -> send $ responseBadRequest ("Bad query: " <> toBytestring err)
+            Found snapshot -> send $ responseOk (LHex.encode snapshot)
 
-    handleGetBlock slot hash = do
-      case makePoint slot hash of
-        Nothing ->
-          send $ responseLBS status400 [] "Malformed hash or slot"
-        Just point ->
-          getBlock db point >>= \case
-            Err NotFound -> send responseNotFound
-            Err err -> send $ responseLBS status400 [] ("Bad query: " <> toBytestring err)
-            Found parent -> send $ responseLBS status200 [("content-type", "application/json")] (LHex.encode parent)
+    handleGetParent slot hash = handleWithPoint getParent slot hash
+
+    handleGetBlock slot hash = handleWithPoint getBlock slot hash
 
 -- * Tracing