Skip to content
Merged
Show file tree
Hide file tree
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
Add URL to the 404 result of serveFileWhile server
  • Loading branch information
palas committed Sep 19, 2024
commit 198dcbce37e5a3db3e66311d025a9d6b452ebf74
1 change: 1 addition & 0 deletions cardano-cli/cardano-cli.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -342,6 +342,7 @@ test-suite cardano-cli-test
text,
time,
transformers,
utf8-string,
wai,
warp,

Expand Down
21 changes: 18 additions & 3 deletions cardano-cli/test/cardano-cli-test/Test/Cli/Hash.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,13 +8,17 @@ import Control.Concurrent (forkOS)
import Control.Exception.Lifted (bracket)
import Control.Monad (void)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString.UTF8 as BSU8
import Data.List (intercalate)
import Data.Monoid (Last (..))
import Data.String (IsString (fromString))
import Data.Text (unpack)
import qualified Data.Text as T
import GHC.IO.Exception (ExitCode (..))
import Network.HTTP.Types.Status (status200, status404)
import Network.HTTP.Types.URI (renderQuery)
import Network.Socket (close)
import Network.Wai (Request, Response, ResponseReceived, pathInfo, responseFile,
import Network.Wai (Request (..), Response, ResponseReceived, pathInfo, responseFile,
responseLBS)
import Network.Wai.Handler.Warp (defaultSettings, openFreePort, runSettingsSocket)
import System.Directory (getCurrentDirectory)
Expand Down Expand Up @@ -122,7 +126,7 @@ hprop_check_anchor_data_hash_from_http_uri =
serveFileWhile
relativeUrl
exampleAnchorDataPath
( \port ->
( \port -> do
void $
execCardanoCLI
[ "hash"
Expand Down Expand Up @@ -198,7 +202,10 @@ serveFileWhile relativeUrl filePath action =
let path = T.unpack <$> pathInfo req
if path == relativeUrl
then respond $ responseFile status200 [("Content-Type", "text/plain")] filePath Nothing
else respond $ responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found"
else
respond $
responseLBS status404 [("Content-Type", "text/plain")] $
fromString ("404 - Url \"" ++ urlFromRequest req ++ "\" - Not Found")

-- Run server asynchronously in a separate thread
void $ H.evalIO $ forkOS $ runSettingsSocket defaultSettings socket app
Expand All @@ -208,3 +215,11 @@ serveFileWhile relativeUrl filePath action =
(\(_, socket) -> H.evalIO $ close socket)
-- Test action
(\(port, _) -> action port)
where
urlFromRequest :: Request -> String
urlFromRequest req =
"http://"
++ maybe "localhost" BSU8.toString (requestHeaderHost req)
++ "/"
++ intercalate "/" (unpack <$> pathInfo req)
++ BSU8.toString (renderQuery True (queryString req))