mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
ed50582ddc
commit
8137e3dd11
|
|
@ -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
|
||||
[ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
|
||||
| ListVal [SymbolVal "refchan", LitStrVal rc] <- chan
|
||||
rchan <- headMay ( catMaybes
|
||||
[ fromStringMay @(RefChanId L4Proto) (Text.unpack rc)
|
||||
| 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
|
||||
|
||||
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)
|
||||
for_ [ s | LitStrVal s <- desc ] $ \s -> do
|
||||
p_ (toHtml s)
|
||||
|
||||
|
||||
channelPage :: MonadIO m
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
<&> fromStringMay
|
||||
>>= orElse (status status404)
|
||||
void $ flip runContT pure do
|
||||
|
||||
plugin <- readTVarIO handles <&> HM.lookup chan
|
||||
>>= orElse (status status404)
|
||||
chan <- maybe (fromStringMay $ Text.unpack url) pure alias
|
||||
& orElse (status status404)
|
||||
|
||||
let env = mempty
|
||||
lift $ renderTextT (channelPage plugin env) >>= html
|
||||
plugin <- readTVarIO handles <&> HM.lookup chan
|
||||
>>= orElse (status status404)
|
||||
|
||||
let env = mempty
|
||||
lift $ renderTextT (channelPage plugin env) >>= html
|
||||
|
||||
|
||||
put "/" do
|
||||
|
|
|
|||
Loading…
Reference in New Issue