Blockfrost Proxy

BlockfrostProxy.hs

{-# LANGUAGE OverloadedStrings #-}
{-| Blockfrost proxy that injects the auth header with the API key
into all requests
-}
module Wst.Server.BlockfrostProxy(
  BlockfrostProxy,
  runBlockfrostProxy
) where

import Control.Exception (bracket_)
import Data.ByteString.Char8 qualified as B8
import Data.CaseInsensitive qualified as CI
import Data.Text (Text)
import Data.Text qualified as Text
import Network.HTTP.Client (Manager, Request (..), httpLbs, parseRequest,
                            responseBody, responseHeaders, responseStatus)
import Network.Wai (Response)
import qualified  Network.HTTP.Types.Version as H
import Network.Wai qualified as Wai
import Servant.API (Raw, (:>))
import qualified Data.ByteString.Lazy as BSL
import Servant.Server (ServerT)
import Data.Foldable (traverse_)

{-| Blockfrost proxy route
-}
type BlockfrostProxy = "blockfrost-proxy" :> Raw

type Header = (CI.CI B8.ByteString, B8.ByteString)

-- TODO: This always connects to the preview network, we should
-- make this configurable. (Needs to be accompanied by a change
-- in the frontend)
targetUrl :: B8.ByteString
targetUrl = "https://cardano-preview.blockfrost.io/"

runBlockfrostProxy :: Manager -> Text -> ServerT Raw m
runBlockfrostProxy manager t = do
  let header :: Header
      header = ("Project_id", B8.pack $ Text.unpack t)

  pure $ \req respond ->
    bracket_
      (pure ())
      (pure ())
      (handler manager header req respond)

handler :: Manager -> Header -> Wai.Request -> (Response -> IO w) -> IO w
handler manager hd request respond = do
  initialRequest <- parseRequest $ B8.unpack targetUrl

  -- We need to remove the first element of the path.
  -- everything after that can be forwarded to blockfrost as-is.
  let path_ = B8.drop (length @[] "/blockfrost-proxy") (Wai.rawPathInfo request) <> Wai.rawQueryString request

      -- remove existing project_id headers (if any)
      isBfHeader ("project_id", _) = True
      isBfHeader _ = False
      newRequest = initialRequest
        { method = Wai.requestMethod request
        , path = path_
        , requestHeaders = [hd]
        , requestBody = requestBody initialRequest
        , secure = True
        }

  response <- httpLbs newRequest manager
  putStrLn $ "Response headers: "
  traverse_ print (responseHeaders response)
  respond $ Wai.responseLBS
    (responseStatus response)
    -- (("content-length", B8.pack $ show $ BSL.length $ responseBody response) : responseHeaders response)
    (responseHeaders response)
    (responseBody response)