Merge pull request #2 from notunrandom/fixbuild

Fix build error and warnings

Author: abailly

.gitignore

@@ -25,6 +25,14 @@ dist/
 **/tags
 **/TAGS
 
+# Shake
+
+report.html
+bin
+blst
+libsodium
+secp256k1
+
 # nix
 result
 result-[0-9]*

db-server.cabal

@@ -61,7 +61,6 @@ library
     aeson,
     base >=4.14 && <4.21,
     base16-bytestring >=1.0,
-    base64-bytestring,
     bytestring >=0.10 && <0.13,
     cardano-crypto-class,
     cardano-ledger-api,
@@ -90,7 +89,6 @@ executable db-server
     base,
     contra-tracer,
     cardano-crypto-class,
-    network,
     optparse-applicative,
     db-server,
     with-utf8,

src/Cardano/Tools/DB.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -51,6 +53,7 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Word (Word64)
+import GHC.Generics (Generic)
 import Ouroboros.Consensus.Block (ChainHash (..), ConvertRawHash (fromRawHash), Proxy (..), headerPrevHash, toRawHash)
 import Ouroboros.Consensus.Block.Abstract (HeaderHash)
 import Ouroboros.Consensus.Block.RealPoint
@@ -160,7 +163,8 @@ data DBError
   | MalformedQuery Text
   | InitialHeader
   | UnknownStateType
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
 
 toBytestring :: (IsString s) => DBError -> s
 toBytestring = fromString . show

src/Cardano/Tools/DBQuery.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
 
 module Cardano.Tools.DBQuery
   ( DBQueryLog (..),
@@ -40,7 +39,7 @@ import qualified Data.Text as Text
 import GHC.Generics (Generic)
 import Ouroboros.Consensus.Storage.ChainDB (TraceEvent)
 
-data DBQueryLog = DBLog (TraceEvent StandardBlock)
+newtype DBQueryLog = DBLog (TraceEvent StandardBlock)
   deriving stock (Eq, Show, Generic)
 
 instance ToJSON DBQueryLog where
@@ -76,7 +75,7 @@ runQuery tracer configurationFile databaseDirectory query =
 runDBQuery :: DB -> Text -> IO (Result LBS.ByteString)
 runDBQuery db query = do
   case parseQuery query of
-    Left err -> pure $ Err (MalformedQuery query)
+    Left _ -> pure $ Err (MalformedQuery query)
     Right q ->
       case q of
         GetBlock point -> getBlock db point

src/Cardano/Tools/DBServer.hs

@@ -61,7 +61,7 @@ run tracer (fromIntegral -> port) host configurationFile databaseDirectory = do
         & Warp.setServerName "db-server"
         & Warp.setTimeout 120
         & Warp.setMaximumBodyFlush Nothing
-        & Warp.setBeforeMainLoop (traceWith tr HttpServerListening {host, port})
+        & Warp.setBeforeMainLoop (traceWith tr (HttpListenLog (ListenEvent {host, port})))
 
 webApp :: ChainDB IO StandardBlock -> Application
 webApp db req send =
@@ -74,8 +74,8 @@ webApp db req send =
     _ -> send responseNotFound
   where
     responseNotFound = responseLBS status404 [] ""
-    responseBadRequest msg = responseLBS status400 [] msg
-    responseOk content = responseLBS status200 [("content-type", "application/json")] content
+    responseBadRequest = responseLBS status400 []
+    responseOk = responseLBS status200 [("content-type", "application/json")]
 
     handleGetSnapshots =
       listSnapshots db >>= \snapshotsPoints ->
@@ -90,7 +90,7 @@ webApp db req send =
             Err err -> send $ responseBadRequest ("Bad query: " <> toBytestring err)
             Found result -> send $ responseOk (LHex.encode result)
 
-    handleGetHeader slot hash = handleWithPoint getHeader slot hash
+    handleGetHeader = handleWithPoint getHeader
 
     handleGetSnapshot slot =
       case makeSlot slot of
@@ -101,9 +101,9 @@ webApp db req send =
             Err err -> send $ responseBadRequest ("Bad query: " <> toBytestring err)
             Found snapshot -> send $ responseOk (LHex.encode snapshot)
 
-    handleGetParent slot hash = handleWithPoint getParent slot hash
+    handleGetParent = handleWithPoint getParent
 
-    handleGetBlock slot hash = handleWithPoint getBlock slot hash
+    handleGetBlock = handleWithPoint getBlock
 
 -- * Tracing
 
@@ -131,12 +131,12 @@ withLog hdl k = do
 tracerMiddleware :: Tracer IO HttpServerLog -> Middleware
 tracerMiddleware tr runApp req send = do
   start <- GHC.Clock.getMonotonicTimeNSec
-  traceWith tr HttpRequest {path, method}
+  traceWith tr (HttpRequestLog (RequestEvent {path, method}))
   runApp req $ \res -> do
     result <- send res
     end <- GHC.Clock.getMonotonicTimeNSec
     let time = mkRequestTime start end
-    traceWith tr HttpResponse {status = mkStatus (responseStatus res), time}
+    traceWith tr (HttpResponseLog (ResponseEvent {status = mkStatus (responseStatus res), time}))
     pure result
   where
     method = decodeUtf8 (requestMethod req)
@@ -161,9 +161,20 @@ data HttpStatus = HttpStatus {code :: Int, message :: Text}
   deriving stock (Eq, Generic, Show)
   deriving anyclass (ToJSON, FromJSON)
 
-data HttpServerLog
-  = HttpServerListening {host :: String, port :: Int}
-  | HttpRequest {path :: [Text], method :: Text}
-  | HttpResponse {status :: HttpStatus, time :: RequestTime}
+data HttpServerLog =
+  HttpListenLog ListenEvent
+  | HttpRequestLog RequestEvent
+  | HttpResponseLog ResponseEvent
   deriving stock (Eq, Show, Generic)
   deriving anyclass (ToJSON, FromJSON)
+
+data ListenEvent = ListenEvent {host :: String, port :: Int}
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+data RequestEvent = RequestEvent {path :: [Text], method :: Text}
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+data ResponseEvent = ResponseEvent {status :: HttpStatus, time :: RequestTime}
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+