wip, extracted parseManifest

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

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)
+
+

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

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: