diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 4b9fb479..df465b9c 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -60,8 +60,9 @@ getRPC = pure Nothing data CallRPC data PingRPC +data IndexNowRPC -type MyRPC = '[ PingRPC, CallRPC ] +type MyRPC = '[ PingRPC, IndexNowRPC, CallRPC ] instance HasProtocol UNIX (ServiceProto MyRPC UNIX) where type instance ProtocolId (ServiceProto MyRPC UNIX) = 0xFAFABEBE @@ -69,15 +70,15 @@ instance HasProtocol UNIX (ServiceProto MyRPC UNIX) where decode = either (const Nothing) Just . deserialiseOrFail encode = serialise --- instance (MonadIO m, HasProtocol UNIX (ServiceProto MyServiceMethods1 UNIX)) => HasTimeLimits UNIX (ServiceProto MyServiceMethods1 UNIX) m where --- tryLockForPeriod _ _ = pure True - type instance Input CallRPC = String type instance Output CallRPC = String type instance Input PingRPC = () type instance Output PingRPC = String +type instance Input IndexNowRPC = () +type instance Output IndexNowRPC = () + class HasDashBoardEnv m where getDashBoardEnv :: m DashBoardEnv @@ -91,6 +92,12 @@ instance (MonadIO m, HasDashBoardEnv m) => HandleMethod m PingRPC where debug $ "RPC PING" pure "pong" +instance (DashBoardPerks m, HasDashBoardEnv m) => HandleMethod m IndexNowRPC where + handleMethod _ = do + e <- getDashBoardEnv + debug $ "rpc: index:now" + withDashBoardEnv e $ addJob (liftIO $ withDashBoardEnv e updateIndex) + readConfig :: DashBoardPerks m => m [Syntax C] readConfig = do @@ -422,7 +429,7 @@ updateIndexPeriodially = do env <- ask - let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 30) + let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60) flip runContT pure do @@ -486,8 +493,7 @@ withMyRPCClient soname m = do liftIO $ m caller -theDict :: forall m . ( MonadIO m - , MonadUnliftIO m +theDict :: forall m . ( DashBoardPerks m -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m ) => Dict C (DashBoardM m) theDict = do @@ -501,6 +507,7 @@ theDict = do developAssetsEntry getRpcSocketEntry rpcPingEntry + rpcIndexEntry where @@ -569,6 +576,12 @@ theDict = do what <- callService @PingRPC caller () print what + rpcIndexEntry = do + entry $ bindMatch "index:now" $ nil_ $ const $ lift do + so <- getRPCSocket >>= orThrowUser "rpc socket down" + withMyRPCClient so $ \caller -> do + void $ callService @IndexNowRPC caller () + main :: IO () main = do argz <- getArgs diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs new file mode 100644 index 00000000..91e94425 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Manifest.hs @@ -0,0 +1,31 @@ +module HBS2.Git.DashBoard.Manifest where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.Data.RepoHead + +import Data.Text qualified as Text +import Data.Either +import Streaming.Prelude qualified as S + +parseManifest :: Monad m => RepoHead -> m ([Syntax C], Text) +parseManifest mhead = do + + let rawManifest = maybe mempty Text.lines (_repoManifest mhead) + + w <- S.toList_ do + flip fix rawManifest $ \next ss -> do + case ss of + ( "" : rest ) -> S.yield (Right (Text.stripStart (Text.unlines rest))) + ( a : rest ) -> S.yield (Left a ) >> next rest + [] -> pure () + + let meta = Text.unlines (lefts w) + & Text.unpack + & parseTop + & fromRight mempty + + let manifest = mconcat $ rights w + + pure (meta, manifest) + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index 973785d3..dd4c2c05 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs @@ -8,6 +8,7 @@ import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types import HBS2.Git.DashBoard.State import HBS2.Git.DashBoard.State.Commits +import HBS2.Git.DashBoard.Manifest import HBS2.OrDie @@ -410,32 +411,16 @@ tabClick :: Attribute tabClick = hyper_ "on click take .contrast from .tab for event's target" + parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text) parsedManifest RepoListItem{..} = do sto <- asks _sto mhead <- readRepoHeadFromTx sto (coerce rlRepoTx) - let rawManifest = (_repoManifest . snd =<< mhead) - & fromMaybe (coerce rlRepoBrief) - & Text.lines - - w <- S.toList_ do - flip fix rawManifest $ \next ss -> do - case ss of - ( "" : rest ) -> S.yield (Right (Text.stripStart (Text.unlines rest))) - ( a : rest ) -> S.yield (Left a ) >> next rest - [] -> pure () - - let meta = Text.unlines (lefts w) - & Text.unpack - & parseTop - & fromRight mempty - - let manifest = mconcat $ rights w - - pure (meta, manifest) - + case mhead of + Just x -> parseManifest (snd x) + Nothing -> pure (mempty, coerce rlRepoBrief) thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () thisRepoManifest it@RepoListItem{..} = do diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 61bf6a7e..d0d8751c 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -153,6 +153,7 @@ executable hbs2-git-dashboard HBS2.Git.DashBoard.State.Index HBS2.Git.DashBoard.State.Index.Channels HBS2.Git.DashBoard.State.Index.Peer + HBS2.Git.DashBoard.Manifest HBS2.Git.Web.Html.Root -- other-extensions: