wip, manifest to html

hbs2-core/lib/HBS2/Prelude/Plated.hs

@@ -11,9 +11,12 @@ import Data.Generics.Uniplate.Data()
 import Data.Generics.Uniplate.Operations
 import GHC.Generics()
 import Safe
+import Codec.Serialise
 
 import HBS2.Prelude
 
+deriving instance Data DeserialiseFailure
+
 uniLastMay :: forall to from . (Data from, Data to) => from -> Maybe to
 uniLastMay = lastMay . universeBi
 

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs

@@ -228,6 +228,17 @@ readRepoHeadFromTx sto href = runMaybeT do
     >>= toMPlus
     <&> (rhh,)
 
+readRepoHead :: (MonadIO m, MonadError OperationError m)
+             => AnyStorage
+             -> HashRef
+             -> m RepoHead
+
+readRepoHead sto rhh =
+  readFromMerkle sto (SimpleKey (fromHashRef rhh))
+    <&> deserialiseOrFail @RepoHead
+    >>= \case
+           Left{} -> throwError UnsupportedFormat
+           Right x -> pure x
 
 data BundleMeta =
   BundleMeta

hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs

@@ -107,7 +107,7 @@ newtype OnCoflictIgnore t r = OnCoflictIgnore r
 instance (HasPrimaryKey t, HasColumnNames r) => HasColumnNames (OnCoflictIgnore t r) where
   columnNames (OnCoflictIgnore r) = columnNames r
 
-onConflictIgnore :: forall t r . (HasTableName t, HasColumnNames r) => r -> OnCoflictIgnore t r
+onConflictIgnore :: (HasTableName t, HasColumnNames r) => r -> OnCoflictIgnore t r
 onConflictIgnore = OnCoflictIgnore
 
 instance ToField Bound where

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

@@ -77,7 +77,7 @@ runWithOracleEnv rchan m = do
 
   debug $ red "DBPATH" <+> pretty dbfile
 
-  db <- newDBPipeEnv dbPipeOptsDef dbfile
+  db <- newDBPipeEnv (dbPipeOptsDef { dbLogger = err . viaShow } ) dbfile
 
   env <- pure $ OracleEnv rchan
                           peerAPI
@@ -100,11 +100,11 @@ runWithOracleEnv rchan m = do
 
     void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
 
-    lift $ withOracleEnv env m
+    lift $ withOracleEnv env (withState evolveDB >> m)
 
 withOracleEnv :: MonadUnliftIO m => OracleEnv -> Oracle m a -> m a
 withOracleEnv env action = do
- runReaderT (fromOracle (withState evolveDB >> action)) env
+ runReaderT (fromOracle action) env
 
 class Monad m => HasDB m where
   getDB :: m DBPipeEnv

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

@@ -19,7 +19,8 @@ deriving instance Data (RefLogKey HBS2Basic)
 deriving instance Data (LWWRefKey HBS2Basic)
 
 data GitRepoExtended =
-  GitRepoExtended
+    GitRepoExtendedNone
+  | GitRepoExtendedManifest GitManifest
   deriving stock (Generic,Data)
 
 newtype GitLwwRef  = GitLwwRef (LWWRefKey HBS2Basic)
@@ -55,6 +56,10 @@ newtype GitBrief  = GitBrief (Maybe Text)
                     deriving stock (Generic,Data)
                     deriving newtype (ToField)
 
+newtype GitManifest = GitManifest (Maybe Text)
+                      deriving stock (Generic,Data)
+                      deriving newtype (ToField,FromField)
+
 newtype GitEncrypted = GitEncrypted (Maybe HashRef)
                        deriving stock (Generic,Data)
                        deriving newtype (ToField)
@@ -84,6 +89,7 @@ instance Serialise GitTx
 instance Serialise GitRepoHeadRef
 instance Serialise GitName
 instance Serialise GitBrief
+instance Serialise GitManifest
 instance Serialise GitRepoExtended
 instance Serialise GitEncrypted
 instance Serialise GitRepoHeadSeq
@@ -109,6 +115,15 @@ instance (FromField (RefLogKey HBS2Basic))  where
 instance HasTableName GitRepoFacts where
   tableName = "gitrepofact"
 
+instance HasTableName GitManifest where
+  tableName = "gitrepomanifest"
+
+instance HasColumnName GitManifest where
+  columnName = "manifest"
+
+instance HasPrimaryKey GitManifest where
+  primaryKey = ["repohead"]
+
 instance HasPrimaryKey GitRepoFacts where
   primaryKey = ["lwwref","lwwseq","reflog","tx","repohead"]
 

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

@@ -3,6 +3,8 @@ module HBS2.Git.Oracle.Html where
 import HBS2.Git.Oracle.Prelude
 import HBS2.Git.Oracle.State
 
+import HBS2.Git.Oracle.Facts
+
 import HBS2.Peer.HTTP.Root
 import HBS2.Peer.Proto.BrowserPlugin
 
@@ -12,7 +14,9 @@ import Lucid hiding (for_)
 import Lucid.Base
 import Lucid.Html5 hiding (for_)
 
+import Data.Coerce
 import Data.Text (Text)
+import Data.Maybe
 import Data.Text qualified as Text
 import Data.Word
 import Data.List qualified as List
@@ -30,7 +34,7 @@ markdownToHtml markdown = runPure $ do
 
 renderMarkdown :: Text -> Html ()
 renderMarkdown markdown = case markdownToHtml markdown of
-    Left{} -> mempty
+    Left{} -> blockquote_ (toHtml markdown)
     Right html -> toHtmlRaw $ Text.pack html
 
 -- <svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy-check" width="44" height="44" viewBox="0 0 24 24" stroke-width="1.5" stroke="#2c3e50" fill="none" stroke-linecap="round" stroke-linejoin="round">
@@ -87,14 +91,21 @@ renderEntries (Method _ kw) items = pure $ renderBS do
 
                   renderMarkdown b
 
-  where
-
-    -- wrapped f | not (HM.member "HTML_WRAPPED" args) = div_ f
-    --           | otherwise = do
-      wrapped f = do
+wrapped :: Monad m => HtmlT m a -> HtmlT m a
+wrapped f = do
   doctypehtml_ do
     head_ mempty do
       meta_ [charset_ "utf-8"]
 
     body_ mempty f
 
+
+renderRepoHtml :: Monad m => PluginMethod -> Maybe GitManifest -> m ByteString
+renderRepoHtml (Method _ kw) mf' = pure $ renderBS $ wrapped do
+  main_ do
+    let txt = coerce @_ @(Maybe Text) <$> mf' & join & fromMaybe ""
+    section_ [id_ "repo-manifest-text"] do
+      renderMarkdown txt
+
+
+

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

@@ -43,7 +43,7 @@ import HBS2.Net.Proto.Service
 import HBS2.Peer.Proto.RefChan
 import HBS2.Net.Messaging
 import HBS2.Net.Messaging.Pipe
-import HBS2.Actors.Peer
+import HBS2.Actors.Peer hiding (handle)
 import HBS2.Storage
 
 import HBS2.Misc.PrettyStuff

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

@@ -10,7 +10,7 @@ import HBS2.Git.Oracle.Facts
 import HBS2.Git.Oracle.State
 import HBS2.Git.Oracle.Html
 
-import HBS2.Actors.Peer
+import HBS2.Actors.Peer hiding (handle)
 
 import HBS2.Hash
 import HBS2.Merkle
@@ -51,8 +51,13 @@ import Text.InterpolatedString.Perl6 (qc)
 import System.Environment
 import System.Posix.Signals
 import System.FilePath
+import Data.Either
+import Control.Monad.Except
+import Control.Exception (SomeException)
+import Control.Exception qualified as E
 import Data.Word
 
+
 import System.Exit
 
 {- HLINT ignore "Functor law" -}
@@ -135,7 +140,7 @@ runOracleIndex auPk = do
                              (GitName (Just name))
                              (GitBrief (Just brief))
                              (GitEncrypted _repoHeadGK0)
-                             mempty
+                             [GitRepoExtendedManifest (GitManifest manifest)]
 
           -- liftIO $ withDB db (insertTxProcessed (HashVal tx))
 
@@ -198,7 +203,7 @@ runDump pks = do
     wtf <- callService @RpcChannelQuery caller (createPluginMethod path env & filterKW kw)
             >>= orThrowUser "can't query rpc"
 
-    r <- ContT $ maybe1 wtf (liftIO (hClose ssin >> exitFailure))
+    r <- ContT $ maybe1 wtf (liftIO (hClose ssin) >> void (waitExitCode p))
 
     hClose ssin
 
@@ -209,9 +214,24 @@ runDump pks = do
 class HasOracleEnv m where
   getOracleEnv :: m OracleEnv
 
+instance Monad m => HasOracleEnv (Oracle m) where
+  getOracleEnv = ask
+
+instance (Monad m, HasOracleEnv m) => HasOracleEnv (MaybeT m) where
+  getOracleEnv = lift getOracleEnv
+
+hardened :: (HasOracleEnv m, MonadIO m)
+         => Oracle IO (Maybe a)
+         -> m (Maybe a)
+hardened m = do
+  env <- getOracleEnv
+  liftIO $ E.try @SomeException (withOracleEnv env m) >>= \case
+    Left e -> err (viaShow e) >> pure Nothing
+    Right x -> pure $ x
+
 -- API handler
 instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery where
-  handleMethod req@(Method path args) = do
+  handleMethod req@(Method path args) = hardened do
     env <- getOracleEnv
 
     debug $ green "PLUGIN: HANDLE METHOD!" <+> viaShow req
@@ -223,7 +243,10 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
       []                 -> listEntries req
       ("list-entries":_) -> listEntries req
       ("/":_)            -> listEntries req
-      ("repo" : params)  -> renderRepo (withParams params req)
+
+      ("repo" : params)  -> do
+        renderRepo (withParams params req)
+
       _                  -> pure Nothing
 
     where
@@ -259,11 +282,30 @@ instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery whe
             _           -> formatJson items
 
 
-      renderRepo (Method _ kw) = do
-        Just <$> renderBST do
-          main_ do
-            let repoRef = fromMaybe "unknown" $ HM.lookup "_1" kw
-            h1_ $ toHtml $ "REPO " <> repoRef
+      renderRepo req@(Method _ kw) = runMaybeT do
+        env <- getOracleEnv
+        sto <- getOracleEnv <&> _storage
+
+        debug $ yellow "ONE"
+
+        ref <- HM.lookup "_1" kw  & toMPlus
+                 <&> Text.unpack
+                 <&> fromStringMay @HashRef
+                 >>= toMPlus
+
+        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
+                       where v.lwwref = ?
+                       limit 1
+                       |] (Only ref)
+                    )  <&> headMay
+                       <&> fmap snd
+
+        renderRepoHtml req mf'
 
       formatJson items = do
           let root = object [ "rows"  .= items
@@ -292,6 +334,8 @@ runPipe :: forall m  . MonadUnliftIO m
 runPipe = do
 
   setLogging @DEBUG  (logPrefix "" . toStderr)
+  setLogging @ERROR  (logPrefix "" . toStderr)
+  setLogging @WARN   (logPrefix "" . toStderr)
 
   chan <- asks _refchanId
   debug $ green "RUN PIPE!!!"
@@ -302,7 +346,7 @@ runPipe = do
 
     server  <- newMessagingPipe (stdin,stdout)
 
-    void $ ContT $ bracket (async $ runMessagingPipe server) cancel
+    void $ ContT $ withAsync (runMessagingPipe server)
 
     void $ ContT $ withAsync $ do
       pause @'Seconds 10
@@ -312,7 +356,7 @@ runPipe = do
         pause @'Seconds 60
 
     -- make server protocol responder
-    serv <- ContT $ withAsync $ flip runReaderT server do
+    void $ ContT $ withAsync $ flip runReaderT server do
         runProto @PIPE
           [ makeResponse (makeServer @BrowserPluginAPI)
           ]
@@ -324,12 +368,14 @@ runPipe = do
       let done = done1 || done2 || done3
       unless done (pause @'Seconds 0.01 >> next)
 
+
 updateState :: MonadUnliftIO m => Oracle m ()
 updateState = do
   debug $ yellow "update state"
 
   chan  <- asks _refchanId
   rchanAPI <- asks _refchanAPI
+  peerAPI <- asks _peerAPI
   sto  <- asks  _storage
   db   <- asks _db
 
@@ -373,3 +419,12 @@ updateState = do
           debug "BAD FACT"
           insertTxProcessed (HashVal tx)
 
+    let refs = [ h | GitRepoHeadRef h <- universeBi facts ]
+
+    w <- for refs $ \r -> do
+      -- TODO: dont-fetch-repeatedly
+      debug $ red "repo-head-to-fetch" <+> pretty r
+      lift $ async (callRpcWaitMay @RpcFetch (TimeoutSec 1) peerAPI r)
+
+    lift $ mapM_ wait w
+

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

@@ -26,6 +26,8 @@ evolveDB :: MonadUnliftIO m => DBPipeM m ()
 evolveDB = do
   debug $ yellow "evolveDB"
   gitRepoFactTable
+  gitRepoManifestTable
+  gitRepoFactView
   txProcessedTable
 
 txProcessedTable :: MonadUnliftIO m => DBPipeM m ()
@@ -54,6 +56,41 @@ gitRepoFactTable = do
     )
   |]
 
+
+gitRepoManifestTable :: MonadUnliftIO m => DBPipeM m ()
+gitRepoManifestTable = do
+  ddl [qc|
+    create table if not exists gitrepomanifest
+    ( repohead      text not null
+    , manifest      text
+    , primary key (repohead)
+    )
+  |]
+
+
+gitRepoFactView :: MonadUnliftIO m => DBPipeM m ()
+gitRepoFactView = do
+  ddl [qc|
+    CREATE VIEW IF NOT EXISTS vrepofact AS
+    SELECT
+      lwwref,
+      repohead,
+      name,
+      brief,
+      repoheadseq
+    FROM (
+      SELECT
+        lwwref,
+        repohead,
+        name,
+        brief,
+        repoheadseq,
+        ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC, repoheadseq DESC) as rn
+      FROM gitrepofact
+    ) as s0
+    WHERE rn = 1;
+  |]
+
 newtype GitRepoKey = GitRepoKey (LWWRefKey HBS2Basic)
                      deriving stock Generic
 
@@ -91,7 +128,7 @@ isTxProcessed hash = do
 
 
 insertRepoFacts :: (MonadUnliftIO m) => GitRepoFacts -> DBPipeM m ()
-insertRepoFacts GitRepoFacts{..} = do
+insertRepoFacts facts@GitRepoFacts{..} = do
  insert @GitRepoFacts $
    onConflictIgnore @GitRepoFacts
     ( gitLwwRef
@@ -104,5 +141,11 @@ insertRepoFacts GitRepoFacts{..} = do
     , gitBrief
     , gitEncrypted
     )
+ let mf = [ m | m :: GitManifest <- universeBi facts ]
+ for_ mf $ \m@GitManifest{} -> do
+  insert @GitManifest $ onConflictIgnore @GitManifest (gitRepoHead, m)
+  pure ()
+
+  -- insert @GitManifest ( gitRepoHead,
 
 

hbs2-peer/app/Browser/Root.hs

@@ -121,7 +121,11 @@ nav.left {
   padding: 2rem;
   margin: 0;
   background: #FAFAFA;
-  width: 20em;
+  width: 20rem;
+}
+
+section#repo-manifest-text {
+  width: 60rem;
 }
 
 main {