support web:bind alias redirect

hbs2-peer/app/HttpWorker.hs

@@ -42,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.Text.Lazy qualified as LT
 import Data.HashMap.Strict qualified as HM
 import Control.Monad.Reader
 import Lens.Micro.Platform (view)
@@ -255,10 +256,17 @@ httpWorker (PeerConfig syn) pmeta = do
 
 -- 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
-  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))
+  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, RefRef (LWWRefKey k))
+  ListVal [TextLike "web:bind", TextLike name, TextLike "redirect",  TextLike re] -> Just (name, RefRedirect re)
   _ -> Nothing
 
 noWebRoot :: [Syntax c] -> [Syntax c]
@@ -272,6 +280,8 @@ getTreeHash :: forall e s . (s ~ Encryption e, ForSignedBox s, IsRefPubKey s, s
 
 getTreeHash sto part what'' = void $ flip runContT pure do
 
+  callCC \exit -> do
+
     flip fix (mempty, what'', 0) $ \again (p, what',i) -> do
 
       let what = fromHashRef what'
@@ -293,13 +303,22 @@ getTreeHash sto part 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)
+
+      let re = headMay
+               [ show (pretty w)
+               | ListVal [SymbolVal "web:redirect", StringLike w] <- meta
+               ]
+
+      for_ re $ \l -> do
+        lift $ redirect (fromString l)
+        exit ()
+
+      let parts = (Nothing, RefTree what') : [ (Just name, w)
                   | ( webRef @C -> Just (name, w) ) <- meta
                   ] & HM.fromList
 
@@ -334,8 +353,12 @@ getTreeHash sto part what'' = void $ flip runContT pure do
           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
+                   Just (RefTree key) -> pure key
+                   Just (RefRef lww)  -> lookupLWWRef @e sto lww
+                   Just (RefRedirect s)  -> do
+                      lift $ redirect (LT.fromStrict s)
+                      exit ()
+
                    _ -> pure (HashRef what)
 
           elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey (coerce key))

miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs

@@ -44,6 +44,7 @@ module Data.Config.Suckless.Syntax
   , pattern TextLikeList
   , pattern Nil
   , pattern OpaqueVal
+  , pattern MatchOpaqueVal
   )
   where
 
@@ -133,6 +134,10 @@ pattern Nil <- ListVal []
 pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
 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
 
 isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a