wip

hbs2-peer/app/Browser/Root.hs

@@ -22,6 +22,7 @@ import Text.InterpolatedString.Perl6 (q)
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import System.FilePath
 import Control.Monad
+import Control.Monad.Trans.Maybe
 
 import Text.HTML.TagSoup
 
@@ -255,7 +256,7 @@ browserRootPage syn = rootPage do
       div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
 
     main_ do
-      for_ channels $ \chan -> do
+      for_ channels $ \chan -> void $ runMaybeT do
 
         let title = headDef "unknown" [ t
                                           | ListVal [ SymbolVal "title", LitStrVal t ] <- chan
@@ -264,25 +265,28 @@ browserRootPage syn = rootPage do
                            | ListVal (SymbolVal "description" : d) <- chan
                            ] & take 5
 
-        let rchan = headMay $ catMaybes
+        rchan <- headMay ( catMaybes
-                            [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
+                       [ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
-                            | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
+                       | ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
+                       ] ) & toMPlus
+
+
+        let alias = headMay [ x
+                            | ListVal [SymbolVal "alias", LitStrVal x] <- chan
                             ]
 
+        let url = case alias of
+                    Just x -> Text.unpack x
+                    Nothing -> (show . pretty . AsBase58) rchan
 
-        for_ rchan $ \r -> do
+        lift do
+          div_ [class_ "channel-list-item"] do
+            h2_ $ toHtml title
 
-          let rcs = show $ pretty (AsBase58 r)
+            a_ [href_ (path [url])] (toHtml (show $ pretty $ AsBase58 rchan))
 
-          section_ do
+            for_ [ s | LitStrVal s <- desc ] $ \s -> do
-
+              p_ (toHtml s)
-            div_ [class_ "channel-list-item"] do
-              h2_ $ toHtml title
-
-              a_ [href_ (path ["channel", rcs])] (toHtml rcs)
-
-              for_ [ s | LitStrVal s <- desc ] $ \s -> do
-                p_ (toHtml s)
 
 
 channelPage :: MonadIO m

hbs2-peer/app/HttpWorker.hs

@@ -120,13 +120,10 @@ runPlugin pks (self:args) handles = do
       ContT $ bracket (atomically $ modifyTVar handles (HM.insert pks caller))
                       (const $ atomically $ modifyTVar handles (HM.delete pks))
 
-
-
-
       void $ waitExitCode p
 
 
-findPlugins :: forall m . MonadIO m => [Syntax C] -> m [(RefChanId L4Proto, [FilePath])]
+findPlugins :: forall m . MonadIO m => [Syntax C] -> m [(Maybe Text, RefChanId L4Proto, [FilePath])]
 findPlugins syn = w $ S.toList_ $ do
 
   let chans = mconcat [ channels b | ListVal (SymbolVal "browser" : b)  <- syn ]
@@ -138,6 +135,10 @@ findPlugins syn = w $ S.toList_ $ do
                            | ListVal [SymbolVal "refchan", LitStrVal x] <- cha
                            ]
 
+    let alias =  headMay [ x
+                         | ListVal [SymbolVal "alias", LitStrVal x] <- cha
+                         ]
+
     plug <- toMPlus $ headMay $ catMaybes $
                [ mkProcessArgs what
                | ListVal [ SymbolVal "plugin", Spawn what ] <- cha
@@ -145,13 +146,14 @@ findPlugins syn = w $ S.toList_ $ do
 
     debug $ red "FOUND CHANNEL" <+> pretty (AsBase58 rchan) <+> parens (pretty plug)
 
-    lift $ S.yield (rchan, plug)
+    lift $ S.yield (alias, rchan, plug)
 
   where
 
     w l = l >>= uniq
 
-    uniq s = pure (List.nubBy ((==) `on` fst) s)
+    uniq s = pure (List.nubBy ((==) `on` ukey) s)
+      where ukey (a,b,_) = (a,b)
 
     mkProcessArgs ssyn = sequence $
       flip fmap ssyn \case
@@ -185,9 +187,12 @@ httpWorker (PeerConfig syn) pmeta e = do
 
     handles <- newTVarIO mempty
 
+    aliases <- newTVarIO (mempty :: HashMap Text (RefChanId L4Proto))
+
     plugins <- findPlugins syn
 
-    for_ plugins $ \(r, args) -> do
+    for_ plugins $ \(a, r, args) -> do
+      for_ a $ \alias -> atomically $ modifyTVar aliases (HM.insert alias r)
       void $ ContT $ withAsync (runPlugin r args handles)
 
     port <- ContT $ maybe1 port' none
@@ -320,17 +325,20 @@ httpWorker (PeerConfig syn) pmeta e = do
         get "/browser" do
           renderTextT (browserRootPage syn) >>= html
 
-        get "/browser/channel/:refchan" $ void $ flip runContT pure do
+        get "/browser/:plugin" $ do
+          url <- param @Text "plugin"
+          alias <- readTVarIO aliases <&> HM.lookup url
 
-          chan <- lift (param @String "refchan")
+          void $ flip runContT pure do
-                   <&> fromStringMay
-                   >>= orElse (status status404)
 
-          plugin <- readTVarIO handles <&> HM.lookup chan
+            chan <- maybe (fromStringMay $ Text.unpack url) pure alias
-                     >>= orElse (status status404)
+                   & orElse (status status404)
 
-          let env = mempty
+            plugin <- readTVarIO handles <&> HM.lookup chan
-          lift $ renderTextT (channelPage plugin env) >>= html
+                       >>= orElse (status status404)
+
+            let env = mempty
+            lift $ renderTextT (channelPage plugin env) >>= html
 
 
       put "/" do