wip

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs

@@ -25,7 +25,7 @@ data GitRepoExtended =
 
 newtype GitLwwRef  = GitLwwRef (LWWRefKey HBS2Basic)
                      deriving stock (Generic,Data)
-                     deriving newtype (ToField)
+                     deriving newtype (ToField,FromField)
 
 newtype GitLwwSeq  = GitLwwSeq Word64
                      deriving stock (Generic,Data)
@@ -46,15 +46,15 @@ newtype GitTx  = GitTx HashRef
 
 newtype GitRepoHeadRef  = GitRepoHeadRef HashRef
                           deriving stock (Generic,Data)
-                          deriving newtype (ToField)
+                          deriving newtype (ToField,FromField)
 
 newtype GitName  = GitName  (Maybe Text)
                    deriving stock (Generic,Data)
-                   deriving newtype (ToField)
+                   deriving newtype (ToField,FromField)
 
 newtype GitBrief  = GitBrief (Maybe Text)
                     deriving stock (Generic,Data)
-                    deriving newtype (ToField)
+                    deriving newtype (ToField,FromField)
 
 newtype GitManifest = GitManifest (Maybe Text)
                       deriving stock (Generic,Data)

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs

@@ -26,6 +26,8 @@ import Text.Pandoc
 import Text.Pandoc.Error (handleError)
 import Text.InterpolatedString.Perl6 (qc)
 
+
+
 markdownToHtml :: Text -> Either PandocError String
 markdownToHtml markdown = runPure $ do
   doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown
@@ -100,12 +102,35 @@ wrapped f = do
     body_ mempty f
 
 
-renderRepoHtml :: Monad m => PluginMethod -> Maybe GitManifest -> m ByteString
-renderRepoHtml (Method _ kw) mf' = pure $ renderBS $ wrapped do
+renderRepoHtml :: Monad m => PluginMethod -> GitRepoPage -> m ByteString
+renderRepoHtml (Method _ kw) page@(GitRepoPage{..}) = pure $ renderBS $ wrapped do
+
+  let mf = headDef "" [ fromMaybe "" s | GitManifest s <- universeBi page ]
+            & Text.lines
+            & List.dropWhile (not . Text.null)
+            & Text.unlines
+
+  let name' = coerce @_ @(Maybe Text) repoPageName
+  let brief = coerce @_ @(Maybe Text) repoPageBrief & fromMaybe ""
+
   main_ do
-    let txt = coerce @_ @(Maybe Text) <$> mf' & join & fromMaybe ""
+
+    section_ [id_ "repo-data"] do
+
+      for_ name' $ \name -> do
+        h1_ (toHtml name)
+        renderMarkdown brief
+
+      table_ do
+        tr_ do
+          th_ "code/hbs2:"
+          td_ mempty
+
+      pure ()
+
+
     section_ [id_ "repo-manifest-text"] do
-      renderMarkdown txt
+      renderMarkdown mf
 
 
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -295,17 +295,21 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
 
         debug $ yellow "TWO"
 
-        mf' <- lift ( withOracleEnv env do
-                withState $ select @(HashRef, GitManifest) [qc|
-                       select v.repohead, m.manifest
-                       from vrepofact v join gitrepomanifest m on v.repohead = m.repohead
+        mf <- lift ( withOracleEnv env do
+                withState $ select @GitRepoPage [qc|
+                       select  v.lwwref
+                             , v.repohead
+                             , v.name
+                             , v.brief
+                             , m.manifest
+                       from vrepofact v left join gitrepomanifest m on v.repohead = m.repohead
                        where v.lwwref = ?
                        limit 1
                        |] (Only ref)
                     )  <&> headMay
-                       <&> fmap snd
+                       >>= toMPlus
 
-        renderRepoHtml req mf'
+        renderRepoHtml req mf
 
       formatJson items = do
           let root = object [ "rows"  .= items

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs

@@ -19,6 +19,18 @@ import Data.Coerce
 import Data.Word
 import Data.Text qualified as Text
 
+data GitRepoPage =
+  GitRepoPage
+  { repoPageRef      :: GitLwwRef
+  , repoPageHead     :: GitRepoHeadRef
+  , repoPageName     :: GitName
+  , repoPageBrief    :: GitBrief
+  , repoPageManifest :: GitManifest
+  }
+  deriving stock (Generic,Data)
+
+instance FromRow GitRepoPage
+
 processedRepoTx :: (LWWRefKey HBS2Basic, HashRef) -> HashVal
 processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w)
 

hbs2-peer/app/Browser/Root.hs

@@ -68,13 +68,15 @@ button.search svg {
 body, html {
   margin: 0;
   height: 100%;
-  font-size: 18px;
+  font-size: 20px;
 }
 
 
 header {
   width: 100%;
 
+  font-size: 20px;
+
   display: flex;
   align-items: center;
 
@@ -89,7 +91,7 @@ header {
 /* height: 64px; */
 
 header h1 {
-  font-size: 1.45rem;
+  font-size: 20px;
   margin: 0 0 0 2.21rem;
   font-weight: 500;
 }
@@ -121,6 +123,7 @@ header a {
 nav.left {
   flex: 0 0 20rem;
   padding: 4rem 0rem 0 1rem;
+  font-size: 20px;
   flex-direction: column;
   justify-content: normal;
   background: #FAFAFA;
@@ -132,6 +135,7 @@ nav.left .info-block {
 
 section#repo-manifest-text {
   width: 60rem;
+  font-size: 24px;
 }
 
 
@@ -253,6 +257,7 @@ form.search input[type="search"] {
 
 form.search button {
   align: center;
+  min-width: 4rem;
 }
 
 .xclip::after {
@@ -295,6 +300,7 @@ rootPage content  = do
       -- link_ [rel_ "stylesheet", href_"/css/pico.min.css"]
       link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"]
       script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] ""
+      script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] ""
       myCss
 
     body_ do