mirror of https://github.com/voidlizard/hbs2
patch 0.24.1.1
This commit is contained in:
Dmitry Zuikov
parent
10181d1e34
commit
d2082de4bf
|
|
@ -1 +1,3 @@
|
|||
#
|
||||
|
||||
# 0.24.1.1 2024-04-02
|
||||
- Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue