diff --git a/hbs2-git/hbs2-git-oracle/app/Main.hs b/hbs2-git/hbs2-git-oracle/app/Main.hs index 611237c3..f1d7b175 100644 --- a/hbs2-git/hbs2-git-oracle/app/Main.hs +++ b/hbs2-git/hbs2-git-oracle/app/Main.hs @@ -63,14 +63,17 @@ runApp chan mode = do setLogging @ERROR (toStderr . logPrefix "[error] ") setLogging @NOTICE (toStderr . logPrefix "[debug] ") - case mode of RunIndex a -> runWithOracleEnv chan $ runOracleIndex a - RunPipe{} -> runWithOracleEnv chan $ runPipe + RunPipe{} -> shutUp >> (runWithOracleEnv chan $ runPipe) RunDump pks -> runDump pks RunUpdate -> runWithOracleEnv chan $ updateState `finally` do + shutUp + + where + shutUp = do setLoggingOff @DEBUG setLoggingOff @WARN setLoggingOff @ERROR 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 new file mode 100644 index 00000000..e7dbc2f0 --- /dev/null +++ b/hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Html.hs @@ -0,0 +1,32 @@ +module HBS2.Git.Oracle.Html where + +import HBS2.Git.Oracle.Prelude +import HBS2.Git.Oracle.State + +import Data.HashMap.Strict (HashMap) + +import Lucid (Html,HtmlT,toHtml,renderBS) +import Lucid.Html5 hiding (for_) + +import Data.Text (Text) +import Data.Text qualified as Text +import Data.ByteString.Lazy +import Control.Monad.Identity + +renderEntries :: Monad m => HashMap Text Text -> [(HashVal, Text, Text)] -> m ByteString +renderEntries _ items = pure $ renderBS do + doctypehtml_ do + head_ mempty do + meta_ [charset_ "utf-8"] + + body_ mempty do + for_ items $ \(h,n,b) -> do + div_ do + + when ( Text.length n > 2) do + h3_ [class_ "repo-name"] (toHtml (show $ pretty n)) + span_ [class_ "repo-reference"] (toHtml (show $ pretty h)) + + -- td_ (toHtml (show $ pretty n)) + -- td_ (toHtml (show $ pretty b)) + 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 eb2f3ba2..c44b1d3b 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 @@ -7,6 +7,7 @@ import HBS2.Git.Oracle.Prelude import HBS2.Git.Oracle.App import HBS2.Git.Oracle.Facts import HBS2.Git.Oracle.State +import HBS2.Git.Oracle.Html import HBS2.Actors.Peer @@ -35,12 +36,13 @@ import Control.Monad.Trans.Maybe import Data.Coerce import Data.Ord import Data.Text qualified as Text +import Data.List qualified as List import Data.HashMap.Strict qualified as HM import Data.ByteString.Lazy qualified as LBS import System.Process.Typed import Text.InterpolatedString.Perl6 (qc) import System.Environment (getProgName, getArgs) - +import System.Environment import System.Posix.Signals import System.Exit @@ -151,6 +153,9 @@ runDump :: forall m . MonadUnliftIO m runDump pks = do self <- liftIO getProgName + env <- liftIO getEnvironment + <&> fmap (over _1 Text.pack . over _2 Text.pack) + let cmd = proc self ["pipe", "-r", show (pretty (AsBase58 pks))] & setStdin createPipe & setStdout createPipe @@ -158,39 +163,27 @@ runDump pks = do flip runContT pure do p <- ContT $ withProcessWait cmd - -- p <- lift $ startProcess cmd let ssin = getStdin p let sout = getStdout p client <- newMessagingPipe (sout,ssin) -- ,sout) - mess <- ContT $ bracket (async $ runMessagingPipe client) cancel + void $ ContT $ withAsync $ runMessagingPipe client caller <- makeServiceCaller @BrowserPluginAPI @PIPE (localPeer client) - broker <- ContT $ bracket (async $ liftIO $ runReaderT (runServiceClient caller) client) cancel + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClient caller) client - wtf <- callService @RpcChannelQuery caller () + wtf <- callService @RpcChannelQuery caller env >>= orThrowUser "can't query rpc" r <- ContT $ maybe1 wtf (pure ()) - let val = Aeson.decode @Value r - - liftIO $ LBS.putStr (A.encodePretty val) - hClose ssin - hClose sout - waitExitCode p + liftIO $ LBS.putStr r >> hFlush stdout - debug "CLIENT: WTF?" - - -- stopProcess p - -- error "MOTHERFUCKER!" - -- void $ callService @RpcChannelQuery caller () - -- >>= orThrowUser "can't query rpc" - -- liftIO $ exitSuccess + void $ waitExitCode p data RpcChannelQuery @@ -198,7 +191,7 @@ data RpcChannelQuery type BrowserPluginAPI = '[ RpcChannelQuery ] -- API endpoint definition -type instance Input RpcChannelQuery = () +type instance Input RpcChannelQuery = [(Text,Text)] type instance Output RpcChannelQuery = Maybe ByteString class HasOracleEnv m where @@ -206,37 +199,56 @@ class HasOracleEnv m where -- API handler instance (MonadUnliftIO m, HasOracleEnv m) => HandleMethod m RpcChannelQuery where - handleMethod _ = do + handleMethod args' = do env <- getOracleEnv - -- let chan = _refchanId env - -- let rchanAPI = _refchanAPI env - -- let sto = _storage env + let args = HM.fromList args' - withOracleEnv env do - items <- withState $ select_ @_ @(HashVal, Text, Text) [qc| + case HM.lookup "METHOD" args of + Just "debug" -> listEnv args + Just "list-entries" -> listEntries args + Nothing -> listEntries args + _ -> pure mempty - SELECT - lwwref, - name, - brief - FROM ( - SELECT - lwwref, - name, - brief, - ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC) as rn - FROM gitrepofact - ) as s0 - WHERE rn = 1; + where + listEnv args = do + pure $ Just $ A.encodePretty args - |] + listEntries args = do + env <- getOracleEnv + withOracleEnv env do + items <- withState $ select_ @_ @(HashVal, Text, Text) [qc| - let root = object [ "rows" .= items - , "desc" .= [ "entity", "name", "brief" ] - ] + SELECT + lwwref, + name, + brief + FROM ( + SELECT + lwwref, + name, + brief, + ROW_NUMBER() OVER (PARTITION BY lwwref ORDER BY lwwseq DESC) as rn + FROM gitrepofact + ) as s0 + WHERE rn = 1; - pure $ Just $ A.encodePretty root + |] + + case HM.lookup "OUTPUT" args of + Just "html" -> formatHtml args items + Just "json" -> formatJson items + _ -> formatJson items + + formatJson items = do + let root = object [ "rows" .= items + , "desc" .= [ "entity", "name", "brief" ] + ] + + pure $ Just $ A.encodePretty root + + formatHtml args items = do + renderEntries args items <&> Just -- Codec for protocol instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where @@ -270,10 +282,12 @@ runPipe = do void $ ContT $ bracket (async $ runMessagingPipe server) cancel - void $ ContT $ withAsync $ forever do - debug $ yellow "updateState" - updateState - pause @'Seconds 60 + void $ ContT $ withAsync $ do + pause @'Seconds 10 + forever do + debug $ yellow "updateState" + updateState + pause @'Seconds 60 -- make server protocol responder serv <- ContT $ withAsync $ flip runReaderT server do @@ -282,12 +296,10 @@ runPipe = do ] fix \next -> do - -- debug $ red "YAYAYAYA" done1 <- hIsClosed stdin done2 <- hIsClosed stdout done3 <- hIsEOF stdin let done = done1 || done2 || done3 - debug $ red "DONE:" <+> pretty done unless done (pause @'Seconds 0.01 >> next) updateState :: MonadUnliftIO m => Oracle m () 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 60e830a2..845785da 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 @@ -59,6 +59,7 @@ newtype GitRepoKey = GitRepoKey (LWWRefKey HBS2Basic) newtype HashVal = HashVal HashRef deriving stock Generic + deriving newtype (Pretty,Show) instance ToJSON HashVal where toJSON (HashVal x) = toJSON (show $ pretty x) diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index b5209011..a4a61499 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -178,12 +178,16 @@ library hbs2-git-oracle-oracle-lib HBS2.Git.Oracle.Run HBS2.Git.Oracle.State HBS2.Git.Oracle.Facts + HBS2.Git.Oracle.Html + DBPipe.SQLite.Types DBPipe.SQLite.Generic build-depends: base, hbs2-git , base16-bytestring , binary + , lucid + , pandoc == 3.1.12.3 , unix -- FIXME: ASAP-remove , sqlite-simple