mirror of https://github.com/voidlizard/hbs2
795 lines
24 KiB
Haskell
795 lines
24 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
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
|
|
|
|
import HBS2.Git.Web.Assets
|
|
import HBS2.Git.DashBoard.State
|
|
import HBS2.Git.DashBoard.State.Index
|
|
import HBS2.Git.DashBoard.State.Commits
|
|
import HBS2.Git.DashBoard.Types
|
|
import HBS2.Git.DashBoard.Fixme
|
|
import HBS2.Git.DashBoard.Manifest
|
|
import HBS2.Git.Web.Html.Root
|
|
import HBS2.Git.Web.Html.Issue
|
|
import HBS2.Git.Web.Html.Repo
|
|
import HBS2.Git.Web.Html.Fixme
|
|
import HBS2.Peer.CLI.Detect
|
|
|
|
import DBPipe.SQLite
|
|
|
|
import Data.Config.Suckless.Script
|
|
|
|
import Lucid (renderTextT,HtmlT(..),toHtml)
|
|
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
|
|
import Network.Wai.Middleware.RequestLogger
|
|
import Web.Scotty.Trans as Scotty
|
|
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)
|
|
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" -}
|
|
|
|
getRPC :: Monad m => HasConf m => m (Maybe FilePath)
|
|
getRPC = pure Nothing
|
|
|
|
data CallRPC
|
|
data PingRPC
|
|
data IndexNowRPC
|
|
|
|
type MyRPC = '[ PingRPC, IndexNowRPC, 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
|
|
|
|
type instance Input CallRPC = String
|
|
type instance Output CallRPC = String
|
|
|
|
type instance Input PingRPC = ()
|
|
type instance Output PingRPC = String
|
|
|
|
type instance Input IndexNowRPC = ()
|
|
type instance Output IndexNowRPC = ()
|
|
|
|
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"
|
|
|
|
instance (DashBoardPerks m, HasDashBoardEnv m) => HandleMethod m IndexNowRPC where
|
|
handleMethod _ = do
|
|
e <- getDashBoardEnv
|
|
debug $ "rpc: index:now"
|
|
withDashBoardEnv e $ addJob (liftIO $ withDashBoardEnv e updateIndex)
|
|
|
|
instance HasLimit (FromParams 'FixmeDomain [Param]) where
|
|
-- TODO: optimal-page-size
|
|
limit (FromParams p) = Just limits
|
|
where
|
|
pageSize = fromIntegral fixmePageSize
|
|
page = fromMaybe 0 $ headMay [ readDef 0 (Text.unpack n) | ("$page", n) <- p ]
|
|
offset = page
|
|
limits = (fromIntegral offset, fromIntegral pageSize)
|
|
|
|
instance HasPredicate (FromParams 'FixmeDomain [Param]) where
|
|
predicate (FromParams args) = do
|
|
flip fix seed $ \next -> \case
|
|
[] -> All
|
|
( clause : rest ) -> And clause (next rest)
|
|
|
|
where
|
|
seed = [ AttrLike a b | (a,b) <- args, a /= "$page" ]
|
|
|
|
readConfig :: DashBoardPerks m => m [Syntax C]
|
|
readConfig = do
|
|
|
|
xdgConf <- liftIO $ getXdgDirectory XdgConfig hbs2_git_dashboard
|
|
|
|
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 dataDir = xdgData
|
|
|
|
-- FIXME: unix-socket-from-config
|
|
soname <- detectRPC `orDie` "hbs2-peer rpc not found"
|
|
|
|
let errorPrefix = toStderr . logPrefix "[error] "
|
|
let warnPrefix = toStderr . logPrefix "[warn] "
|
|
let noticePrefix = toStderr . logPrefix ""
|
|
let debugPrefix = toStderr . logPrefix "[debug] "
|
|
|
|
setLogging @INFO defLog
|
|
setLogging @ERROR errorPrefix
|
|
setLogging @DEBUG debugPrefix
|
|
setLogging @WARN warnPrefix
|
|
setLogging @NOTICE noticePrefix
|
|
|
|
|
|
flip runContT pure do
|
|
|
|
|
|
client <- liftIO $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
|
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
|
|
|
void $ ContT $ withAsync $ runMessagingUnix client
|
|
|
|
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
|
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
|
refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
|
|
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
|
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
|
|
|
let sto = AnyStorage (StorageClient storageAPI)
|
|
|
|
let endpoints = [ Endpoint @UNIX peerAPI
|
|
, Endpoint @UNIX refLogAPI
|
|
, Endpoint @UNIX refChanAPI
|
|
, Endpoint @UNIX lwwAPI
|
|
, Endpoint @UNIX storageAPI
|
|
]
|
|
|
|
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
|
|
|
|
|
env <- newDashBoardEnv
|
|
dataDir
|
|
peerAPI
|
|
refLogAPI
|
|
refChanAPI
|
|
lwwAPI
|
|
sto
|
|
|
|
lift $ withDashBoardEnv env do
|
|
mkdir dataDir
|
|
notice "evolving db"
|
|
withState evolveDB
|
|
|
|
void $ ContT $ withAsync do
|
|
fix \next -> do
|
|
dbe' <- readTVarIO (_db env)
|
|
case dbe' of
|
|
Just dbe -> do
|
|
notice $ green "Aquired database!"
|
|
runPipe dbe
|
|
forever do
|
|
pause @'Seconds 30
|
|
|
|
Nothing -> do
|
|
pause @'Seconds 5
|
|
next
|
|
|
|
replicateM_ 2 do
|
|
ContT $ withAsync do
|
|
q <- withDashBoardEnv env $ asks _pipeline
|
|
forever do
|
|
liftIO (atomically $ readTQueue q) & liftIO . join
|
|
|
|
lift $ withDashBoardEnv env m
|
|
`finally` do
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @INFO
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
|
|
|
|
data WebOptions =
|
|
WebOptions
|
|
{ _assetsOverride :: Maybe FilePath
|
|
}
|
|
|
|
orFall :: m r -> Maybe a -> ContT r m a
|
|
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 WebOptions{..} = do
|
|
middleware logStdout
|
|
|
|
case _assetsOverride of
|
|
Nothing -> do
|
|
middleware (E.static assetsDir)
|
|
Just f -> do
|
|
middleware $ staticPolicy (noDots >-> addBase f)
|
|
|
|
get (routePattern RepoListPage) do
|
|
renderHtml dashboardRootPage
|
|
|
|
|
|
get "/:lww" do
|
|
lww <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
>>= orThrow (itemNotFound "repository key")
|
|
|
|
asksBaseUrl $ withBaseUrl $
|
|
redirect (LT.fromStrict $ toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
|
|
|
get (routePattern (RepoPage "tab" "lww")) do
|
|
lww <- captureParam @String "lww" <&> fromStringMay
|
|
>>= orThrow (itemNotFound "repository key")
|
|
|
|
tab <- captureParam @String "tab"
|
|
<&> fromStringMay
|
|
<&> fromMaybe (CommitsTab Nothing)
|
|
|
|
qp <- queryParams
|
|
|
|
renderHtml (repoPage tab lww qp)
|
|
|
|
get (routePattern (RepoManifest "lww")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
TopInfoBlock{..} <- lift $ getTopInfoBlock lww
|
|
lift $ html (LT.fromStrict manifest)
|
|
|
|
get (routePattern (RepoRefs "lww")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
|
|
-- setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|]
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
lift $ renderHtml (repoRefs lww)
|
|
|
|
get (routePattern (RepoTree "lww" "co" "hash")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
|
|
co' <- captureParam @String "co" <&> fromStringMay @GitHash
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
hash <- hash' & orFall (status status404)
|
|
co <- co' & orFall (status status404)
|
|
lift $ renderHtml (repoTree lww co hash)
|
|
|
|
get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
hash' <- captureParam @String "hash" <&> fromStringMay @GitHash
|
|
co' <- captureParam @String "co" <&> fromStringMay @GitHash
|
|
blob' <- captureParam @String "blob" <&> fromStringMay @GitHash
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
hash <- hash' & orFall (status status404)
|
|
co <- co' & orFall (status status404)
|
|
blobHash <- blob' & orFall (status status404)
|
|
|
|
blobInfo <- lift (selectBlobInfo (BlobHash blobHash))
|
|
>>= orFall (status status404)
|
|
|
|
lift $ renderHtml (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo)
|
|
|
|
get (routePattern (RepoSomeBlob "lww" "syntax" "blob")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
syn <- captureParamMaybe @Text "syntax" <&> fromMaybe "default"
|
|
blob' <- captureParam @String "blob" <&> fromStringMay @GitHash
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
blob <- blob' & orFall (status status404)
|
|
lift $ renderHtml (repoSomeBlob lww syn blob)
|
|
|
|
get (routePattern (RepoCommitDefault "lww" "hash")) (commitRoute RepoCommitSummary)
|
|
get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary)
|
|
get (routePattern (RepoCommitPatchQ "lww" "hash")) (commitRoute RepoCommitPatch)
|
|
|
|
get (routePattern (RepoForksHtmx "lww")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
lift $ renderHtml (repoForks lww)
|
|
-- lift $ renderHtml (toHtml $ show $ pretty lww)
|
|
|
|
get (routePattern (IssuePage "lww" "fixme")) do
|
|
|
|
r <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
f <- captureParam @String "fixme" <&> fromStringMay @FixmeKey
|
|
|
|
debug $ blue "AAAA" <+> pretty r <+> pretty f
|
|
|
|
flip runContT pure do
|
|
lww <- r & orFall (status status404)
|
|
fme <- f & orFall (status status404)
|
|
|
|
lift $ renderHtml (issuePage (RepoLww lww) fme)
|
|
|
|
get (routePattern (RepoFixmeHtmx mempty "lww")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
p <- queryParams
|
|
debug $ "FIXME: GET QUERY" <+> pretty p
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
lift $ renderHtml (repoFixme (FromParams @'FixmeDomain p) lww)
|
|
|
|
get (routePattern (RepoCommits "lww")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
|
|
let pred = mempty & set commitPredOffset 0
|
|
& set commitPredLimit 100
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
lift $ renderHtml (repoCommits lww (Right pred))
|
|
|
|
get (routePattern (RepoCommitsQ "lww" "off" "lim")) do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
|
off <- captureParam @Int "off"
|
|
lim <- captureParam @Int "lim"
|
|
|
|
let pred = mempty & set commitPredOffset off
|
|
& set commitPredLimit lim
|
|
|
|
flip runContT pure do
|
|
|
|
lww <- lwws' & orFall (status status404)
|
|
|
|
-- FIXME: this
|
|
referrer <- asksBaseUrl $ withBaseUrl $ lift (Scotty.header "Referer")
|
|
>>= orFall (redirect $ LT.fromStrict $ toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
|
|
|
lift $ renderHtml (repoCommits lww (Left pred))
|
|
|
|
-- "pages"
|
|
|
|
where
|
|
commitRoute style = do
|
|
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic)
|
|
co <- captureParam @String "hash" <&> fromStringMay @GitHash
|
|
|
|
referrer <- Scotty.header "Referer"
|
|
debug $ yellow "COMMIT-REFERRER" <+> pretty referrer
|
|
|
|
flip runContT pure do
|
|
lww <- lwws' & orFall (status status404)
|
|
hash <- co & orFall (status status404)
|
|
lift $ renderHtml (repoCommit style lww hash)
|
|
|
|
|
|
runScotty :: DashBoardPerks m => DashBoardM m ()
|
|
runScotty = do
|
|
|
|
env <- ask
|
|
|
|
notice "running config"
|
|
conf <- readConfig
|
|
|
|
run theDict conf
|
|
|
|
pno <- getHttpPortNumber
|
|
wo <- WebOptions <$> getDevAssets
|
|
|
|
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]
|
|
|
|
|
|
|
|
-- pure ()
|
|
|
|
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
|
updateIndexPeriodially = do
|
|
|
|
|
|
api <- asks _refLogAPI
|
|
|
|
env <- ask
|
|
|
|
changes <- newTQueueIO
|
|
|
|
-- queues <- newTVarIO ( mempty :: HashMap RepoLww (TQueue (IO ()) ) )
|
|
|
|
flip runContT pure do
|
|
|
|
lift $ addJob (withDashBoardEnv env updateIndex)
|
|
|
|
p1 <- ContT $ withAsync $ do
|
|
pause @'Seconds 30
|
|
forever do
|
|
rs <- atomically $ peekTQueue changes >> flushTQueue changes
|
|
addJob (withDashBoardEnv env updateIndex)
|
|
-- pause @'Seconds 1
|
|
|
|
p2 <- pollRepos changes
|
|
|
|
p3 <- pollFixmies
|
|
|
|
p4 <- pollRepoIndex
|
|
|
|
void $ waitAnyCatchCancel [p1,p2,p3,p4]
|
|
|
|
where
|
|
|
|
pollFixmies = do
|
|
|
|
env <- ask
|
|
|
|
api <- asks _refChanAPI
|
|
|
|
cached <- newTVarIO ( mempty :: HashMap MyRefChan HashRef )
|
|
|
|
let chans = selectRepoFixme
|
|
<&> fmap (,60)
|
|
|
|
ContT $ withAsync $ do
|
|
polling (Polling 10 30) chans $ \(l,r) -> do
|
|
debug $ yellow "POLL FIXME CHAN" <+> pretty (AsBase58 r)
|
|
|
|
void $ runMaybeT do
|
|
|
|
new <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) api (coerce r))
|
|
<&> join
|
|
>>= toMPlus
|
|
|
|
old <- readTVarIO cached <&> HM.lookup r
|
|
|
|
atomically $ modifyTVar cached (HM.insert r new)
|
|
|
|
when (Just new /= old) $ lift do
|
|
debug $ yellow "fixme refchan changed" <+> "run update" <+> pretty new
|
|
addJob do
|
|
-- TODO: this-is-not-100-percent-reliable
|
|
-- $workflow: backlog
|
|
-- откуда нам вообще знать, что там всё получилось?
|
|
void $ try @_ @SomeException (withDashBoardEnv env $ updateFixmeFor l r)
|
|
|
|
|
|
pollRepos changes = do
|
|
|
|
cached <- newTVarIO ( mempty :: HashMap MyRefLogKey HashRef )
|
|
|
|
api <- asks _refLogAPI
|
|
let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60)
|
|
|
|
ContT $ withAsync $ do
|
|
polling (Polling 10 30) rlogs $ \r -> do
|
|
|
|
debug $ yellow "POLL REFLOG" <+> pretty r
|
|
|
|
rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api (coerce r)
|
|
<&> join
|
|
|
|
old <- readTVarIO cached <&> HM.lookup r
|
|
|
|
|
|
for_ rv $ \x -> do
|
|
|
|
atomically $ modifyTVar cached (HM.insert r x)
|
|
|
|
when (rv /= old) do
|
|
debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x
|
|
atomically $ modifyTVar cached (HM.insert r x)
|
|
atomically $ writeTQueue changes r
|
|
|
|
flip runContT pure $ callCC $ \exit -> do
|
|
|
|
lww <- lift (selectLwwByRefLog (RepoRefLog r))
|
|
>>= maybe (exit ()) pure
|
|
|
|
dir <- lift $ repoDataPath (coerce 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
|
|
|
|
pollRepoIndex = do
|
|
|
|
api <- asks _refLogAPI
|
|
let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 600)
|
|
|
|
ContT $ withAsync $ do
|
|
polling (Polling 1 30) rlogs $ \r -> do
|
|
lww' <- selectLwwByRefLog (RepoRefLog r)
|
|
for_ lww' $ addRepoIndexJob . coerce
|
|
|
|
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
|
|
|
|
|
|
theDict :: forall m . ( DashBoardPerks 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
|
|
baseUrlEntry
|
|
getRpcSocketEntry
|
|
rpcPingEntry
|
|
rpcIndexEntry
|
|
debugEntries
|
|
|
|
where
|
|
|
|
myHelpEntry = do
|
|
entry $ bindMatch "--help" $ nil_ $ \case
|
|
HelpEntryBound what -> do
|
|
helpEntry what
|
|
quit
|
|
|
|
[StringLike s] -> helpList False (Just s) >> quit
|
|
|
|
_ -> helpList False Nothing >> quit
|
|
|
|
fixmeAllowEntry = do
|
|
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
|
|
|
|
fixmeAllowDropEntry = do
|
|
brief "drop all allowed fixme records" $
|
|
examples [qc|
|
|
fixme-allow:drop
|
|
|]
|
|
$ entry $ bindMatch "fixme-allow:drop" $ nil_ \case
|
|
[] -> do
|
|
lift $ deleteFixmeAllowed
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
webEntry = do
|
|
brief "run web interface" $
|
|
entry $ bindMatch "web" $ nil_ $ const do
|
|
lift runScotty
|
|
|
|
portEntry = do
|
|
brief "set http port for web interface" $
|
|
entry $ bindMatch "port" $ nil_ \case
|
|
[LitIntVal n] -> do
|
|
tp <- lift $ asks _dashBoardHttpPort
|
|
atomically $ writeTVar tp (Just (fromIntegral n))
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
developAssetsEntry = do
|
|
entry $ bindMatch "develop-assets" $ nil_ \case
|
|
[StringLike s] -> do
|
|
devAssTVar <- lift $ asks _dashBoardDevAssets
|
|
atomically $ writeTVar devAssTVar (Just s)
|
|
|
|
_ -> none
|
|
|
|
baseUrlEntry = do
|
|
entry $ bindMatch "base-url" $ nil_ \case
|
|
[StringLike s] -> do
|
|
urlTV <- lift $ asks _dashBoardBaseUrl
|
|
atomically $ writeTVar urlTV (Just (Text.pack s))
|
|
_ -> 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
|
|
|
|
rpcIndexEntry = do
|
|
entry $ bindMatch "index:now" $ nil_ $ const $ lift do
|
|
so <- getRPCSocket >>= orThrowUser "rpc socket down"
|
|
withMyRPCClient so $ \caller -> do
|
|
void $ callService @IndexNowRPC caller ()
|
|
|
|
-- TODO: ASAP-hide-debug-functions-from-help
|
|
|
|
debugEntries = do
|
|
|
|
entry $ bindMatch "debug:cache:ignore:on" $ nil_ $ const $ lift do
|
|
t <- asks _dashBoardIndexIgnoreCaches
|
|
atomically $ writeTVar t True
|
|
|
|
entry $ bindMatch "debug:cache:ignore:off" $ nil_ $ const $ lift do
|
|
t <- asks _dashBoardIndexIgnoreCaches
|
|
atomically $ writeTVar t False
|
|
|
|
entry $ bindMatch "debug:build-commit-index" $ nil_ $ \case
|
|
[SignPubKeyLike lw] -> lift do
|
|
buildCommitTreeIndex (LWWRefKey lw)
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
entry $ bindMatch "debug:build-single-commit-index" $ nil_ $ \case
|
|
[SignPubKeyLike lw, StringLike h'] -> lift do
|
|
|
|
h <- fromStringMay @GitHash h'
|
|
& orThrowUser ("invalid git object hash" <+> pretty h')
|
|
|
|
buildSingleCommitTreeIndex (LWWRefKey lw) h
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
-- rs <- selectRepoFixme
|
|
-- for_ rs $ \(r,f) -> do
|
|
-- liftIO $ print $ pretty r <+> pretty (AsBase58 f)
|
|
|
|
|
|
entry $ bindMatch "debug:select-repo-fixme" $ nil_ $ const $ lift do
|
|
rs <- selectRepoFixme
|
|
for_ rs $ \(r,f) -> do
|
|
liftIO $ print $ pretty r <+> pretty (AsBase58 f)
|
|
|
|
entry $ bindMatch "debug:check-fixme-allowed" $ nil_ $ \case
|
|
[SignPubKeyLike s] -> do
|
|
what <- lift $ checkFixmeAllowed (RepoLww (LWWRefKey s))
|
|
liftIO $ print $ pretty what
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
entry $ bindMatch "debug:test-with-fixme" $ nil_ $ \case
|
|
[SignPubKeyLike s] -> lift do
|
|
r <- listFixme (RepoLww (LWWRefKey s)) ()
|
|
for_ r $ \f -> do
|
|
liftIO $ print $ pretty f
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
entry $ bindMatch "debug:count-fixme" $ nil_ $ \case
|
|
[SignPubKeyLike s] -> lift do
|
|
r <- countFixme (RepoLww (LWWRefKey s))
|
|
liftIO $ print $ pretty r
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
|
|
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
|