diff --git a/hbs2-core/lib/HBS2/Prelude/Plated.hs b/hbs2-core/lib/HBS2/Prelude/Plated.hs index c672a44a..b3288da4 100644 --- a/hbs2-core/lib/HBS2/Prelude/Plated.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs index d8ec8b76..9deef2db 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs b/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs index 36d7e171..14d8abff 100644 --- a/hbs2-git/hbs2-git-oracle/lib/DBPipe/SQLite/Generic.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs index 0816c14a..8e21cf12 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs index 39d6caac..5c77d173 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs +++ b/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"] diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs index a9a6d5a8..62e2554a 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs +++ b/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 -- @@ -87,14 +91,21 @@ renderEntries (Method _ kw) items = pure $ renderBS do renderMarkdown b - where +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 - -- wrapped f | not (HM.member "HTML_WRAPPED" args) = div_ f - -- | otherwise = do - wrapped f = do - doctypehtml_ do - head_ mempty do - meta_ [charset_ "utf-8"] - body_ mempty f diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs index cbfcec61..99c621bc 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Prelude.hs +++ b/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 diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs index cc1b53ea..d0d2c3d9 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs +++ b/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 + diff --git a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs index 845785da..2153bf45 100644 --- a/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs +++ b/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, diff --git a/hbs2-peer/app/Browser/Root.hs b/hbs2-peer/app/Browser/Root.hs index 2682bd42..b86dd753 100644 --- a/hbs2-peer/app/Browser/Root.hs +++ b/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 {