mirror of https://github.com/voidlizard/hbs2
support web:bind alias redirect
This commit is contained in:
voidlizard
parent
2628d7efa0
commit
95b93698ac
|
|
@ -42,6 +42,7 @@ import Codec.Serialise (deserialiseOrFail)
|
||||||
import Data.Aeson (object, (.=))
|
import Data.Aeson (object, (.=))
|
||||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
|
import Data.Text.Lazy qualified as LT
|
||||||
import Data.HashMap.Strict qualified as HM
|
import Data.HashMap.Strict qualified as HM
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Lens.Micro.Platform (view)
|
import Lens.Micro.Platform (view)
|
||||||
|
|
@ -255,10 +256,17 @@ httpWorker (PeerConfig syn) pmeta = do
|
||||||
|
|
||||||
-- pattern WebRef :: forall {s} . sEither (L
|
-- pattern WebRef :: forall {s} . sEither (L
|
||||||
|
|
||||||
webRef :: forall c s . (IsContext c, s ~ HBS2Basic) => Syntax c -> Maybe (Text, Either (LWWRefKey s) HashRef)
|
data WebRefAction s =
|
||||||
|
RefTree HashRef
|
||||||
|
| RefRef (LWWRefKey s)
|
||||||
|
| RefRedirect Text
|
||||||
|
|
||||||
|
|
||||||
|
webRef :: forall c s . (IsContext c, s ~ HBS2Basic) => Syntax c -> Maybe (Text, WebRefAction s)
|
||||||
webRef = \case
|
webRef = \case
|
||||||
ListVal [TextLike "web:bind", TextLike name, TextLike "tree", HashLike h] -> Just (name, Right h)
|
ListVal [TextLike "web:bind", TextLike name, TextLike "tree", HashLike h] -> Just (name, RefTree h)
|
||||||
ListVal [TextLike "web:bind", TextLike name, TextLike "ref", SignPubKeyLike k] -> Just (name, Left (LWWRefKey k))
|
ListVal [TextLike "web:bind", TextLike name, TextLike "ref", SignPubKeyLike k] -> Just (name, RefRef (LWWRefKey k))
|
||||||
|
ListVal [TextLike "web:bind", TextLike name, TextLike "redirect", TextLike re] -> Just (name, RefRedirect re)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
noWebRoot :: [Syntax c] -> [Syntax c]
|
noWebRoot :: [Syntax c] -> [Syntax c]
|
||||||
|
|
@ -272,80 +280,95 @@ getTreeHash :: forall e s . (s ~ Encryption e, ForSignedBox s, IsRefPubKey s, s
|
||||||
|
|
||||||
getTreeHash sto part what'' = void $ flip runContT pure do
|
getTreeHash sto part what'' = void $ flip runContT pure do
|
||||||
|
|
||||||
flip fix (mempty, what'', 0) $ \again (p, what',i) -> do
|
callCC \exit -> do
|
||||||
|
|
||||||
let what = fromHashRef what'
|
flip fix (mempty, what'', 0) $ \again (p, what',i) -> do
|
||||||
|
|
||||||
meta' <- extractMetadataHash sto what'
|
let what = fromHashRef what'
|
||||||
>>= orElse (status status404)
|
|
||||||
|
|
||||||
let meta = p <> meta'
|
meta' <- extractMetadataHash sto what'
|
||||||
|
>>= orElse (status status404)
|
||||||
|
|
||||||
debug $ red "META/0" <+> pretty meta <+> line
|
let meta = p <> meta'
|
||||||
|
|
||||||
let tp = headDef "application/octet-stream"
|
debug $ red "META/0" <+> pretty meta <+> line
|
||||||
[ show (pretty w)
|
|
||||||
| ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta
|
|
||||||
]
|
|
||||||
|
|
||||||
let fn = headMay
|
let tp = headDef "application/octet-stream"
|
||||||
[ show (pretty w)
|
[ show (pretty w)
|
||||||
| ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
|
| ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta
|
||||||
]
|
]
|
||||||
|
|
||||||
|
let fn = headMay
|
||||||
|
[ show (pretty w)
|
||||||
|
| ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
|
||||||
|
]
|
||||||
|
|
||||||
|
let ce = headMay
|
||||||
|
[ show (pretty w)
|
||||||
|
| ListVal [SymbolVal "content-encoding:", StringLike w] <- meta
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
let ce = headMay
|
let re = headMay
|
||||||
[ show (pretty w)
|
[ show (pretty w)
|
||||||
| ListVal [SymbolVal "content-encoding:", StringLike w] <- meta
|
| ListVal [SymbolVal "web:redirect", StringLike w] <- meta
|
||||||
]
|
]
|
||||||
|
|
||||||
let parts = (Nothing, Right what') : [ (Just name, w)
|
for_ re $ \l -> do
|
||||||
| ( webRef @C -> Just (name, w) ) <- meta
|
lift $ redirect (fromString l)
|
||||||
] & HM.fromList
|
exit ()
|
||||||
|
|
||||||
for_ ce $ \c ->
|
let parts = (Nothing, RefTree what') : [ (Just name, w)
|
||||||
lift $ addHeader "Content-Encoding" (fromString c)
|
| ( webRef @C -> Just (name, w) ) <- meta
|
||||||
|
] & HM.fromList
|
||||||
|
|
||||||
let webroot = headMay [ w
|
for_ ce $ \c ->
|
||||||
| i < 2
|
lift $ addHeader "Content-Encoding" (fromString c)
|
||||||
, ListVal [SymbolVal r, HashLike w] <- meta
|
|
||||||
, r == "webroot" || r == "web:root"
|
|
||||||
]
|
|
||||||
|
|
||||||
case webroot of
|
let webroot = headMay [ w
|
||||||
Just x | i < 2 -> again (noWebRoot meta, x, succ i)
|
| i < 2
|
||||||
|
, ListVal [SymbolVal r, HashLike w] <- meta
|
||||||
|
, r == "webroot" || r == "web:root"
|
||||||
|
]
|
||||||
|
|
||||||
_ -> do
|
case webroot of
|
||||||
|
Just x | i < 2 -> again (noWebRoot meta, x, succ i)
|
||||||
|
|
||||||
for_ webroot $ \w -> do
|
_ -> do
|
||||||
warn $ green "HTTP:WEBROOT" <+> pretty w
|
|
||||||
|
|
||||||
-- liftIO $ print $ pretty meta
|
for_ webroot $ \w -> do
|
||||||
|
warn $ green "HTTP:WEBROOT" <+> pretty w
|
||||||
|
|
||||||
case fn of
|
-- liftIO $ print $ pretty meta
|
||||||
Just x | takeExtension x == ".html" -> pure ()
|
|
||||||
| otherwise -> lift $ do
|
|
||||||
addHeader "content-disposition" [qc|attachment; filename="{x}"|]
|
|
||||||
|
|
||||||
_ -> pure ()
|
case fn of
|
||||||
|
Just x | takeExtension x == ".html" -> pure ()
|
||||||
|
| otherwise -> lift $ do
|
||||||
|
addHeader "content-disposition" [qc|attachment; filename="{x}"|]
|
||||||
|
|
||||||
lift $ addHeader "content-type" (fromString tp)
|
_ -> pure ()
|
||||||
|
|
||||||
debug $ red "META" <+> pretty meta <+> line <+> pretty (HM.keys parts)
|
lift $ addHeader "content-type" (fromString tp)
|
||||||
|
|
||||||
key <- case HM.lookup part parts of
|
debug $ red "META" <+> pretty meta <+> line <+> pretty (HM.keys parts)
|
||||||
Just (Right key) -> pure key
|
|
||||||
Just (Left lww) -> lookupLWWRef @e sto lww
|
|
||||||
_ -> pure (HashRef what)
|
|
||||||
|
|
||||||
elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey (coerce key))
|
key <- case HM.lookup part parts of
|
||||||
|
Just (RefTree key) -> pure key
|
||||||
|
Just (RefRef lww) -> lookupLWWRef @e sto lww
|
||||||
|
Just (RefRedirect s) -> do
|
||||||
|
lift $ redirect (LT.fromStrict s)
|
||||||
|
exit ()
|
||||||
|
|
||||||
case elbs of
|
_ -> pure (HashRef what)
|
||||||
Left{} -> lift $ status status404
|
|
||||||
Right lbs -> lift do
|
elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey (coerce key))
|
||||||
stream $ \write flush -> do
|
|
||||||
for_ (LBS.toChunks lbs) $ \chunk -> do
|
case elbs of
|
||||||
write $ byteString chunk
|
Left{} -> lift $ status status404
|
||||||
flush
|
Right lbs -> lift do
|
||||||
|
stream $ \write flush -> do
|
||||||
|
for_ (LBS.toChunks lbs) $ \chunk -> do
|
||||||
|
write $ byteString chunk
|
||||||
|
flush
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -44,6 +44,7 @@ module Data.Config.Suckless.Syntax
|
||||||
, pattern TextLikeList
|
, pattern TextLikeList
|
||||||
, pattern Nil
|
, pattern Nil
|
||||||
, pattern OpaqueVal
|
, pattern OpaqueVal
|
||||||
|
, pattern MatchOpaqueVal
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -133,6 +134,10 @@ pattern Nil <- ListVal []
|
||||||
pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
|
pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
|
||||||
pattern OpaqueVal box <- OpaqueValue box
|
pattern OpaqueVal box <- OpaqueValue box
|
||||||
|
|
||||||
|
-- by @qnikst, thanks, dude
|
||||||
|
pattern MatchOpaqueVal :: forall c a . (IsContext c, Typeable a) => a -> Syntax c
|
||||||
|
pattern MatchOpaqueVal o <- (OpaqueVal (fromOpaque -> Just o))
|
||||||
|
|
||||||
data family Context c :: Type
|
data family Context c :: Type
|
||||||
|
|
||||||
isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
|
isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue