From d2082de4bf54b54095eecd121727d89e936089ed Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 2 Apr 2024 06:39:50 +0300 Subject: [PATCH] patch 0.24.1.1 --- CHANGELOG.md | 4 +- hbs2-core/hbs2-core.cabal | 2 +- hbs2-fixer/hbs2-fixer.cabal | 2 +- hbs2-git/hbs2-git.cabal | 2 +- hbs2-keyman/hbs2-keyman.cabal | 2 +- hbs2-peer/app/HttpWorker.hs | 94 ++++++++++--------- hbs2-peer/hbs2-peer.cabal | 2 +- hbs2-share/hbs2-share.cabal | 2 +- hbs2-storage-simple/hbs2-storage-simple.cabal | 2 +- hbs2/hbs2.cabal | 2 +- 10 files changed, 60 insertions(+), 54 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 792d6005..88d20478 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1 +1,3 @@ -# + +# 0.24.1.1 2024-04-02 + - Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 5088ae5b..a6edb9b8 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-core -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-fixer/hbs2-fixer.cabal b/hbs2-fixer/hbs2-fixer.cabal index bba3210d..ad1222e9 100644 --- a/hbs2-fixer/hbs2-fixer.cabal +++ b/hbs2-fixer/hbs2-fixer.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-fixer -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 18a1443f..0623dd7b 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-git -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal index c2e87fc8..68c14b00 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/hbs2-keyman/hbs2-keyman.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-keyman -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 0cef0224..eb5ce9f7 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -106,54 +106,12 @@ httpWorker (PeerConfig syn) pmeta e = do >>= orElse (status status404) <&> lwwValue . snd - lift $ redirect [qc|/tree/{pretty rv}|] + lift $ getTreeHash sto rv + -- TODO: define-parsable-instance-for-our-types get "/tree/:hash" do what <- param @String "hash" <&> fromString - - void $ flip runContT pure do - - callCC $ \exit -> do - - blob <- liftIO (getBlock sto what) - >>= orElse (status status404) - - mh <- orElse (status status404) (extractMetadataHash what blob) - - meta <- lift (getBlock sto mh) >>= orElse (status status404) - <&> LBS8.unpack - <&> fromRight mempty . parseTop - - let tp = headDef "application/octet-stream" - [ show (pretty w) - | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta - ] - - let fn = headMay - [ show (pretty w) - | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta - ] - - -- liftIO $ print $ pretty meta - - case fn of - Just x | takeExtension x == ".html" -> pure () - | otherwise -> lift $ do - addHeader "content-disposition" [qc|attachment; filename="{x}"|] - - _ -> pure () - - lift $ addHeader "content-type" (fromString tp) - - elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what) - - case elbs of - Left{} -> lift $ status status404 - Right lbs -> lift do - stream $ \write flush -> do - for_ (LBS.toChunks lbs) $ \chunk -> do - write $ byteString chunk - flush + getTreeHash sto what get "/cat/:hash" do what <- param @String "hash" <&> fromString @@ -213,3 +171,49 @@ httpWorker (PeerConfig syn) pmeta e = do warn "http port not set" forever $ pause @'Seconds 600 + +getTreeHash :: AnyStorage -> HashRef -> ActionM () +getTreeHash sto what' = void $ flip runContT pure do + blob <- liftIO (getBlock sto what) + >>= orElse (status status404) + + mh <- orElse (status status404) (extractMetadataHash what blob) + + meta <- lift (getBlock sto mh) >>= orElse (status status404) + <&> LBS8.unpack + <&> fromRight mempty . parseTop + + let tp = headDef "application/octet-stream" + [ show (pretty w) + | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta + ] + + let fn = headMay + [ show (pretty w) + | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta + ] + + -- liftIO $ print $ pretty meta + + case fn of + Just x | takeExtension x == ".html" -> pure () + | otherwise -> lift $ do + addHeader "content-disposition" [qc|attachment; filename="{x}"|] + + _ -> pure () + + lift $ addHeader "content-type" (fromString tp) + + elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what) + + case elbs of + Left{} -> lift $ status status404 + Right lbs -> lift do + stream $ \write flush -> do + for_ (LBS.toChunks lbs) $ \chunk -> do + write $ byteString chunk + flush + where + what = fromHashRef what' + + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 6c51aa14..00ea789a 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-peer -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-share/hbs2-share.cabal b/hbs2-share/hbs2-share.cabal index f3ef2beb..db94afb1 100644 --- a/hbs2-share/hbs2-share.cabal +++ b/hbs2-share/hbs2-share.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-share -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 985a864c..9cc56f44 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2-storage-simple -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index bc6d5318..47d9f258 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hbs2 -version: 0.24.1.0 +version: 0.24.1.1 -- synopsis: -- description: license: BSD-3-Clause