wip

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
+type MyRPC = '[ PingRPC, CallRPC ]
-hbs2_git_dashboard = "hbs2-git-dashboard"
+
+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
+theDict :: forall m . ( MonadIO m
-
+                      , MonadUnliftIO m
-  let dict = makeDict @C do
+                      -- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m
-
+                      ) => Dict C (DashBoardM m)
-          -- TODO: write-man-entries
+theDict = do
-
+  makeDict @C do
-          myHelpEntry
+    -- TODO: write-man-entries
-          fixmeAllowEntry
+    myHelpEntry
-          fixmeAllowDropEntry
+    fixmeAllowEntry
-          webEntry
+    fixmeAllowDropEntry
-          portEntry
+    webEntry
-          developAssetsEntry
+    portEntry
-
+    developAssetsEntry
-  void $ runDashBoardM $ run dict (conf <> cli)
+    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
+
+

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
 

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
+newDashBoardEnv ddir peer rlog rchan lww sto  = do
-  let ddir = takeDirectory dbFile
   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"
+

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