From 5b80bc3d0d79e67b511419b3636c3f54b823a72f Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 27 Sep 2024 07:50:03 +0300 Subject: [PATCH] wip --- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 182 +++++++++++++++--- .../src/HBS2/Git/DashBoard/State.hs | 26 +++ .../src/HBS2/Git/DashBoard/Types.hs | 43 ++++- hbs2-git/hbs2-git.cabal | 1 + 4 files changed, 221 insertions(+), 31 deletions(-) diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index c8acf6f3..4b9fb479 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -6,10 +6,14 @@ module Main where import HBS2.Git.DashBoard.Prelude import HBS2.Net.Messaging.Unix +import HBS2.Net.Proto +import HBS2.Net.Proto.Service + import HBS2.System.Dir import HBS2.OrDie import HBS2.Polling +import HBS2.Actors.Peer import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient @@ -29,6 +33,7 @@ import Data.Either import Data.Text qualified as Text import Data.Text.Lazy qualified as LT import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy (ByteString) import Network.HTTP.Types.Status import Network.Wai.Middleware.Static hiding ((<|>)) import Network.Wai.Middleware.StaticEmbedded as E @@ -45,6 +50,7 @@ import System.Directory (XdgDirectory(..),getXdgDirectory) import Data.ByteString.Lazy.Char8 qualified as LBS8 import System.Environment import System.Exit +import System.IO.Temp {- HLINT ignore "Eta reduce" -} {- HLINT ignore "Functor law" -} @@ -52,9 +58,38 @@ import System.Exit getRPC :: Monad m => HasConf m => m (Maybe FilePath) getRPC = pure Nothing +data CallRPC +data PingRPC -hbs2_git_dashboard :: FilePath -hbs2_git_dashboard = "hbs2-git-dashboard" +type MyRPC = '[ PingRPC, CallRPC ] + +instance HasProtocol UNIX (ServiceProto MyRPC UNIX) where + type instance ProtocolId (ServiceProto MyRPC UNIX) = 0xFAFABEBE + type instance Encoded UNIX = ByteString + 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 + +class HasDashBoardEnv m where + getDashBoardEnv :: m DashBoardEnv + +instance (MonadIO m) => HandleMethod m CallRPC where + handleMethod n = do + debug $ "RPC CALL" <+> pretty n + pure "" + +instance (MonadIO m, HasDashBoardEnv m) => HandleMethod m PingRPC where + handleMethod _ = do + debug $ "RPC PING" + pure "pong" readConfig :: DashBoardPerks m => m [Syntax C] readConfig = do @@ -76,6 +111,7 @@ runDashBoardM m = do xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard + let dataDir = xdgData let dbFile = xdgData "state.db" -- FIXME: unix-socket-from-config @@ -118,7 +154,7 @@ runDashBoardM m = do void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client env <- newDashBoardEnv - dbFile + dataDir peerAPI refLogAPI refChanAPI @@ -130,7 +166,7 @@ runDashBoardM m = do forever do liftIO (atomically $ readTQueue q) & liftIO . join - lift $ withDashBoardEnv env (withState evolveDB >> m) + lift $ withDashBoardEnv env m `finally` do setLoggingOff @DEBUG setLoggingOff @INFO @@ -306,10 +342,75 @@ runScotty = do env <- ask + notice "evolving db" + withState evolveDB + + notice "running config" + conf <- readConfig + + run theDict conf + flip runContT pure do void $ ContT $ withAsync updateIndexPeriodially + void $ ContT $ withAsync runRPC scottyT pno (withDashBoardEnv env) (runDashboardWeb wo) + +data RPCEnv = RPCEnv + { rpcMessaging :: MessagingUnix + , dashBoardEnv :: DashBoardEnv + } + +newtype RunRPCM m a = RunRPCM { fromRunRPC :: ReaderT RPCEnv m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadTrans + , MonadReader RPCEnv + ) +runRPCMonad :: DashBoardEnv -> MessagingUnix -> RunRPCM m a -> m a +runRPCMonad env s m = runReaderT (fromRunRPC m) (RPCEnv s env) + +instance HasFabriq UNIX (RunRPCM IO) where + getFabriq = asks (Fabriq . rpcMessaging) + +instance HasOwnPeer UNIX (RunRPCM IO) where + ownPeer = asks ( msgUnixSelf . rpcMessaging) + +instance HasDashBoardEnv (ResponseM UNIX (RunRPCM IO)) where + getDashBoardEnv = lift $ asks dashBoardEnv + +runRPC :: DashBoardPerks m => DashBoardM m () +runRPC = do + debug $ green "runRPC loop" + + env <- ask + + liftIO $ flip runContT pure do + + soname <- ContT $ bracket (liftIO $ emptySystemTempFile "hbs2-git-dashboard-socket") rm + + liftIO $ withDashBoardEnv env do + setRPCSocket soname + + void $ ContT $ bracket (pure soname) (\_ -> withDashBoardEnv env $ delRPCSocket) + + notice $ green "rpc-socket" <+> pretty soname + + server <- newMessagingUnix True 1.0 soname + + m1 <- ContT $ withAsync (runMessagingUnix server) + + p1 <- ContT $ withAsync $ runRPCMonad env server do + runProto @UNIX + [ makeResponse (makeServer @MyRPC) + ] + + void $ waitAnyCatchCancel [m1,p1] + + updateIndexPeriodially :: DashBoardPerks m => DashBoardM m () updateIndexPeriodially = do @@ -328,7 +429,7 @@ updateIndexPeriodially = do void $ ContT $ withAsync $ forever do rs <- atomically $ peekTQueue changes >> flushTQueue changes addJob (withDashBoardEnv env updateIndex) - pause @'Seconds 60 + pause @'Seconds 1 lift do polling (Polling 1 30) rlogs $ \r -> do @@ -370,27 +471,36 @@ updateIndexPeriodially = do quit :: DashBoardPerks m => m () quit = liftIO exitSuccess +withMyRPCClient :: ( MonadUnliftIO m ) + -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m) + => FilePath -> (ServiceCaller MyRPC UNIX -> IO b) -> m b +withMyRPCClient soname m = do + liftIO do + client <- newMessagingUnix False 1.0 soname + flip runContT pure do + mess <- ContT $ withAsync $ runMessagingUnix client + caller <- makeServiceCaller @MyRPC @UNIX (msgUnixSelf client) + p2 <- ContT $ withAsync $ runReaderT (runServiceClient caller) client + void $ ContT $ bracket none (const $ cancel mess) + void $ ContT $ bracket none (const $ cancel p2) + liftIO $ m caller -main :: IO () -main = do - argz <- getArgs - cli <- parseTop (unlines $ unwords <$> splitForms argz) - & either (error.show) pure - conf <- readConfig - - let dict = makeDict @C do - - -- TODO: write-man-entries - - myHelpEntry - fixmeAllowEntry - fixmeAllowDropEntry - webEntry - portEntry - developAssetsEntry - - void $ runDashBoardM $ run dict (conf <> cli) +theDict :: forall m . ( MonadIO m + , MonadUnliftIO m + -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m + ) => Dict C (DashBoardM m) +theDict = do + makeDict @C do + -- TODO: write-man-entries + myHelpEntry + fixmeAllowEntry + fixmeAllowDropEntry + webEntry + portEntry + developAssetsEntry + getRpcSocketEntry + rpcPingEntry where @@ -416,7 +526,6 @@ main = do _ -> throwIO $ BadFormException @C nil - fixmeAllowDropEntry = do brief "drop all allowed fixme records" $ examples [qc| @@ -449,3 +558,26 @@ main = do _ -> none + getRpcSocketEntry = do + entry $ bindMatch "rpc:socket" $ nil_ $ const do + lift getRPCSocket >>= liftIO . maybe exitFailure putStr + + rpcPingEntry = do + entry $ bindMatch "ping" $ nil_ $ const $ lift do + so <- getRPCSocket >>= orThrowUser "rpc socket down" + withMyRPCClient so $ \caller -> do + what <- callService @PingRPC caller () + print what + +main :: IO () +main = do + argz <- getArgs + cli <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure + + let dict = theDict + + void $ runDashBoardM $ do + run dict cli + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index 79cfd2e8..61868c38 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -19,6 +19,7 @@ import HBS2.Git.Data.RepoHead import HBS2.Git.Data.Tx.Git import HBS2.Git.Local import HBS2.Git.Local.CLI +import HBS2.System.Dir import DBPipe.SQLite hiding (insert) import DBPipe.SQLite qualified as S @@ -36,6 +37,7 @@ import Data.List qualified as List import Data.Map qualified as Map import Data.Map (Map) import System.FilePath +import System.Directory import Skylighting.Core qualified as Sky import Skylighting qualified as Sky @@ -979,4 +981,28 @@ checkFixmeAllowed r = do pure $ not $ List.null w +rpcSocketKey :: String +rpcSocketKey = + hashObject @HbSync (serialise "rpc-socket-name") & pretty & show + +rpcSocketFile :: MonadUnliftIO m => m FilePath +rpcSocketFile = do + dir <- liftIO $ getXdgDirectory XdgState hbs2_git_dashboard + pure $ dir rpcSocketKey + +setRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m () +setRPCSocket soname = do + soFile <- rpcSocketFile + touch soFile + liftIO $ writeFile soFile soname + +delRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m () +delRPCSocket = do + rpcSocketFile >>= rm + +getRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m (Maybe FilePath) +getRPCSocket = do + soFile <- rpcSocketFile + liftIO $ try @_ @IOError (readFile soFile) + <&> either (const Nothing) Just diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs index 66a168e5..de3a0cfc 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs @@ -50,7 +50,7 @@ data DashBoardEnv = , _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX , _sto :: AnyStorage , _dataDir :: FilePath - , _db :: DBPipeEnv + , _db :: TVar (Maybe DBPipeEnv) , _pipeline :: TQueue (IO ()) , _dashBoardHttpPort :: TVar (Maybe Word16) , _dashBoardDevAssets :: TVar (Maybe FilePath) @@ -82,10 +82,9 @@ newDashBoardEnv :: MonadIO m -> ServiceCaller LWWRefAPI UNIX -> AnyStorage -> m DashBoardEnv -newDashBoardEnv dbFile peer rlog rchan lww sto = do - let ddir = takeDirectory dbFile +newDashBoardEnv ddir peer rlog rchan lww sto = do DashBoardEnv peer rlog rchan lww sto ddir - <$> newDBPipeEnv dbPipeOptsDef dbFile + <$> newTVarIO mzero <*> newTQueueIO <*> newTVarIO (Just 8911) <*> newTVarIO Nothing @@ -104,9 +103,38 @@ getDevAssets = do withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a withDashBoardEnv env m = runReaderT (fromDashBoardM m) env -withState :: (MonadIO m, MonadReader DashBoardEnv m) => DBPipeM m a -> m a +data StateFSM m a = + S0 + | SConnect + +withState :: forall m a . (MonadIO m, MonadReader DashBoardEnv m) => DBPipeM m a -> m a withState f = do - asks _db >>= flip withDB f + + dbFile <- asks _dataDir <&> ( "state.db") + tdb <- asks _db + + flip fix S0 $ \next -> \case + + SConnect -> do + notice $ yellow "connecting to db" + dbe <- liftIO $ try @_ @SomeException (newDBPipeEnv dbPipeOptsDef dbFile) + + case dbe of + Right e -> do + atomically $ writeTVar tdb (Just e) + next S0 + + Left what -> do + err $ viaShow what + pause @Seconds 1 + next SConnect + + S0 -> do + dbe <- readTVarIO tdb + + case dbe of + Just d -> withDB d f + Nothing -> next SConnect addJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => IO () -> m () @@ -114,3 +142,6 @@ addJob f = do q <- asks _pipeline atomically $ writeTQueue q f +hbs2_git_dashboard :: FilePath +hbs2_git_dashboard = "hbs2-git-dashboard" + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 3240f477..61bf6a7e 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -179,6 +179,7 @@ executable hbs2-git-dashboard , skylighting-core , skylighting-lucid , scotty >= 0.21 + , temporary hs-source-dirs: hbs2-git-dashboard