patch 0.24.1.1

CHANGELOG.md

@@ -1 +1,3 @@
-#
+
+# 0.24.1.1  2024-04-02
+  - Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly

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

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

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

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

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
-
+        getTreeHash sto what
-        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
 
       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'
+
+

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

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

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

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