voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, webroot

This commit is contained in:
voidlizard 2025-02-02 13:31:27 +03:00
parent 5891271d93
commit 945e8ca18b
1 changed files with 43 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
hbs2-peer/app/HttpWorker.hs
View File

@ -14,6 +14,7 @@ import HBS2.Net.Auth.Schema
import HBS2.Data.Types.SignedBox import HBS2.Data.Types.SignedBox
import HBS2.Events import HBS2.Events
import HBS2.Storage.Operations.ByteString import HBS2.Storage.Operations.ByteString
import HBS2.Misc.PrettyStuff
import PeerTypes import PeerTypes
import PeerConfig import PeerConfig
@ -206,7 +207,11 @@ httpWorker (PeerConfig syn) pmeta = do
getTreeHash :: AnyStorage -> HashRef -> ActionM () getTreeHash :: AnyStorage -> HashRef -> ActionM ()
getTreeHash sto what' = void $ flip runContT pure do getTreeHash sto what'' = void $ flip runContT pure do
flip fix (what'', 0) $ \again (what',i) -> do
let what = fromHashRef what'
meta <- extractMetadataHash sto what' meta <- extractMetadataHash sto what'
>>= orElse (status status404) >>= orElse (status status404)
@ -221,6 +226,18 @@ getTreeHash sto what' = void $ flip runContT pure do
| ListVal [SymbolVal "file-name:", LitStrVal w] <- meta | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
] ]
let webroot = headMay [ w
| i < 2, ListVal [SymbolVal "webroot", HashLike w] <- meta
]
case webroot of
Just x | i < 2 -> again (x, succ i)
_ -> do
for_ webroot $ \w -> do
warn $ green "HTTP:WEBROOT" <+> pretty w
-- liftIO $ print $ pretty meta -- liftIO $ print $ pretty meta
case fn of case fn of
@ -241,7 +258,5 @@ getTreeHash sto what' = void $ flip runContT pure do
for_ (LBS.toChunks lbs) $ \chunk -> do for_ (LBS.toChunks lbs) $ \chunk -> do
write $ byteString chunk write $ byteString chunk
flush flush
where
what = fromHashRef what'