Draft http server for explorer

cardano-scaling · Jan 11, 2024 · 3815053 · 3815053
1 parent a90d289
commit 3815053
Show file tree

Hide file tree

Showing 3 changed files with 92 additions and 2 deletions.
diff --git a/hydra-cluster/test/Test/HydraExplorerSpec.hs b/hydra-cluster/test/Test/HydraExplorerSpec.hs
@@ -98,7 +98,7 @@ spec = do
                 headExplorerSees explorer "HeadInitTx" headId
 
                 manager <- HTTPClient.newTlsManager
-                let url = "https://127.0.0.1:9000/heads?page=0"
+                let url = "http://127.0.0.1:9090/heads?page=1"
                 request <-
                   HTTPClient.parseRequest url <&> \request ->
                     request
@@ -107,6 +107,7 @@ spec = do
                       }
                 response <- HTTPClient.httpLbs request manager
                 HTTPClient.responseStatus response `shouldBe` status200
+                print (HTTPClient.responseBody response)
                 let maybeOpenHeads = decode $ HTTPClient.responseBody response :: Maybe [HeadId]
                 maybeOpenHeads `shouldBe` Just [UnsafeHeadId $ encodeUtf8 headId]
 

diff --git a/hydra-explorer/hydra-explorer.cabal b/hydra-explorer/hydra-explorer.cabal
@@ -43,10 +43,17 @@ library
   hs-source-dirs:  src
   ghc-options:     -haddock
   build-depends:
+    , aeson
+    , base
+    , bytestring
+    , containers
+    , http-types
     , hydra-chain-observer
     , hydra-node
     , hydra-prelude
     , optparse-applicative
+    , wai
+    , warp
 
   exposed-modules: Hydra.Explorer
 

diff --git a/hydra-explorer/src/Hydra/Explorer.hs b/hydra-explorer/src/Hydra/Explorer.hs
@@ -3,5 +3,87 @@ module Hydra.Explorer where
 import Hydra.ChainObserver qualified
 import Hydra.Prelude
 
+import Data.ByteString.Char8 (unpack)
+import Data.List qualified as List
+import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..))
+import Hydra.Logging (Tracer, Verbosity (..), traceWith, withTracer)
+import Hydra.Network (PortNumber)
+import Network.HTTP.Types (parseQuery, status200)
+import Network.HTTP.Types.Header (HeaderName)
+import Network.HTTP.Types.Status (status404, status500)
+import Network.Wai (
+  Application,
+  Response,
+  pathInfo,
+  rawPathInfo,
+  rawQueryString,
+  requestMethod,
+  responseFile,
+  responseLBS,
+ )
+import Network.Wai.Handler.Warp qualified as Warp
+import Prelude (read)
+
 main :: IO ()
-main = Hydra.ChainObserver.main
+main = do
+  withTracer (Verbose "hydra-explorer") $ \tracer -> do
+    race
+      Hydra.ChainObserver.main
+      ( traceWith tracer (APIServerStarted (fromIntegral port :: PortNumber))
+          *> Warp.runSettings (settings tracer) (httpApp tracer)
+      )
+      >>= \case
+        Left{} -> error "Something went wrong"
+        Right a -> pure a
+ where
+  port = 9090
+
+  settings tracer =
+    Warp.defaultSettings
+      & Warp.setPort port
+      & Warp.setHost "0.0.0.0"
+      & Warp.setOnException (\_ e -> traceWith tracer $ APIConnectionError{reason = show e})
+      & Warp.setBeforeMainLoop
+        ( do
+            putStrLn "Server started..."
+            putStrLn $ "Listening on: tcp/" <> show port
+        )
+
+httpApp :: Tracer IO APIServerLog -> Application
+httpApp tracer req send = do
+  traceWith tracer $
+    APIHTTPRequestReceived
+      { method = Method $ requestMethod req
+      , path = PathInfo $ rawPathInfo req
+      }
+  case (requestMethod req, pathInfo req) of
+    ("HEAD", _) -> send $ responseLBS status200 corsHeaders ""
+    ("GET", []) -> send $ handleFile "index.html"
+    ("GET", ["heads"]) -> do
+      let queryParams = parseQuery $ rawQueryString req
+          pageParam = join $ List.lookup "page" queryParams
+          page :: Int = maybe 0 (read . unpack) pageParam
+      send $
+        responseLBS status200 corsHeaders $
+          "OK. Handling /heads route with pagination. Page: " <> show page
+    -- FIXME: do proper file serving, this is dangerous
+    ("GET", path) -> send $ handleFile $ toString $ mconcat $ List.intersperse "/" ("." : path)
+    (_, _) -> send handleNotFound
+
+handleError :: Response
+handleError =
+  responseLBS status500 corsHeaders "INVALID REQUEST"
+
+handleNotFound :: Response
+handleNotFound =
+  responseLBS status404 corsHeaders "NOT FOUND"
+
+handleFile :: FilePath -> Response
+handleFile filepath = responseFile status200 corsHeaders filepath Nothing
+
+corsHeaders :: [(HeaderName, ByteString)]
+corsHeaders =
+  [ ("Access-Control-Allow-Origin", "*")
+  , ("Access-Control-Allow-Methods", "*")
+  , ("Access-Control-Allow-Headers", "*")
+  ]