From 2628d7efa011fc541c7064480ee88d6383148b69 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Thu, 6 Feb 2025 10:39:12 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Data/Types/Refs.hs | 1 + hbs2-peer/app/HttpWorker.hs | 145 +++++++++++++++++++++----- 2 files changed, 118 insertions(+), 28 deletions(-) diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 4c725fa1..6e5d017d 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -87,6 +87,7 @@ instance Serialise (TaggedHashRef e) type IsRefPubKey s = ( Eq (PubKey 'Sign s) , Serialise (PubKey 'Sign s) , FromStringMaybe (PubKey 'Sign s) + , Serialise (PubKey 'Sign s) , Hashable (PubKey 'Sign s) , Pretty (AsBase58 (PubKey 'Sign s)) ) diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 5f723d90..0d5136d6 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -1,4 +1,6 @@ +{-# Language AllowAmbiguousTypes #-} {-# Language TypeOperators #-} +{-# Language ViewPatterns #-} module HttpWorker where import HBS2.Prelude @@ -11,6 +13,7 @@ import HBS2.Merkle import HBS2.Peer.Proto import HBS2.Peer.Proto.LWWRef import HBS2.Net.Auth.Schema +import HBS2.Net.Auth.Credentials import HBS2.Data.Types.SignedBox import HBS2.Events import HBS2.Storage.Operations.ByteString @@ -22,11 +25,14 @@ import RefLog ( doRefLogBroadCast ) import Data.Config.Suckless +import Data.Maybe import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger import Text.InterpolatedString.Perl6 (qc) + import Web.Scotty +import Web.Scotty.Trans (ActionT) import Data.ByteString.Builder (byteString, Builder) @@ -36,6 +42,7 @@ import Codec.Serialise (deserialiseOrFail) import Data.Aeson (object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Text qualified as Text +import Data.HashMap.Strict qualified as HM import Control.Monad.Reader import Lens.Micro.Platform (view) import System.FilePath @@ -77,11 +84,29 @@ extractMetadataHash sto what = runMaybeT do orElse :: m r -> Maybe a -> ContT r m a orElse a mb = ContT $ maybe1 mb a +lookupLWWRef :: forall e s m . (s ~ Encryption e, IsRefPubKey s, ForSignedBox s, s ~ HBS2Basic) + => AnyStorage + -> LWWRefKey s + -> ContT () ActionM HashRef + +lookupLWWRef sto what = + getRef sto what + >>= orElse (status status404) + >>= getBlock sto + >>= orElse (status status404) + <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s) + >>= orElse (status status404) + <&> unboxSignedBox0 @(LWWRef s) + >>= orElse (status status404) + <&> lwwValue . snd + + httpWorker :: forall e s m . ( MyPeer e , MonadIO m , HasStorage m , IsRefPubKey s , s ~ Encryption e + , s ~ HBS2Basic , m ~ PeerM e IO , e ~ L4Proto -- , ForLWWRefProto e @@ -100,11 +125,38 @@ httpWorker (PeerConfig syn) pmeta = do -- defaultHandler do -- status status500 + -- + -- + let handleRef ( p :: Maybe Text ) = \case + + Right ref -> do + + what <- fromStringMay ref + & orElse (status status404) + + lift $ getTreeHash @e sto p what + + Left ( ref :: String ) -> do + + what <- fromStringMay @(LWWRefKey s) ref + & orElse (status status404) + + rv <- getRef sto what + >>= orElse (status status404) + >>= getBlock sto + >>= orElse (status status404) + <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s) + >>= orElse (status status404) + <&> unboxSignedBox0 @(LWWRef s) + >>= orElse (status status404) + <&> lwwValue . snd + + lift $ getTreeHash @e sto p rv get "/size/:hash" do void $ flip runContT pure do - what <- lift (param @String "hash") + what <- lift (pathParam @String "hash") <&> fromStringMay >>= orElse (status status404) @@ -117,35 +169,31 @@ httpWorker (PeerConfig syn) pmeta = do -- TODO: key-to-disable-tree-streaming get "/ref/:key" do - void $ flip runContT pure do - what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey s)) - >>= orElse (status status404) + ref <- lift (pathParam @String "key") + handleRef Nothing (Left ref) - rv <- getRef sto what - >>= orElse (status status404) - >>= getBlock sto - >>= orElse (status status404) - <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s) - >>= orElse (status status404) - <&> unboxSignedBox0 @(LWWRef s) - >>= orElse (status status404) - <&> lwwValue . snd - - lift $ getTreeHash sto rv + get "/ref/:key/:part" do + void $ flip runContT pure do + ref <- lift (pathParam @String "key") + part <- lift (pathParam @Text "part") + handleRef (Just part) (Left ref) -- TODO: define-parsable-instance-for-our-types get "/tree/:hash" do void $ flip runContT pure do - what <- lift (param @String "hash") - <&> fromStringMay - >>= orElse (status status404) + ref <- lift (pathParam @String "hash") + handleRef Nothing (Right ref) - lift $ getTreeHash sto what + get "/tree/:hash/:part" do + void $ flip runContT pure do + ref <- lift (pathParam @String "hash") + part <- lift (pathParam @Text "part") + handleRef (Just part) (Right ref) get "/cat/:hash" do void $ flip runContT pure do - what <- lift (param @String "hash") + what <- lift (pathParam @String "hash") <&> fromStringMay >>= orElse (status status404) lift do @@ -158,7 +206,7 @@ httpWorker (PeerConfig syn) pmeta = do raw lbs get "/reflog/:ref" do - re <- param @String "ref" <&> fromStringMay + re <- pathParam @String "ref" <&> fromStringMay case re of Nothing -> status status404 Just ref -> do @@ -205,17 +253,36 @@ httpWorker (PeerConfig syn) pmeta = do warn "http port not set" forever $ pause @'Seconds 600 +-- pattern WebRef :: forall {s} . sEither (L -getTreeHash :: AnyStorage -> HashRef -> ActionM () -getTreeHash sto what'' = void $ flip runContT pure do +webRef :: forall c s . (IsContext c, s ~ HBS2Basic) => Syntax c -> Maybe (Text, Either (LWWRefKey s) HashRef) +webRef = \case + ListVal [TextLike "web:bind", TextLike name, TextLike "tree", HashLike h] -> Just (name, Right h) + ListVal [TextLike "web:bind", TextLike name, TextLike "ref", SignPubKeyLike k] -> Just (name, Left (LWWRefKey k)) + _ -> Nothing - flip fix (what'', 0) $ \again (what',i) -> do +noWebRoot :: [Syntax c] -> [Syntax c] +noWebRoot syn = flip filter syn \case + ListVal (TextLike "web:root" : _) -> False + ListVal (TextLike "webroot" : _) -> False + _ -> True + +getTreeHash :: forall e s . (s ~ Encryption e, ForSignedBox s, IsRefPubKey s, s ~ HBS2Basic) + => AnyStorage -> Maybe Text -> HashRef -> ActionM () + +getTreeHash sto part what'' = void $ flip runContT pure do + + flip fix (mempty, what'', 0) $ \again (p, what',i) -> do let what = fromHashRef what' - meta <- extractMetadataHash sto what' + meta' <- extractMetadataHash sto what' >>= orElse (status status404) + let meta = p <> meta' + + debug $ red "META/0" <+> pretty meta <+> line + let tp = headDef "application/octet-stream" [ show (pretty w) | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta @@ -226,12 +293,27 @@ getTreeHash sto what'' = void $ flip runContT pure do | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta ] + + let ce = headMay + [ show (pretty w) + | ListVal [SymbolVal "content-encoding:", StringLike w] <- meta + ] + + let parts = (Nothing, Right what') : [ (Just name, w) + | ( webRef @C -> Just (name, w) ) <- meta + ] & HM.fromList + + for_ ce $ \c -> + lift $ addHeader "Content-Encoding" (fromString c) + let webroot = headMay [ w - | i < 3, ListVal [SymbolVal "webroot", HashLike w] <- meta + | i < 2 + , ListVal [SymbolVal r, HashLike w] <- meta + , r == "webroot" || r == "web:root" ] case webroot of - Just x | i < 3 -> again (x, succ i) + Just x | i < 2 -> again (noWebRoot meta, x, succ i) _ -> do @@ -249,7 +331,14 @@ getTreeHash sto what'' = void $ flip runContT pure do lift $ addHeader "content-type" (fromString tp) - elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what) + debug $ red "META" <+> pretty meta <+> line <+> pretty (HM.keys parts) + + key <- case HM.lookup part parts of + Just (Right key) -> pure key + Just (Left lww) -> lookupLWWRef @e sto lww + _ -> pure (HashRef what) + + elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey (coerce key)) case elbs of Left{} -> lift $ status status404