mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
4a165a9ec9
commit
8e61ded45c
|
|
@ -22,8 +22,9 @@ import HBS2.Git.Web.Html.Root
|
|||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
||||
import Lucid (renderTextT,HtmlT(..),toHtml)
|
||||
import Options.Applicative as O
|
||||
import Data.Either
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Lazy qualified as LT
|
||||
|
|
@ -42,32 +43,8 @@ import System.FilePath
|
|||
import System.Process.Typed
|
||||
import System.Directory (XdgDirectory(..),getXdgDirectory)
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
|
||||
|
||||
configParser :: DashBoardPerks m => Parser (m ())
|
||||
configParser = do
|
||||
opts <- RunDashBoardOpts <$> optional (strOption
|
||||
( long "config"
|
||||
<> short 'c'
|
||||
<> metavar "FILEPATH"
|
||||
<> help "Path to the configuration file"
|
||||
<> completer (bashCompleter "file")
|
||||
))
|
||||
|
||||
cmd <- subparser
|
||||
( command "web" (O.info pRunWeb (progDesc "Run the web interface"))
|
||||
<> command "index" (O.info pRunIndex (progDesc "update index"))
|
||||
)
|
||||
|
||||
pure $ cmd opts
|
||||
|
||||
|
||||
pRunWeb :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
|
||||
pRunWeb = pure $ \x -> runDashBoardM x runScotty
|
||||
|
||||
pRunIndex :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
|
||||
pRunIndex = pure $ \x -> runDashBoardM x do
|
||||
updateIndex
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
|
||||
{- HLINT ignore "Eta reduce" -}
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
|
@ -76,31 +53,31 @@ getRPC :: Monad m => HasConf m => m (Maybe FilePath)
|
|||
getRPC = pure Nothing
|
||||
|
||||
|
||||
runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a
|
||||
runDashBoardM cli m = do
|
||||
hbs2_git_dashboard :: FilePath
|
||||
hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||
|
||||
readConfig :: DashBoardPerks m => m [Syntax C]
|
||||
readConfig = do
|
||||
|
||||
let hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||
xdgConf <- liftIO $ getXdgDirectory XdgConfig hbs2_git_dashboard
|
||||
xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
|
||||
|
||||
let cliConfPath = cli & configPath
|
||||
|
||||
let confPath = fromMaybe xdgConf cliConfPath
|
||||
let confPath = xdgConf
|
||||
let confFile = confPath </> "config"
|
||||
|
||||
touch confFile
|
||||
|
||||
runExceptT (liftIO $ readFile confFile)
|
||||
<&> fromRight mempty
|
||||
<&> parseTop
|
||||
<&> fromRight mempty
|
||||
|
||||
runDashBoardM :: DashBoardPerks m => DashBoardM m a -> m a
|
||||
runDashBoardM m = do
|
||||
|
||||
xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
|
||||
|
||||
let dbFile = xdgData </> "state.db"
|
||||
|
||||
when (isNothing cliConfPath) do
|
||||
touch confFile
|
||||
|
||||
conf <- runExceptT (liftIO $ readFile confFile)
|
||||
<&> fromRight mempty
|
||||
<&> parseTop
|
||||
<&> fromRight mempty
|
||||
|
||||
liftIO $ print (pretty conf)
|
||||
|
||||
-- FIXME: unix-socket-from-config
|
||||
soname <- detectRPC `orDie` "hbs2-peer rpc not found"
|
||||
|
||||
|
|
@ -141,7 +118,6 @@ runDashBoardM cli m = do
|
|||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
env <- newDashBoardEnv
|
||||
conf
|
||||
dbFile
|
||||
peerAPI
|
||||
refLogAPI
|
||||
|
|
@ -174,13 +150,11 @@ orFall a mb = ContT $ maybe1 mb a
|
|||
renderHtml :: forall m a . MonadIO m => HtmlT (ActionT m) a -> ActionT m ()
|
||||
renderHtml m = renderTextT m >>= html
|
||||
|
||||
runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) ()
|
||||
runDashboardWeb wo = do
|
||||
runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) ()
|
||||
runDashboardWeb WebOptions{..} = do
|
||||
middleware logStdout
|
||||
|
||||
let assets = _assetsOverride wo
|
||||
|
||||
case assets of
|
||||
case _assetsOverride of
|
||||
Nothing -> do
|
||||
middleware (E.static assetsDir)
|
||||
Just f -> do
|
||||
|
|
@ -327,15 +301,13 @@ runDashboardWeb wo = do
|
|||
|
||||
runScotty :: DashBoardPerks m => DashBoardM m ()
|
||||
runScotty = do
|
||||
pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090
|
||||
wo <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions
|
||||
pno <- getHttpPortNumber
|
||||
wo <- WebOptions <$> getDevAssets
|
||||
|
||||
env <- ask
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
void $ ContT $ withAsync updateIndexPeriodially
|
||||
|
||||
scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
|
||||
|
||||
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
||||
|
|
@ -395,14 +367,57 @@ updateIndexPeriodially = do
|
|||
|
||||
lift $ buildCommitTreeIndex (coerce lww)
|
||||
|
||||
quit :: DashBoardPerks m => m ()
|
||||
quit = liftIO exitSuccess
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
execParser opts & join
|
||||
where
|
||||
opts = O.info (configParser <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "hbs2-git-dashboard"
|
||||
<> O.header "hbs2-git-dashboard" )
|
||||
argz <- getArgs
|
||||
cli <- parseTop (unlines $ unwords <$> splitForms argz)
|
||||
& either (error.show) pure
|
||||
|
||||
conf <- readConfig
|
||||
|
||||
let dict = makeDict @C do
|
||||
|
||||
-- TODO: write-man-entries
|
||||
|
||||
entry $ bindMatch "--help" $ nil_ $ \case
|
||||
HelpEntryBound what -> do
|
||||
helpEntry what
|
||||
quit
|
||||
|
||||
[StringLike s] -> helpList False (Just s) >> quit
|
||||
|
||||
_ -> helpList False Nothing >> quit
|
||||
|
||||
entry $ bindMatch "develop-assets" $ nil_ \case
|
||||
[StringLike s] -> do
|
||||
pure ()
|
||||
|
||||
_ -> none
|
||||
|
||||
brief "allows fixme for given reflog" $
|
||||
args [arg "public-key" "reflog"] $
|
||||
examples [qc|
|
||||
fixme-allow BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP
|
||||
|]
|
||||
$ entry $ bindMatch "fixme-allow" $ nil_ \case
|
||||
[SignPubKeyLike what] -> do
|
||||
lift $ insertFixmeAllowed (RepoRefLog (RefLogKey what))
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "port" $ nil_ \case
|
||||
[LitIntVal n] -> do
|
||||
tp <- lift $ asks _dashBoardHttpPort
|
||||
atomically $ writeTVar tp (Just (fromIntegral n))
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "web" $ nil_ $ const do
|
||||
lift runScotty
|
||||
|
||||
void $ runDashBoardM $ run dict (conf <> cli)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ import DBPipe.SQLite qualified as S
|
|||
import DBPipe.SQLite.Generic as G
|
||||
|
||||
|
||||
import Data.Aeson as Aeson
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Lucid.Base
|
||||
|
|
@ -108,6 +109,16 @@ evolveDB = do
|
|||
createRepoCommitTable
|
||||
createForksTable
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists object
|
||||
( o text not null
|
||||
, w integer not null
|
||||
, k text not null
|
||||
, v text not null
|
||||
, nonce text null
|
||||
, primary key (o,k)
|
||||
)
|
||||
|]
|
||||
|
||||
instance ToField GitHash where
|
||||
toField x = toField $ show $ pretty x
|
||||
|
|
@ -182,7 +193,7 @@ newtype RepoHeadSeq = RepoHeadSeq Word64
|
|||
|
||||
newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
deriving newtype (ToField,FromField,Pretty,Serialise)
|
||||
|
||||
newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
|
||||
deriving stock (Generic)
|
||||
|
|
@ -272,10 +283,11 @@ asRefChan = \case
|
|||
LitStrVal s -> fromStringMay @MyRefChan (Text.unpack s)
|
||||
_ -> Nothing
|
||||
|
||||
getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
|
||||
getIndexEntries :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [MyRefChan]
|
||||
getIndexEntries = do
|
||||
conf <- getConf
|
||||
pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
||||
pure mempty
|
||||
-- conf <- getConf
|
||||
-- pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
||||
|
||||
|
||||
data NiceTS = NiceTS
|
||||
|
|
@ -872,3 +884,83 @@ gitShowRefs what = do
|
|||
pure $ view repoHeadRefs hd
|
||||
|
||||
|
||||
insertOWKV :: (DashBoardPerks m, ToJSON a)
|
||||
=> Text
|
||||
-> Maybe Integer
|
||||
-> Text
|
||||
-> a
|
||||
-> DBPipeM m ()
|
||||
insertOWKV o w k v = do
|
||||
|
||||
let sql = [qc|
|
||||
|
||||
insert into object (o, w, k, v)
|
||||
values (?, ?, ?, cast (? as text))
|
||||
on conflict (o, k)
|
||||
do update set
|
||||
v = case
|
||||
when excluded.w > object.w then excluded.v
|
||||
else object.v
|
||||
end,
|
||||
w = case
|
||||
when excluded.w > object.w then excluded.w
|
||||
else object.w
|
||||
end
|
||||
|]
|
||||
|
||||
t <- maybe1 w (round <$> liftIO getPOSIXTime) pure
|
||||
|
||||
S.insert sql (o,t,k,Aeson.encode v)
|
||||
|
||||
|
||||
insertOption :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
, Pretty a
|
||||
, Serialise a)
|
||||
=> Text
|
||||
-> a
|
||||
-> m ()
|
||||
insertOption key value = do
|
||||
w <- liftIO getPOSIXTime <&> fromIntegral . round
|
||||
let o = hashObject @HbSync (serialise ("option", key)) & pretty & show
|
||||
let v = show $ pretty v
|
||||
withState $ transactional do
|
||||
insertOWKV (fromString o) (Just w) "$type" "option"
|
||||
insertOWKV (fromString o) (Just w) "name" key
|
||||
insertOWKV (fromString o) (Just w) "value" (fromString v)
|
||||
|
||||
|
||||
insertFixmeAllowed :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> RepoRefLog
|
||||
-> m ()
|
||||
insertFixmeAllowed reflog = do
|
||||
let o = hashObject @HbSync (serialise ("fixme-allowed", reflog)) & pretty & show
|
||||
let v = show $ pretty reflog
|
||||
withState $ transactional do
|
||||
insertOWKV (fromString o) mzero "$type" "fixme-allowed"
|
||||
insertOWKV (fromString o) mzero "value" v
|
||||
|
||||
checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoRefLog
|
||||
-> m Bool
|
||||
|
||||
checkFixmeAllowed r = do
|
||||
|
||||
let sql = [qc|
|
||||
with
|
||||
s1 as (
|
||||
select o from object where k = '$type' and json_extract(v, '$') = 'fixme-allowed'
|
||||
)
|
||||
select 1
|
||||
from s1 join object o on s1.o = o.o
|
||||
where o.k = 'value' and json_extract(o.v, '$') = ?
|
||||
limit 1;
|
||||
|]
|
||||
|
||||
w <- withState $ select @(Only Int) sql (Only r)
|
||||
|
||||
pure $ not $ List.null w
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import HBS2.Git.DashBoard.Types
|
|||
import HBS2.Git.DashBoard.State.Index.Channels
|
||||
import HBS2.Git.DashBoard.State.Index.Peer
|
||||
|
||||
updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndex = do
|
||||
debug "updateIndex"
|
||||
updateIndexFromPeer
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import DBPipe.SQLite.Generic as G
|
|||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
updateIndexFromChannels :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromChannels :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromChannels = do
|
||||
debug "updateIndexChannels"
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import Streaming.Prelude qualified as S
|
|||
|
||||
seconds = TimeoutSec
|
||||
|
||||
updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromPeer = do
|
||||
debug "updateIndexFromPeer"
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,8 @@ import HBS2.System.Dir
|
|||
|
||||
import System.FilePath
|
||||
|
||||
import Data.Word
|
||||
|
||||
data HttpPortOpt
|
||||
|
||||
data DevelopAssetsOpt
|
||||
|
|
@ -42,15 +44,16 @@ instance Semigroup RunDashBoardOpts where
|
|||
|
||||
data DashBoardEnv =
|
||||
DashBoardEnv
|
||||
{ _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _refChanAPI :: ServiceCaller RefChanAPI UNIX
|
||||
, _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _sto :: AnyStorage
|
||||
, _dashBoardConf :: TVar [Syntax C]
|
||||
, _db :: DBPipeEnv
|
||||
, _dataDir :: FilePath
|
||||
, _pipeline :: TQueue (IO ())
|
||||
{ _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _refChanAPI :: ServiceCaller RefChanAPI UNIX
|
||||
, _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _sto :: AnyStorage
|
||||
, _dataDir :: FilePath
|
||||
, _db :: DBPipeEnv
|
||||
, _pipeline :: TQueue (IO ())
|
||||
, _dashBoardHttpPort :: TVar (Maybe Word16)
|
||||
, _dashBoardDevAssets :: TVar (Maybe FilePath)
|
||||
}
|
||||
|
||||
makeLenses 'DashBoardEnv
|
||||
|
|
@ -71,26 +74,32 @@ newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a
|
|||
, MonadReader DashBoardEnv
|
||||
)
|
||||
|
||||
instance (MonadIO m, Monad m, MonadReader DashBoardEnv m) => HasConf m where
|
||||
getConf = do
|
||||
asks _dashBoardConf >>= readTVarIO
|
||||
|
||||
newDashBoardEnv :: MonadIO m
|
||||
=> [Syntax C]
|
||||
-> FilePath
|
||||
=> FilePath
|
||||
-> ServiceCaller PeerAPI UNIX
|
||||
-> ServiceCaller RefLogAPI UNIX
|
||||
-> ServiceCaller RefChanAPI UNIX
|
||||
-> ServiceCaller LWWRefAPI UNIX
|
||||
-> AnyStorage
|
||||
-> m DashBoardEnv
|
||||
newDashBoardEnv cfg dbFile peer rlog rchan lww sto = do
|
||||
newDashBoardEnv dbFile peer rlog rchan lww sto = do
|
||||
let ddir = takeDirectory dbFile
|
||||
DashBoardEnv peer rlog rchan lww sto
|
||||
<$> newTVarIO cfg
|
||||
<*> newDBPipeEnv dbPipeOptsDef dbFile
|
||||
<*> pure ddir
|
||||
DashBoardEnv peer rlog rchan lww sto ddir
|
||||
<$> newDBPipeEnv dbPipeOptsDef dbFile
|
||||
<*> newTQueueIO
|
||||
<*> newTVarIO (Just 8911)
|
||||
<*> newTVarIO Nothing
|
||||
|
||||
getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
|
||||
getHttpPortNumber = do
|
||||
asks _dashBoardHttpPort
|
||||
>>= readTVarIO
|
||||
<&> fromIntegral . fromMaybe 8911
|
||||
|
||||
getDevAssets :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m (Maybe FilePath)
|
||||
getDevAssets = do
|
||||
asks _dashBoardDevAssets
|
||||
>>= readTVarIO
|
||||
|
||||
withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
|
||||
withDashBoardEnv env m = runReaderT (fromDashBoardM m) env
|
||||
|
|
|
|||
|
|
@ -943,7 +943,8 @@ repoPage tab lww params = rootPage do
|
|||
let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
|
||||
let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
|
||||
|
||||
let fixme = headMay [ x | FixmeRefChanP x <- meta ]
|
||||
allowed <- lift $ checkFixmeAllowed (RepoRefLog (coerce lww))
|
||||
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
|
||||
|
||||
debug $ red "META" <+> pretty meta
|
||||
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@ common shared-properties
|
|||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
, aeson
|
||||
, attoparsec
|
||||
, atomic-write
|
||||
, bytestring
|
||||
|
|
|
|||
Loading…
Reference in New Issue