wip

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -4,9 +4,9 @@
 module Main where
 
 import HBS2.Git.DashBoard.Prelude
-import HBS2.System.Dir
 
 import HBS2.Net.Messaging.Unix
+import HBS2.System.Dir
 import HBS2.OrDie
 import HBS2.Polling
 
@@ -31,12 +31,14 @@ import Network.Wai.Middleware.Static hiding ((<|>))
 import Network.Wai.Middleware.StaticEmbedded as E
 import Network.Wai.Middleware.RequestLogger
 import Web.Scotty.Trans
-import System.Directory
 import Control.Monad.Except
 import System.Random
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Control.Concurrent.STM (flushTQueue)
+import System.FilePath
+import System.Process.Typed
+import System.Directory (XdgDirectory(..),getXdgDirectory)
 
 
 configParser :: DashBoardPerks m => Parser (m ())
@@ -228,12 +230,12 @@ updateIndexPeriodially = do
   flip runContT pure do
 
     void $ ContT $ withAsync $ forever do
-      _ <- atomically $ peekTQueue changes >> flushTQueue changes
+      rs <- atomically $ peekTQueue changes >> flushTQueue changes
       addJob (withDashBoardEnv env updateIndex)
       pause @'Seconds 30
 
     lift do
-      polling (Polling 10 10) rlogs $ \r -> do
+      polling (Polling 1 10) rlogs $ \r -> do
 
         debug $ yellow "POLL REFLOG" <+> pretty r
 
@@ -249,9 +251,23 @@ updateIndexPeriodially = do
             atomically $ modifyTVar cached (HM.insert r x)
             atomically $ writeTQueue changes r
 
-        delay <- liftIO $ randomRIO (0.5,10)
+            flip runContT pure $ callCC $ \exit -> do
-        pause (TimeoutSec (realToFrac delay))
 
+              lww <- lift (selectLwwByRefLog (RepoRefLog r))
+                       >>= maybe (exit ()) pure
+
+              dir <- asks (view dataDir) <&> (</> (show $ pretty lww))
+
+              here <- doesDirectoryExist dir
+
+              unless here do
+                debug $ red "INIT DATA DIR" <+> pretty dir
+                mkdir dir
+                void $ runProcess $ shell [qc|git --git-dir {dir} init --bare|]
+
+              let cmd = [qc|git --git-dir {dir} hbs2 import {show $ pretty lww}|]
+              debug $ red "SYNC" <+> pretty cmd
+              void $ runProcess $ shell cmd
 
 main :: IO ()
 main = do

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -410,6 +410,12 @@ insertRepoHead lww lwwseq rlog tx rf rh = do
 
   pure ()
 
+-- FIXME: what-if-two-repo-shares-one-reflog?
+selectLwwByRefLog :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoRefLog -> m (Maybe RepoLww)
+selectLwwByRefLog rlog  = withState do
+  select [qc|select lww from repolistview where reflog = ?|] (Only rlog)
+    <&> listToMaybe . fmap fromOnly
+
 selectRefLogs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoRefLog]
 selectRefLogs = withState do
   select_ [qc|select distinct(reflog) from repolistview|] <&> fmap fromOnly

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
+{-# Language TemplateHaskell #-}
 module HBS2.Git.DashBoard.Types
   ( module HBS2.Git.DashBoard.Types
   , module HBS2.Git.Data.Tx.Index
@@ -14,6 +15,8 @@ import HBS2.Net.Messaging.Unix
 
 import DBPipe.SQLite
 
+import System.FilePath
+
 data HttpPortOpt
 
 data DevelopAssetsOpt
@@ -44,9 +47,12 @@ data DashBoardEnv =
   , _sto            :: AnyStorage
   , _dashBoardConf  :: TVar [Syntax C]
   , _db             :: DBPipeEnv
+  , _dataDir        :: FilePath
   , _pipeline       :: TQueue (IO ())
   }
 
+makeLenses 'DashBoardEnv
+
 type DashBoardPerks m = MonadUnliftIO m
 
 newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a }
@@ -74,9 +80,11 @@ newDashBoardEnv :: MonadIO m
                 -> AnyStorage
                 -> m DashBoardEnv
 newDashBoardEnv cfg dbFile peer rlog rchan lww sto  = do
+  let ddir = takeDirectory dbFile
   DashBoardEnv peer rlog rchan lww sto
         <$> newTVarIO cfg
         <*> newDBPipeEnv dbPipeOptsDef dbFile
+        <*> pure ddir
         <*> newTQueueIO
 
 withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a