mirror of https://github.com/voidlizard/hbs2
hbs2-dashboard and hbs2-fixer removed
This commit is contained in:
voidlizard
parent
57b480a454
commit
96b5b051b3
|
|
@ -34,10 +34,7 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
|||
"hbs2-core"
|
||||
"hbs2-storage-simple"
|
||||
"hbs2-git"
|
||||
"hbs2-git-dashboard"
|
||||
"hbs2-git3"
|
||||
"hbs2-qblf"
|
||||
"hbs2-fixer"
|
||||
"hbs2-cli"
|
||||
"hbs2-sync"
|
||||
"fixme-new"
|
||||
|
|
|
|||
|
|
@ -1,724 +0,0 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Base58
|
||||
import HBS2.OrDie
|
||||
import HBS2.Hash
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Polling
|
||||
import HBS2.Misc.PrettyStuff
|
||||
import HBS2.System.Dir
|
||||
import HBS2.System.Logger.Simple.ANSI hiding (info)
|
||||
import HBS2.Net.Messaging.Unix
|
||||
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
|
||||
import HBS2.Net.Proto.Notify
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.Peer.Notify
|
||||
import HBS2.Peer.RPC.API.Peer
|
||||
import HBS2.Peer.RPC.API.RefLog
|
||||
import HBS2.Peer.RPC.API.LWWRef
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
import HBS2.Peer.Proto.RefLog
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Coerce
|
||||
import Control.Monad.Reader
|
||||
import Lens.Micro.Platform
|
||||
import System.Directory
|
||||
import Options.Applicative
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||
import Data.Text qualified as Text
|
||||
import Data.Hashable
|
||||
import Control.Exception qualified as E
|
||||
import System.Process.Typed
|
||||
import System.Environment qualified as Env
|
||||
import System.Exit qualified as Exit
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.Cache (Cache)
|
||||
|
||||
import System.Exit
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
|
||||
type Config = [Syntax C]
|
||||
|
||||
|
||||
type RLWW = LWWRefKey 'HBS2Basic
|
||||
type RRefLog = RefLogKey 'HBS2Basic
|
||||
|
||||
newtype Watcher =
|
||||
Watcher [Syntax C]
|
||||
deriving newtype (Semigroup,Monoid)
|
||||
|
||||
data Ref =
|
||||
RefRefLog RRefLog
|
||||
| RefLWW RLWW
|
||||
deriving stock (Eq,Generic)
|
||||
|
||||
instance Pretty Ref where
|
||||
pretty (RefRefLog r) = parens $ "reflog" <+> dquotes (pretty r)
|
||||
pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r)
|
||||
|
||||
newtype AnyPolledRef =
|
||||
AnyPolledRef (PubKey 'Sign 'HBS2Basic)
|
||||
deriving (Eq,Generic)
|
||||
|
||||
instance Hashable AnyPolledRef
|
||||
|
||||
-- FIXME: move-to-suckless-conf
|
||||
deriving newtype instance Hashable Id
|
||||
|
||||
instance Pretty AnyPolledRef where
|
||||
pretty (AnyPolledRef r) = pretty (AsBase58 r)
|
||||
-- deriving newtype instance Pretty (PubKey 'Sign 'HBS2Basic) => Pretty AnyPolledRef
|
||||
|
||||
instance FromStringMaybe AnyPolledRef where
|
||||
fromStringMay = fmap AnyPolledRef . fromStringMay
|
||||
|
||||
newtype PolledRef =
|
||||
PolledRef (Ref, NominalDiffTime)
|
||||
deriving stock (Eq,Generic)
|
||||
deriving newtype (Pretty)
|
||||
|
||||
instance Hashable Ref
|
||||
|
||||
instance Hashable PolledRef where
|
||||
hashWithSalt salt (PolledRef (r,_)) = hashWithSalt salt r
|
||||
|
||||
data FixerEnv = FixerEnv
|
||||
{ _configFile :: Maybe FilePath
|
||||
, _lwwAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _refLogSink :: NotifySink (RefLogEvents L4Proto) UNIX
|
||||
, _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _sto :: AnyStorage
|
||||
, _config :: TVar Config
|
||||
, _configPoll :: TVar Int
|
||||
, _watchers :: TVar (HashMap PolledRef Watcher)
|
||||
, _listeners :: TVar (HashMap RRefLog (Async ()))
|
||||
, _result :: TVar (HashMap Ref (Maybe HashRef, Maybe HashRef))
|
||||
, _runNum :: TVar Int
|
||||
, _locals :: TVar (HashMap Id (Syntax C))
|
||||
, _pipeline :: TQueue (IO ())
|
||||
}
|
||||
|
||||
makeLenses ''FixerEnv
|
||||
|
||||
|
||||
newtype FixerM m a = FixerM { runFixerM :: ReaderT FixerEnv m a }
|
||||
deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader FixerEnv, MonadUnliftIO)
|
||||
|
||||
instance MonadIO m => HasConf (FixerM m) where
|
||||
getConf = asks _config >>= readTVarIO
|
||||
|
||||
|
||||
debugPrefix = toStdout . logPrefix "[debug] "
|
||||
|
||||
readConf :: MonadIO m => FilePath -> m [Syntax C]
|
||||
readConf fn = liftIO (readFile fn) <&> parseTop <&> fromRight mempty
|
||||
|
||||
withConfig :: MonadUnliftIO m => Maybe FilePath -> FixerM m () -> FixerM m ()
|
||||
withConfig cfgPath m = do
|
||||
defConfDir <- liftIO $ getXdgDirectory XdgConfig "hbs2-fixer"
|
||||
|
||||
let configPath = fromMaybe (defConfDir </> "config") cfgPath
|
||||
unless (isJust cfgPath) do
|
||||
debug $ pretty configPath
|
||||
touch configPath
|
||||
|
||||
syn <- readConf configPath
|
||||
tsyn <- newTVarIO syn
|
||||
|
||||
local (set config tsyn . set configFile (Just configPath)) (void m)
|
||||
|
||||
withApp :: Maybe FilePath -> FixerM IO () -> IO ()
|
||||
withApp cfgPath action = do
|
||||
setLogging @DEBUG debugPrefix
|
||||
setLogging @INFO defLog
|
||||
setLogging @ERROR errorPrefix
|
||||
setLogging @WARN warnPrefix
|
||||
setLogging @NOTICE noticePrefix
|
||||
|
||||
fix \next -> do
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
soname' <- lift detectRPC
|
||||
|
||||
soname <- ContT $ maybe1 soname' (pure ())
|
||||
|
||||
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
|
||||
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||||
|
||||
mess <- ContT $ withAsync $ runMessagingUnix client
|
||||
|
||||
peerAPI <- makeServiceCaller @PeerAPI (fromString soname)
|
||||
refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname)
|
||||
storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
|
||||
lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname)
|
||||
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX refLogAPI
|
||||
, Endpoint @UNIX lwwAPI
|
||||
, Endpoint @UNIX storageAPI
|
||||
]
|
||||
|
||||
mn <- ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
let o = [MUDontRetry]
|
||||
clientN <- newMessagingUnixOpts o False 1.0 soname
|
||||
|
||||
notif <- ContT $ withAsync (runMessagingUnix clientN)
|
||||
|
||||
|
||||
sink <- newNotifySink
|
||||
|
||||
void $ ContT $ withAsync $ flip runReaderT clientN $ do
|
||||
debug $ red "notify restarted!"
|
||||
runNotifyWorkerClient sink
|
||||
|
||||
p1 <- ContT $ withAsync $ flip runReaderT clientN $ do
|
||||
runProto @UNIX
|
||||
[ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink)
|
||||
]
|
||||
|
||||
env <- FixerEnv Nothing
|
||||
lwwAPI
|
||||
refLogAPI
|
||||
sink
|
||||
peerAPI
|
||||
(AnyStorage (StorageClient storageAPI))
|
||||
<$> newTVarIO mempty
|
||||
<*> newTVarIO 30
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO mempty
|
||||
<*> newTQueueIO
|
||||
|
||||
void $ ContT $ bracket (pure ()) $ \_ -> do
|
||||
readTVarIO (_listeners env) <&> HM.elems >>= mapM_ cancel
|
||||
|
||||
p3 <- ContT $ withAsync $ runReaderT (runFixerM $ withConfig cfgPath action) env
|
||||
|
||||
void $ waitAnyCatchCancel [mess,mn,notif,p1,p3]
|
||||
|
||||
debug $ red "respawning..."
|
||||
pause @'Seconds 5
|
||||
next
|
||||
|
||||
setLoggingOff @DEBUG
|
||||
setLoggingOff @INFO
|
||||
setLoggingOff @ERROR
|
||||
setLoggingOff @WARN
|
||||
setLoggingOff @NOTICE
|
||||
|
||||
where
|
||||
errorPrefix = toStdout . logPrefix "[error] "
|
||||
warnPrefix = toStdout . logPrefix "[warn] "
|
||||
noticePrefix = toStdout
|
||||
|
||||
|
||||
data ConfWatch =
|
||||
ConfWatch
|
||||
| ConfRead
|
||||
| ConfUpdate [Syntax C]
|
||||
|
||||
mainLoop :: FixerM IO ()
|
||||
mainLoop = do
|
||||
debug "hbs2-fixer. do stuff since 2024"
|
||||
conf <- getConf
|
||||
-- debug $ line <> vcat (fmap pretty conf)
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
debug $ red "Reloading..."
|
||||
|
||||
lift $ updateFromConfig conf
|
||||
|
||||
p1 <- ContT $ withAsync $ do
|
||||
cfg <- asks _configFile `orDie` "config file not specified"
|
||||
|
||||
flip fix ConfRead $ \next -> \case
|
||||
ConfRead -> do
|
||||
debug $ yellow "read config" <+> pretty cfg
|
||||
newConf <- readConf cfg
|
||||
oldConf <- getConf
|
||||
|
||||
let a = hashObject @HbSync (LBS.pack $ show $ pretty newConf)
|
||||
let b = hashObject @HbSync (LBS.pack $ show $ pretty oldConf)
|
||||
|
||||
let changed = a /= b
|
||||
|
||||
if not changed then
|
||||
next ConfWatch
|
||||
else
|
||||
next (ConfUpdate newConf)
|
||||
|
||||
ConfUpdate new -> do
|
||||
debug $ yellow "read config / update state"
|
||||
updateFromConfig new
|
||||
next ConfWatch
|
||||
|
||||
ConfWatch{} -> do
|
||||
w <- asks _configPoll >>= readTVarIO
|
||||
pause (TimeoutSec (realToFrac w))
|
||||
next ConfRead
|
||||
|
||||
-- poll reflogs
|
||||
p2 <- ContT $ withAsync do
|
||||
|
||||
let w = asks _watchers
|
||||
>>= readTVarIO
|
||||
<&> HM.toList
|
||||
<&> \wtf -> [ (ByFirst r wa, t) | (PolledRef (r,t), wa) <- wtf ]
|
||||
|
||||
polling (Polling 1 1) w $ \case
|
||||
ByFirst ref wa -> do
|
||||
new <- getRefRpc ref
|
||||
re <- asks _result
|
||||
old <- readTVarIO re
|
||||
<&> (snd <=< HM.lookup ref)
|
||||
|
||||
when (new /= old) do
|
||||
atomically $ modifyTVar re (HM.insert ref (old, new))
|
||||
-- bindId
|
||||
forM_ new (runWatcher wa ref)
|
||||
|
||||
pure ()
|
||||
|
||||
jobs <- asks _pipeline
|
||||
p3 <- ContT $ withAsync $ fix \next -> do
|
||||
r <- liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs)
|
||||
case r of
|
||||
Left e -> do
|
||||
err (viaShow e)
|
||||
let ee = fromException @AsyncCancelled e
|
||||
|
||||
unless (isJust ee) do
|
||||
next
|
||||
|
||||
_ -> next
|
||||
|
||||
void $ waitAnyCatchCancel [p1,p2,p3]
|
||||
|
||||
oneSec :: MonadUnliftIO m => m b -> m (Either () b)
|
||||
oneSec = race (pause @'Seconds 1)
|
||||
|
||||
|
||||
fromStrLitMay :: forall s c . FromStringMaybe s => Syntax c -> Maybe s
|
||||
fromStrLitMay = \case
|
||||
LitStrVal s -> fromStringMay (Text.unpack s)
|
||||
_ -> Nothing
|
||||
|
||||
pattern PTop :: forall {c}. Id -> [Syntax c] -> Syntax c
|
||||
pattern PTop ctor rest <- ListVal (SymbolVal ctor : rest)
|
||||
|
||||
pattern PPolledRef :: forall {c}. Id -> AnyPolledRef -> Syntax c
|
||||
pattern PPolledRef t r <- ListVal [ SymbolVal t, fromStrLitMay @AnyPolledRef -> Just r ]
|
||||
|
||||
pattern PWatchRef :: forall {c}. Integer -> Id -> AnyPolledRef -> [Syntax c] -> [Syntax c]
|
||||
pattern PWatchRef n t r w <- (LitIntVal n : PPolledRef t r : w)
|
||||
|
||||
pattern PListenRef :: forall {c}. Id -> AnyPolledRef -> [Syntax c] -> [Syntax c]
|
||||
pattern PListenRef t r w <- (PPolledRef t r : w)
|
||||
|
||||
-- pattern PDisplay :: Syntax c
|
||||
pattern PDisplay :: forall {c}. Syntax c -> Syntax c
|
||||
pattern PDisplay w <- ListVal [ SymbolVal "display", w ]
|
||||
|
||||
pattern PApply :: Id -> [Syntax C] -> Syntax C
|
||||
pattern PApply f a <- ListVal ( SymbolVal f : a )
|
||||
|
||||
fetchRef :: forall m . MonadIO m => Ref -> FixerM m ()
|
||||
fetchRef r = do
|
||||
case r of
|
||||
RefRefLog ref -> do
|
||||
api <- asks _refLogAPI
|
||||
void $ liftIO $ oneSec $ void $ callService @RpcRefLogFetch api (fromRefLogKey ref)
|
||||
RefLWW ref -> do
|
||||
api <- asks _lwwAPI
|
||||
void $ liftIO $ oneSec $ void $ callService @RpcLWWRefFetch api ref
|
||||
|
||||
|
||||
getRefRpc :: forall m . MonadIO m => Ref -> FixerM m (Maybe HashRef)
|
||||
getRefRpc r = do
|
||||
case r of
|
||||
RefRefLog ref -> do
|
||||
api <- asks _refLogAPI
|
||||
liftIO (oneSec $ callService @RpcRefLogGet api (fromRefLogKey ref))
|
||||
>>= \case
|
||||
Right (Right x) -> pure x
|
||||
_ -> pure Nothing
|
||||
|
||||
RefLWW ref -> do
|
||||
api <- asks _lwwAPI
|
||||
liftIO (oneSec $ callService @RpcLWWRefGet api ref) >>= \case
|
||||
Right (Right x) -> pure (lwwValue <$> x)
|
||||
_ -> pure Nothing
|
||||
|
||||
subscribeRef :: forall m . MonadIO m => Integer -> Ref -> FixerM m ()
|
||||
subscribeRef n r = do
|
||||
debug $ "subscribeRef" <+> pretty n <+> pretty r
|
||||
let (puk,t) = case r of
|
||||
RefRefLog k -> (coerce k, "reflog")
|
||||
RefLWW k -> (coerce k, "lwwref")
|
||||
|
||||
let minutes = fromIntegral $ max 1 (n `div` 60)
|
||||
|
||||
api <- asks _peerAPI
|
||||
void $ liftIO $ oneSec $ callService @RpcPollAdd api (puk, t, minutes)
|
||||
|
||||
asRef :: Id -> AnyPolledRef -> Maybe Ref
|
||||
asRef t r = case t of
|
||||
"lwwref" -> Just $ RefLWW (coerce r)
|
||||
"reflog" -> Just $ RefRefLog (coerce r)
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
runWatcher :: forall m . MonadUnliftIO m => Watcher -> Ref -> HashRef -> FixerM m ()
|
||||
runWatcher (Watcher code) ref new = do
|
||||
debug $ yellow "CHANGED" <+> pretty ref <+> pretty new
|
||||
|
||||
sto <- asks _sto
|
||||
|
||||
newCode <- flip transformBiM code $ \case
|
||||
PApply "lwwref:get-hbs2-git-reflog" _ -> do
|
||||
v <- case ref of
|
||||
RefLWW k -> readLWWBlock sto k
|
||||
_ -> pure Nothing
|
||||
|
||||
-- FIXME: wrappers-for-syntax-ctors
|
||||
let vv = maybe1 v (List (noContext @C) mempty) $
|
||||
\(_, LWWBlockData{..}) ->
|
||||
List (noContext @C) [ Symbol (noContext @C) "reflog"
|
||||
, Literal (noContext @C)
|
||||
(mkLit @Text (fromString $ show $ pretty (AsBase58 lwwRefLogPubKey)))
|
||||
]
|
||||
pure vv
|
||||
|
||||
w -> pure w
|
||||
|
||||
debug (pretty newCode)
|
||||
runConfig newCode
|
||||
|
||||
|
||||
|
||||
display :: forall m . MonadUnliftIO m => Syntax C -> FixerM m ()
|
||||
display what = do
|
||||
case what of
|
||||
LitStrVal s -> notice (pretty s)
|
||||
ast -> notice (pretty ast)
|
||||
|
||||
list_ :: [Syntax C] -> Syntax C
|
||||
list_ = List (noContext @C)
|
||||
|
||||
symbol_ :: Id -> Syntax C
|
||||
symbol_ = Symbol (noContext @C)
|
||||
|
||||
str_ :: Text -> Syntax C
|
||||
str_ s = Literal (noContext @C) (LitStr s)
|
||||
|
||||
int_ :: Integer -> Syntax C
|
||||
int_ s = Literal (noContext @C) (LitInt s)
|
||||
|
||||
bool_ :: Bool -> Syntax C
|
||||
bool_ s = Literal (noContext @C) (LitBool s)
|
||||
|
||||
-- FIXME: to-suckless-conf
|
||||
class AsString s where
|
||||
asString :: s -> String
|
||||
|
||||
instance AsString Literal where
|
||||
asString (LitStr s) = Text.unpack s
|
||||
asString other = show $ pretty other
|
||||
|
||||
instance AsString (Syntax c) where
|
||||
asString (Literal _ x) = asString x
|
||||
asString x = show $ pretty x
|
||||
|
||||
data RunOpts =
|
||||
RunCWD FilePath
|
||||
|
||||
instance Pretty RunOpts where
|
||||
pretty = \case
|
||||
RunCWD f -> parens ("cwd" <+> pretty f)
|
||||
|
||||
eval :: forall m . MonadUnliftIO m => Syntax C -> FixerM m (Syntax C)
|
||||
eval = eval'
|
||||
-- debug $ "EVAL" <+> pretty syn <+> pretty r
|
||||
-- pure r
|
||||
|
||||
eval' :: forall m . MonadUnliftIO m => Syntax C -> FixerM m (Syntax C)
|
||||
eval' syn = do
|
||||
|
||||
case syn of
|
||||
|
||||
x@(Literal{}) -> pure x
|
||||
|
||||
(SymbolVal n) -> lookupLocal n
|
||||
|
||||
w@(PApply "list" code') -> do
|
||||
code <- mapM unquote code'
|
||||
pure $ list_ (symbol_ "list" : code)
|
||||
|
||||
PApply "local" [SymbolVal n, what] -> do
|
||||
bindLocal n =<< eval what
|
||||
pure nil
|
||||
|
||||
PApply "eval" [e] -> do
|
||||
eval e >>= \case
|
||||
(ListVal ( SymbolVal "list" : es ) ) -> do
|
||||
lastDef nil <$> mapM eval es
|
||||
|
||||
_ -> pure nil
|
||||
|
||||
PApply "listen" (what' : code) -> do
|
||||
what <- eval what'
|
||||
case what of
|
||||
PPolledRef "reflog" ref -> do
|
||||
setReflogListener (coerce ref) =<< mapM unquote code
|
||||
|
||||
PPolledRef tp r -> do
|
||||
warn $ yellow "not supported listener type" <+> pretty tp
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
pure nil
|
||||
|
||||
PApply "watch" (p' : what' : watcher') -> do
|
||||
p <- eval p'
|
||||
what <- eval what'
|
||||
watcher <- mapM unquote watcher'
|
||||
|
||||
case (p, what) of
|
||||
(LitIntVal n, PPolledRef tp ref) -> do
|
||||
|
||||
let re = asRef tp ref
|
||||
|
||||
forM_ re (subscribeRef n)
|
||||
void $ async (pause @'Seconds 5 >> forM_ re fetchRef)
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
-- FIXME: more-diagnostics
|
||||
pref <- toMPlus $ case tp of
|
||||
"lwwref" -> Just $ PolledRef (RefLWW (coerce ref), fromIntegral n)
|
||||
"reflog" -> Just $ PolledRef (RefRefLog (coerce ref), fromIntegral n)
|
||||
_ -> Nothing
|
||||
|
||||
debug $ blue "watch" <+> pretty n <+> pretty tp <+> pretty ref
|
||||
w <- asks _watchers
|
||||
atomically $ modifyTVar w (HM.insert pref (Watcher watcher))
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
pure nil
|
||||
|
||||
PApply "on-start" wtf -> do
|
||||
|
||||
rn <- asks _runNum
|
||||
rnn <- atomically do
|
||||
x <- readTVar rn
|
||||
modifyTVar rn succ
|
||||
pure x
|
||||
|
||||
when (rnn == 0) do
|
||||
mapM_ eval wtf
|
||||
|
||||
pure nil
|
||||
|
||||
PApply fn args' -> do
|
||||
args <- mapM eval args'
|
||||
case fn of
|
||||
|
||||
"reflog" -> do
|
||||
pure $ list_ (symbol_ "reflog" : args)
|
||||
|
||||
"lwwref" -> do
|
||||
pure $ list_ (symbol_ "lwwref" : args)
|
||||
|
||||
"watch-config" -> do
|
||||
case headDef (int_ 30) args of
|
||||
LitIntVal n -> do
|
||||
debug $ "watch-config" <+> pretty n
|
||||
asks _configPoll >>= atomically . flip writeTVar (fromIntegral n)
|
||||
_ -> do
|
||||
pure ()
|
||||
|
||||
pure nil
|
||||
|
||||
"debug" -> do
|
||||
let onOff = headDef (bool_ False) args
|
||||
case onOff of
|
||||
LitBoolVal True -> do
|
||||
setLogging @DEBUG debugPrefix
|
||||
_ -> do
|
||||
setLoggingOff @DEBUG
|
||||
|
||||
pure nil
|
||||
|
||||
"string-append" -> do
|
||||
pieces <- for args $ \case
|
||||
LitStrVal s -> pure s
|
||||
other -> pure (Text.pack $ show $ pretty other)
|
||||
|
||||
pure $ str_ $ mconcat pieces
|
||||
|
||||
"display" -> do
|
||||
first <- headDef nil <$> mapM eval args
|
||||
case first of
|
||||
LitStrVal s -> notice (pretty s)
|
||||
ast -> notice (pretty ast)
|
||||
|
||||
pure nil
|
||||
|
||||
"getenv" -> do
|
||||
let name = asString $ headDef nil args
|
||||
liftIO $ Env.lookupEnv name
|
||||
>>= \case
|
||||
Nothing -> pure nil
|
||||
Just s -> pure $ str_ (fromString s)
|
||||
|
||||
"mkdir" -> do
|
||||
debug $ "mkdir" <+> pretty args
|
||||
mapM_ mkdir [ Text.unpack s | (LitStrVal s) <- args ]
|
||||
pure nil
|
||||
|
||||
"exit" -> do
|
||||
case headDef (int_ 0) args of
|
||||
LitIntVal 0 -> liftIO Exit.exitSuccess
|
||||
LitIntVal w -> liftIO $ Exit.exitWith (ExitFailure $ fromIntegral w)
|
||||
_ -> liftIO Exit.exitFailure
|
||||
|
||||
pure nil
|
||||
|
||||
"run" -> do
|
||||
debug $ red "RUN-ARGS" <+> pretty args
|
||||
(o,cargs) <- case args of
|
||||
(ListVal (SymbolVal "list" : SymbolVal "opts" : opts) : rest) -> do
|
||||
let pairs = [ (opt, e) | ListVal [SymbolVal opt, e] <- opts ]
|
||||
oo <- for pairs $ \(o, e) -> (o,) <$> eval e
|
||||
let cwd = lastMay [ RunCWD (Text.unpack f )
|
||||
| ("cwd", LitStrVal f) <- oo
|
||||
]
|
||||
pure (maybeToList cwd, rest)
|
||||
|
||||
rest -> do
|
||||
pure (mempty, rest)
|
||||
|
||||
let what = unwords $ [Text.unpack s | LitStrVal s <- cargs]
|
||||
|
||||
let cwd = case headMay [ p | c@(RunCWD p) <- o ] of
|
||||
Just c -> setWorkingDir c
|
||||
_ -> id
|
||||
|
||||
debug $ red "RUN" <+> pretty what <+> pretty o
|
||||
|
||||
let job = void $ runProcess_ (shell what & cwd)
|
||||
pip <- asks _pipeline
|
||||
atomically $ writeTQueue pip job
|
||||
|
||||
pure nil
|
||||
|
||||
_ -> pure nil
|
||||
|
||||
|
||||
_ -> pure nil
|
||||
|
||||
|
||||
unquote :: forall code m . (code ~ Syntax C, MonadUnliftIO m) => code -> FixerM m code
|
||||
unquote code = flip transformBiM code $ \case
|
||||
x@(ListVal [SymbolVal "unquoted", rest] :: Syntax C) -> do
|
||||
eval rest
|
||||
|
||||
x -> pure x
|
||||
|
||||
setReflogListener :: forall m . MonadUnliftIO m => RRefLog -> [Syntax C] -> FixerM m ()
|
||||
setReflogListener reflog code = do
|
||||
debug $ green "setReflogListener" <+> pretty reflog <> line <> pretty code
|
||||
|
||||
dudes <- asks _listeners
|
||||
|
||||
a <- atomically do
|
||||
x <- readTVar dudes <&> HM.lookup reflog
|
||||
modifyTVar dudes (HM.delete reflog)
|
||||
pure x
|
||||
|
||||
maybe1 a none cancel
|
||||
|
||||
sink <- asks _refLogSink
|
||||
|
||||
debug $ "subscribe to" <+> pretty reflog
|
||||
|
||||
new <- async do
|
||||
cache <- liftIO $ Cache.newCache (Just (toTimeSpec (TimeoutSec 10)))
|
||||
|
||||
runNotifySink sink (RefLogNotifyKey reflog) $ \(RefLogUpdateNotifyData _ h) -> do
|
||||
debug $ "Got notification" <+> pretty reflog <+> pretty h
|
||||
here <- liftIO (Cache.lookup cache (reflog, h)) <&> isJust
|
||||
unless here do
|
||||
liftIO $ Cache.insert cache (reflog,h) ()
|
||||
runConfig code
|
||||
|
||||
atomically $ modifyTVar dudes (HM.insert reflog new)
|
||||
|
||||
bindLocal :: forall m . MonadUnliftIO m => Id -> Syntax C -> FixerM m ()
|
||||
bindLocal l e = do
|
||||
-- debug $ "bindLocal" <+> pretty l
|
||||
asks _locals >>= atomically . flip modifyTVar (HM.insert l e)
|
||||
|
||||
lookupLocal :: forall m . MonadUnliftIO m => Id ->FixerM m (Syntax C)
|
||||
lookupLocal name = do
|
||||
-- debug $ "lookupLocal" <+> pretty name
|
||||
asks _locals >>= readTVarIO <&> fromMaybe nil . HM.lookup name
|
||||
|
||||
runConfig :: forall m . MonadUnliftIO m => Config -> FixerM m ()
|
||||
runConfig conf = do
|
||||
debug $ green "runConfig"
|
||||
bindLocal "off" (bool_ False)
|
||||
bindLocal "on" (bool_ True)
|
||||
|
||||
mapM_ eval conf
|
||||
|
||||
updateFromConfig :: MonadUnliftIO m => Config -> FixerM m ()
|
||||
updateFromConfig conf = do
|
||||
asks _config >>= atomically . flip writeTVar conf
|
||||
runConfig conf
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
runMe =<< customExecParser (prefs showHelpOnError)
|
||||
( info (helper <*> opts)
|
||||
( fullDesc
|
||||
<> header "hbs2-fixer"
|
||||
<> progDesc "Intermediary between hbs2-peer and external applications. Listen events / do stuff"
|
||||
))
|
||||
|
||||
where
|
||||
opts = optional $ strOption (short 'c' <> long "config" <> metavar "FILE" <> help "Specify configuration file")
|
||||
|
||||
runMe opt = withApp opt mainLoop
|
||||
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
;; hbs2-fixer config example
|
||||
|
||||
(local home (getenv "HOME"))
|
||||
|
||||
(local root (string-append home "/.local/share/hbs2-git-repos/0.24.1"))
|
||||
|
||||
(local hbs2-repo "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" )
|
||||
(local hbs2-repo-path (string-append root "/" hbs2-repo))
|
||||
|
||||
(watch-config 30)
|
||||
|
||||
(debug off)
|
||||
|
||||
(display (string-append "repo1" " " hbs2-repo-path))
|
||||
|
||||
(eval (list (display "OKAY11 FROM EVAL")))
|
||||
|
||||
(on-start
|
||||
(display (string-append "on-start" " " "mkdir" " " hbs2-repo-path))
|
||||
|
||||
(mkdir hbs2-repo-path)
|
||||
|
||||
(run (string-append "git init --bare " hbs2-repo-path))
|
||||
(display update-hbs2-repo)
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo))
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git gc" ) )
|
||||
)
|
||||
|
||||
(watch 60 (lwwref "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP")
|
||||
(run-config
|
||||
(watch 300 (lwwref:get-hbs2-git-reflog)
|
||||
(display "GIT REFLOG CHANGED BY WATCH")
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo ))
|
||||
|
||||
(display (string-append "Updated " hbs2-repo " OK"))
|
||||
|
||||
)
|
||||
|
||||
(listen (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(display "GIT REFLOG CHANGED BY LISTENER")
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo ))
|
||||
|
||||
(display (string-append "Updated " hbs2-repo " OK"))
|
||||
)
|
||||
|
||||
)
|
||||
(display (string-append "Updated " hbs2-repo))
|
||||
)
|
||||
|
||||
; (watch 30 (lwwref "Byc3XUeSbJBXVFueumkNkVJMPHbGoUdxYEJBgzJPf8io")
|
||||
; (run "./on-my-ref4.sh")
|
||||
; )
|
||||
|
||||
; (watch 30 (lwwref "DTmSb3Au7apDTMctQn6yqs9GJ8mFW7YQXzgVqZpmkTtf")
|
||||
; (run "./on-my-ref4.sh")
|
||||
; )
|
||||
|
||||
; (watch 30 (reflog "BKtvRLispCM9UuQqHaNxu4SEUzpQNQ3PeRNknecKGPZ6")
|
||||
; (run "./on-my-ref4.sh")
|
||||
; )
|
||||
|
||||
; (display "JOPAKITA 111")
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
|
||||
(display (getenv 1234))
|
||||
|
||||
(display (getenv "HOME"))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
|
||||
(local home (getenv "HOME"))
|
||||
|
||||
(local root (string-append home "/.local/share/hbs2-git-repos/0.24.1"))
|
||||
|
||||
(local hbs2-repo "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" )
|
||||
(local hbs2-repo-path (string-append root "/" hbs2-repo))
|
||||
|
||||
(display root)
|
||||
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
;; hbs2-fixer config example
|
||||
|
||||
; (debug off)
|
||||
|
||||
(watch-config 30)
|
||||
|
||||
(local home (getenv "HOME"))
|
||||
|
||||
(local root (string-append home "/.local/share/hbs2-git-repos/0.24.1"))
|
||||
|
||||
(local hbs2-repo "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" )
|
||||
(local hbs2-repo-path (string-append root "/" hbs2-repo))
|
||||
|
||||
|
||||
(local myref "BKtvRLispCM9UuQqHaNxu4SEUzpQNQ3PeRNknecKGPZ6" )
|
||||
|
||||
(listen (reflog myref)
|
||||
(display (string-append "HELLO FROM REFLOG " (unquoted myref)))
|
||||
)
|
||||
|
||||
(listen (lwwref myref)
|
||||
(display "WON'T HAPPEN")
|
||||
)
|
||||
|
||||
(display "FUUBAR!")
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
|
||||
(local code (list (display "HELLO")))
|
||||
|
||||
(eval code)
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
|
||||
(watch 30 (lwwref "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP")
|
||||
(display "PREVED")
|
||||
)
|
||||
|
|
@ -1,129 +0,0 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-fixer
|
||||
version: 0.25.0.1
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
author: Dmitry Zuikov
|
||||
maintainer: dzuikov@gmail.com
|
||||
-- copyright:
|
||||
category: Development
|
||||
build-type: Simple
|
||||
extra-doc-files: CHANGELOG.md
|
||||
-- extra-source-files:
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wno-type-defaults
|
||||
-fprint-potential-instances
|
||||
-- -fno-warn-unused-matches
|
||||
-- -fno-warn-unused-do-bind
|
||||
-- -Werror=missing-methods
|
||||
-- -Werror=incomplete-patterns
|
||||
-- -fno-warn-unused-binds
|
||||
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
, BangPatterns
|
||||
, BlockArguments
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, DerivingVia
|
||||
, ExtendedDefaultRules
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, GeneralizedNewtypeDeriving
|
||||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeOperators
|
||||
, TypeFamilies
|
||||
, TemplateHaskell
|
||||
|
||||
|
||||
build-depends: hbs2-core, hbs2-peer, hbs2-git
|
||||
, attoparsec
|
||||
, aeson
|
||||
, async
|
||||
, base16-bytestring
|
||||
, bytestring
|
||||
, cache
|
||||
, containers
|
||||
, streaming
|
||||
, streaming-bytestring
|
||||
, streaming-commons
|
||||
, crypton
|
||||
, directory
|
||||
, exceptions
|
||||
, filelock
|
||||
, filepath
|
||||
, filepattern
|
||||
, generic-lens
|
||||
, hashable
|
||||
, http-conduit
|
||||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, prettyprinter
|
||||
, prettyprinter-ansi-terminal
|
||||
, random
|
||||
, resourcet
|
||||
, safe
|
||||
, saltine
|
||||
, serialise
|
||||
, split
|
||||
, sqlite-simple
|
||||
, stm
|
||||
, suckless-conf
|
||||
, temporary
|
||||
, text
|
||||
, time
|
||||
, timeit
|
||||
, transformers
|
||||
, typed-process
|
||||
, uniplate
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, unordered-containers
|
||||
, wai-app-file-cgi
|
||||
, wai-extra
|
||||
|
||||
executable hbs2-fixer
|
||||
import: shared-properties
|
||||
main-is: Main.hs
|
||||
|
||||
ghc-options:
|
||||
-threaded
|
||||
-rtsopts
|
||||
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-peer
|
||||
, optparse-applicative
|
||||
, unliftio
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,199 +0,0 @@
|
|||
; vim: set filetype=scheme :
|
||||
;; hbs2-fixer config example
|
||||
|
||||
|
||||
(local root "/var/www/git")
|
||||
|
||||
(local hbs2-ref (lwwref "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"))
|
||||
(local hbs2-repo "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" )
|
||||
(local hbs2-repo-path (string-append root "/" hbs2-repo))
|
||||
|
||||
|
||||
(local suckless-ref (lwwref "JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"))
|
||||
(local suckless-repo "JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ" )
|
||||
(local suckless-repo-path (string-append root "/" suckless-repo))
|
||||
|
||||
(local fixme-ref (lwwref "Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"))
|
||||
(local fixme-repo "Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr" )
|
||||
(local fixme-repo-path (string-append root "/" fixme-repo))
|
||||
|
||||
(local dbpipe-ref (lwwref "5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"))
|
||||
(local dbpipe-repo "5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" )
|
||||
(local dbpipe-repo-path (string-append root "/" dbpipe-repo))
|
||||
|
||||
(watch-config 30)
|
||||
|
||||
(debug on)
|
||||
|
||||
(display (string-append "repo1" " " hbs2-repo-path))
|
||||
|
||||
(on-start
|
||||
(display (string-append "on-start" " " "mkdir" " " hbs2-repo-path))
|
||||
|
||||
(mkdir hbs2-repo-path)
|
||||
|
||||
(run (string-append "git init --bare " hbs2-repo-path))
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo))
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git gc" ) )
|
||||
|
||||
|
||||
(mkdir suckless-repo-path)
|
||||
|
||||
(run (string-append "git init --bare " suckless-repo-path))
|
||||
|
||||
(run (list opts (cwd suckless-repo-path))
|
||||
(string-append "git hbs2 import" " " suckless-repo))
|
||||
|
||||
(run (list opts (cwd suckless-repo-path))
|
||||
(string-append "git gc" ) )
|
||||
|
||||
(mkdir fixme-repo-path)
|
||||
|
||||
(run (string-append "git init --bare " fixme-repo-path))
|
||||
|
||||
(run (list opts (cwd fixme-repo-path))
|
||||
(string-append "git hbs2 import" " " fixme-repo))
|
||||
|
||||
(run (list opts (cwd fixme-repo-path))
|
||||
(string-append "git gc" ) )
|
||||
|
||||
|
||||
(mkdir dbpipe-repo-path)
|
||||
|
||||
(run (string-append "git init --bare " dbpipe-repo-path))
|
||||
|
||||
(run (list opts (cwd dbpipe-repo-path))
|
||||
(string-append "git hbs2 import" " " dbpipe-repo))
|
||||
|
||||
(run (list opts (cwd dbpipe-repo-path))
|
||||
(string-append "git gc" ) )
|
||||
|
||||
)
|
||||
|
||||
(watch 60 hbs2-ref
|
||||
(display (string-append "hbs2-repo" " " hbs2-ref))
|
||||
|
||||
(display (string-append "hbs2-repo" " " hbs2-ref))
|
||||
(run-config
|
||||
|
||||
(display (string-append "REF" (lwwref:get-hbs2-git-reflog)))
|
||||
|
||||
(watch 300 (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo ))
|
||||
|
||||
(display (string-append "Updated " hbs2-repo " OK"))
|
||||
|
||||
)
|
||||
|
||||
(listen (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(display "subscribed hbs2")
|
||||
|
||||
(run (list opts (cwd hbs2-repo-path))
|
||||
(string-append "git hbs2 import" " " hbs2-repo ))
|
||||
|
||||
(display (string-append "Updated " hbs2-repo " OK")))
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
;; fixme
|
||||
|
||||
(watch 60 fixme-ref
|
||||
(display (string-append "fixme-repo" " " fixme-ref))
|
||||
|
||||
(display (string-append "fixme-repo" " " fixme-ref))
|
||||
(run-config
|
||||
|
||||
(display (string-append "REF" (lwwref:get-hbs2-git-reflog)))
|
||||
|
||||
(watch 300 (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(run (list opts (cwd fixme-repo-path))
|
||||
(string-append "git hbs2 import" " " fixme-repo ))
|
||||
|
||||
(display (string-append "Updated " fixme-repo " OK"))
|
||||
|
||||
)
|
||||
|
||||
(listen (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(display "subscribed fixme")
|
||||
|
||||
(run (list opts (cwd fixme-repo-path))
|
||||
(string-append "git hbs2 import" " " fixme-repo ))
|
||||
|
||||
(display (string-append "Updated " fixme-repo " OK")))
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
;; suckless
|
||||
|
||||
(watch 60 suckless-ref
|
||||
(display (string-append "suckless-repo" " " fixme-ref))
|
||||
|
||||
(display (string-append "suckless-repo" " " fixme-ref))
|
||||
(run-config
|
||||
|
||||
(display (string-append "REF" (lwwref:get-hbs2-git-reflog)))
|
||||
|
||||
(watch 300 (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(run (list opts (cwd suckless-repo-path))
|
||||
(string-append "git hbs2 import" " " suckless-repo ))
|
||||
|
||||
(display (string-append "Updated " suckless-repo " OK"))
|
||||
|
||||
)
|
||||
|
||||
(listen (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(display "subscribed suckless")
|
||||
|
||||
(run (list opts (cwd suckless-repo-path))
|
||||
(string-append "git hbs2 import" " " suckless-repo ))
|
||||
|
||||
(display (string-append "Updated " suckless-repo " OK")))
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
;; dbpipe
|
||||
|
||||
(watch 60 dbpipe-ref
|
||||
(display (string-append "dbpipe-repo" " " fixme-ref))
|
||||
|
||||
(display (string-append "dbpipe-repo" " " fixme-ref))
|
||||
(run-config
|
||||
|
||||
(display (string-append "REF" (lwwref:get-hbs2-git-reflog)))
|
||||
|
||||
(watch 300 (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(run (list opts (cwd dbpipe-repo-path))
|
||||
(string-append "git hbs2 import" " " dbpipe-repo ))
|
||||
|
||||
(display (string-append "Updated " dbpipe-repo " OK"))
|
||||
|
||||
)
|
||||
|
||||
(listen (lwwref:get-hbs2-git-reflog)
|
||||
|
||||
(display "subscribed dbpipe")
|
||||
|
||||
(run (list opts (cwd dbpipe-repo-path))
|
||||
(string-append "git hbs2 import" " " dbpipe-repo ))
|
||||
|
||||
(display (string-append "Updated " dbpipe-repo " OK")))
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -1,794 +0,0 @@
|
|||
{-# 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
|
||||
|
|
@ -1,201 +0,0 @@
|
|||
{-# Language TemplateHaskell #-}
|
||||
module HBS2.Git.Web.Assets where
|
||||
|
||||
import Data.FileEmbed
|
||||
import Data.ByteString
|
||||
import Data.Text (Text)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Lucid.Base
|
||||
|
||||
version :: Int
|
||||
version = 8
|
||||
|
||||
assetsDir :: [(FilePath, ByteString)]
|
||||
assetsDir = $(embedDir "hbs2-git-dashboard-assets/assets")
|
||||
|
||||
data IconType
|
||||
= IconCopy
|
||||
| IconCopyDone
|
||||
| IconLockClosed
|
||||
| IconGitCommit
|
||||
| IconGitFork
|
||||
| IconGitBranch
|
||||
| IconTag
|
||||
| IconFolderFilled
|
||||
| IconHaskell
|
||||
| IconMarkdown
|
||||
| IconNix
|
||||
| IconBash
|
||||
| IconPython
|
||||
| IconJavaScript
|
||||
| IconSql
|
||||
| IconSettingsFilled
|
||||
| IconFileFilled
|
||||
| IconRefresh
|
||||
| IconArrowUturnLeft
|
||||
| IconLicense
|
||||
| IconPinned
|
||||
| IconFixme
|
||||
|
||||
svgIcon :: Monad m => IconType -> HtmlT m ()
|
||||
svgIcon = toHtmlRaw . svgIconText
|
||||
|
||||
svgIconText :: IconType -> Text
|
||||
|
||||
svgIconText IconCopy = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
|
||||
<path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconCopyDone = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-copy-check" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M7 7m0 2.667a2.667 2.667 0 0 1 2.667 -2.667h8.666a2.667 2.667 0 0 1 2.667 2.667v8.666a2.667 2.667 0 0 1 -2.667 2.667h-8.666a2.667 2.667 0 0 1 -2.667 -2.667z" />
|
||||
<path d="M4.012 16.737a2.005 2.005 0 0 1 -1.012 -1.737v-10c0 -1.1 .9 -2 2 -2h10c.75 0 1.158 .385 1.5 1" />
|
||||
<path d="M11 14l2 2l4 -4" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconLockClosed = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-lock" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M5 13a2 2 0 0 1 2 -2h10a2 2 0 0 1 2 2v6a2 2 0 0 1 -2 2h-10a2 2 0 0 1 -2 -2v-6z" />
|
||||
<path d="M11 16a1 1 0 1 0 2 0a1 1 0 0 0 -2 0" />
|
||||
<path d="M8 11v-4a4 4 0 1 1 8 0v4" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconGitCommit = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-commit" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M12 12m-3 0a3 3 0 1 0 6 0a3 3 0 1 0 -6 0" />
|
||||
<path d="M12 3l0 6" />
|
||||
<path d="M12 15l0 6" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconGitFork = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-fork" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M12 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M7 8v2a2 2 0 0 0 2 2h6a2 2 0 0 0 2 -2v-2" />
|
||||
<path d="M12 12l0 4" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconGitBranch = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-branch" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M7 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
|
||||
<path d="M7 8l0 8" />
|
||||
<path d="M9 18h6a2 2 0 0 0 2 -2v-5" />
|
||||
<path d="M14 14l3 -3l3 3" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconTag = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-tag" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M7.5 7.5m-1 0a1 1 0 1 0 2 0a1 1 0 1 0 -2 0" />
|
||||
<path d="M3 6v5.172a2 2 0 0 0 .586 1.414l7.71 7.71a2.41 2.41 0 0 0 3.408 0l5.592 -5.592a2.41 2.41 0 0 0 0 -3.408l-7.71 -7.71a2 2 0 0 0 -1.414 -.586h-5.172a3 3 0 0 0 -3 3z" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconFolderFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-folder-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="#currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M9 3a1 1 0 0 1 .608 .206l.1 .087l2.706 2.707h6.586a3 3 0 0 1 2.995 2.824l.005 .176v8a3 3 0 0 1 -2.824 2.995l-.176 .005h-14a3 3 0 0 1 -2.995 -2.824l-.005 -.176v-11a3 3 0 0 1 2.824 -2.995l.176 -.005h4z" stroke-width="0" fill="currentColor" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconHaskell = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
|
||||
<title>Haskell</title>
|
||||
<path d="M0 3.535L5.647 12 0 20.465h4.235L9.883 12 4.235 3.535zm5.647 0L11.294 12l-5.647 8.465h4.235l3.53-5.29 3.53 5.29h4.234L9.883 3.535zm8.941 4.938l1.883 2.822H24V8.473zm2.824 4.232l1.882 2.822H24v-2.822z"/>
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconMarkdown = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
|
||||
<title>Markdown</title>
|
||||
<path d="M22.27 19.385H1.73A1.73 1.73 0 010 17.655V6.345a1.73 1.73 0 011.73-1.73h20.54A1.73 1.73 0 0124 6.345v11.308a1.73 1.73 0 01-1.73 1.731zM5.769 15.923v-4.5l2.308 2.885 2.307-2.885v4.5h2.308V8.078h-2.308l-2.307 2.885-2.308-2.885H3.46v7.847zM21.232 12h-2.309V8.077h-2.307V12h-2.308l3.461 4.039z"/>
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconNix = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
|
||||
<title>Nix</title>
|
||||
<path d="M7.352 1.592l-1.364.002L5.32 2.75l1.557 2.713-3.137-.008-1.32 2.34H14.11l-1.353-2.332-3.192-.006-2.214-3.865zm6.175 0l-2.687.025 5.846 10.127 1.341-2.34-1.59-2.765 2.24-3.85-.683-1.182h-1.336l-1.57 2.705-1.56-2.72zm6.887 4.195l-5.846 10.125 2.696-.008 1.601-2.76 4.453.016.682-1.183-.666-1.157-3.13-.008L21.778 8.1l-1.365-2.313zM9.432 8.086l-2.696.008-1.601 2.76-4.453-.016L0 12.02l.666 1.157 3.13.008-1.575 2.71 1.365 2.315L9.432 8.086zM7.33 12.25l-.006.01-.002-.004-1.342 2.34 1.59 2.765-2.24 3.85.684 1.182H7.35l.004-.006h.001l1.567-2.698 1.558 2.72 2.688-.026-.004-.006h.01L7.33 12.25zm2.55 3.93l1.354 2.332 3.192.006 2.215 3.865 1.363-.002.668-1.156-1.557-2.713 3.137.008 1.32-2.34H9.881Z"/>
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconBash = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-terminal-2" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M8 9l3 3l-3 3" />
|
||||
<path d="M13 15l3 0" />
|
||||
<path d="M3 4m0 2a2 2 0 0 1 2 -2h14a2 2 0 0 1 2 2v12a2 2 0 0 1 -2 2h-14a2 2 0 0 1 -2 -2z" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconPython = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
|
||||
<title>Python</title>
|
||||
<path d="M14.25.18l.9.2.73.26.59.3.45.32.34.34.25.34.16.33.1.3.04.26.02.2-.01.13V8.5l-.05.63-.13.55-.21.46-.26.38-.3.31-.33.25-.35.19-.35.14-.33.1-.3.07-.26.04-.21.02H8.77l-.69.05-.59.14-.5.22-.41.27-.33.32-.27.35-.2.36-.15.37-.1.35-.07.32-.04.27-.02.21v3.06H3.17l-.21-.03-.28-.07-.32-.12-.35-.18-.36-.26-.36-.36-.35-.46-.32-.59-.28-.73-.21-.88-.14-1.05-.05-1.23.06-1.22.16-1.04.24-.87.32-.71.36-.57.4-.44.42-.33.42-.24.4-.16.36-.1.32-.05.24-.01h.16l.06.01h8.16v-.83H6.18l-.01-2.75-.02-.37.05-.34.11-.31.17-.28.25-.26.31-.23.38-.2.44-.18.51-.15.58-.12.64-.1.71-.06.77-.04.84-.02 1.27.05zm-6.3 1.98l-.23.33-.08.41.08.41.23.34.33.22.41.09.41-.09.33-.22.23-.34.08-.41-.08-.41-.23-.33-.33-.22-.41-.09-.41.09zm13.09 3.95l.28.06.32.12.35.18.36.27.36.35.35.47.32.59.28.73.21.88.14 1.04.05 1.23-.06 1.23-.16 1.04-.24.86-.32.71-.36.57-.4.45-.42.33-.42.24-.4.16-.36.09-.32.05-.24.02-.16-.01h-8.22v.82h5.84l.01 2.76.02.36-.05.34-.11.31-.17.29-.25.25-.31.24-.38.2-.44.17-.51.15-.58.13-.64.09-.71.07-.77.04-.84.01-1.27-.04-1.07-.14-.9-.2-.73-.25-.59-.3-.45-.33-.34-.34-.25-.34-.16-.33-.1-.3-.04-.25-.02-.2.01-.13v-5.34l.05-.64.13-.54.21-.46.26-.38.3-.32.33-.24.35-.2.35-.14.33-.1.3-.06.26-.04.21-.02.13-.01h5.84l.69-.05.59-.14.5-.21.41-.28.33-.32.27-.35.2-.36.15-.36.1-.35.07-.32.04-.28.02-.21V6.07h2.09l.14.01zm-6.47 14.25l-.23.33-.08.41.08.41.23.33.33.23.41.08.41-.08.33-.23.23-.33.08-.41-.08-.41-.23-.33-.33-.23-.41-.08-.41.08z"/>
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconJavaScript = [qc|<svg role="img" width="24" height="24" viewBox="0 0 24 24" xmlns="http://www.w3.org/2000/svg">
|
||||
<title>JavaScript</title>
|
||||
<path d="M0 0h24v24H0V0zm22.034 18.276c-.175-1.095-.888-2.015-3.003-2.873-.736-.345-1.554-.585-1.797-1.14-.091-.33-.105-.51-.046-.705.15-.646.915-.84 1.515-.66.39.12.75.42.976.9 1.034-.676 1.034-.676 1.755-1.125-.27-.42-.404-.601-.586-.78-.63-.705-1.469-1.065-2.834-1.034l-.705.089c-.676.165-1.32.525-1.71 1.005-1.14 1.291-.811 3.541.569 4.471 1.365 1.02 3.361 1.244 3.616 2.205.24 1.17-.87 1.545-1.966 1.41-.811-.18-1.26-.586-1.755-1.336l-1.83 1.051c.21.48.45.689.81 1.109 1.74 1.756 6.09 1.666 6.871-1.004.029-.09.24-.705.074-1.65l.046.067zm-8.983-7.245h-2.248c0 1.938-.009 3.864-.009 5.805 0 1.232.063 2.363-.138 2.711-.33.689-1.18.601-1.566.48-.396-.196-.597-.466-.83-.855-.063-.105-.11-.196-.127-.196l-1.825 1.125c.305.63.75 1.172 1.324 1.517.855.51 2.004.675 3.207.405.783-.226 1.458-.691 1.811-1.411.51-.93.402-2.07.397-3.346.012-2.054 0-4.109 0-6.179l.004-.056z"/>
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconSql = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-file-type-sql" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M14 3v4a1 1 0 0 0 1 1h4" />
|
||||
<path d="M14 3v4a1 1 0 0 0 1 1h4" />
|
||||
<path d="M5 20.25c0 .414 .336 .75 .75 .75h1.25a1 1 0 0 0 1 -1v-1a1 1 0 0 0 -1 -1h-1a1 1 0 0 1 -1 -1v-1a1 1 0 0 1 1 -1h1.25a.75 .75 0 0 1 .75 .75" />
|
||||
<path d="M5 12v-7a2 2 0 0 1 2 -2h7l5 5v4" />
|
||||
<path d="M18 15v6h2" />
|
||||
<path d="M13 15a2 2 0 0 1 2 2v2a2 2 0 1 1 -4 0v-2a2 2 0 0 1 2 -2z" />
|
||||
<path d="M14 20l1.5 1.5" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconSettingsFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-settings-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M14.647 4.081a.724 .724 0 0 0 1.08 .448c2.439 -1.485 5.23 1.305 3.745 3.744a.724 .724 0 0 0 .447 1.08c2.775 .673 2.775 4.62 0 5.294a.724 .724 0 0 0 -.448 1.08c1.485 2.439 -1.305 5.23 -3.744 3.745a.724 .724 0 0 0 -1.08 .447c-.673 2.775 -4.62 2.775 -5.294 0a.724 .724 0 0 0 -1.08 -.448c-2.439 1.485 -5.23 -1.305 -3.745 -3.744a.724 .724 0 0 0 -.447 -1.08c-2.775 -.673 -2.775 -4.62 0 -5.294a.724 .724 0 0 0 .448 -1.08c-1.485 -2.439 1.305 -5.23 3.744 -3.745a.722 .722 0 0 0 1.08 -.447c.673 -2.775 4.62 -2.775 5.294 0zm-2.647 4.919a3 3 0 1 0 0 6a3 3 0 0 0 0 -6z" stroke-width="0" fill="currentColor" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconFileFilled = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-file-filled" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M12 2l.117 .007a1 1 0 0 1 .876 .876l.007 .117v4l.005 .15a2 2 0 0 0 1.838 1.844l.157 .006h4l.117 .007a1 1 0 0 1 .876 .876l.007 .117v9a3 3 0 0 1 -2.824 2.995l-.176 .005h-10a3 3 0 0 1 -2.995 -2.824l-.005 -.176v-14a3 3 0 0 1 2.824 -2.995l.176 -.005h5z" stroke-width="0" fill="currentColor" />
|
||||
<path d="M19 7h-4l-.001 -4.001z" stroke-width="0" fill="currentColor" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconRefresh = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-refresh" width="24" height="24" viewBox="0 0 24 24" stroke-width="2" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M20 11a8.1 8.1 0 0 0 -15.5 -2m-.5 -4v4h4" />
|
||||
<path d="M4 13a8.1 8.1 0 0 0 15.5 2m.5 4v-4h-4" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconArrowUturnLeft = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-arrow-uturn-left" width="24" height="24" viewBox="0 0 24 24" stroke-width="2" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M9 14l-4 -4l4 -4" />
|
||||
<path d="M5 10h11a4 4 0 1 1 0 8h-1" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconLicense = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-license" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M15 21h-9a3 3 0 0 1 -3 -3v-1h10v2a2 2 0 0 0 4 0v-14a2 2 0 1 1 2 2h-2m2 -4h-11a3 3 0 0 0 -3 3v11" />
|
||||
<path d="M9 7l4 0" />
|
||||
<path d="M9 11l4 0" />
|
||||
</svg>|]
|
||||
|
||||
svgIconText IconPinned = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-pinned" width="24" height="24" viewBox="0 0 24 24" stroke-width="1.5" stroke="currentColor" fill="none" stroke-linecap="round" stroke-linejoin="round">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M9 4v6l-2 4v2h10v-2l-2 -4v-6" />
|
||||
<path d="M12 16l0 5" />
|
||||
<path d="M8 4l8 0" />
|
||||
</svg>|]
|
||||
|
||||
|
||||
svgIconText IconFixme = [qc|
|
||||
<svg xmlns="http://www.w3.org/2000/svg"
|
||||
width="24"
|
||||
height="24"
|
||||
viewBox="0 0 24 24"
|
||||
fill="none"
|
||||
stroke="currentColor"
|
||||
stroke-width="2"
|
||||
stroke-linecap="round"
|
||||
stroke-linejoin="round"
|
||||
class="icon icon-tabler icons-tabler-outline icon-tabler-stack-3">
|
||||
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
|
||||
<path d="M12 2l-8 4l8 4l8 -4l-8 -4" />
|
||||
<path d="M4 10l8 4l8 -4" />
|
||||
<path d="M4 18l8 4l8 -4" />
|
||||
<path d="M4 14l8 4l8 -4" />
|
||||
</svg>|]
|
||||
|
||||
|
||||
|
|
@ -1,370 +0,0 @@
|
|||
/* fastpok CSS start */
|
||||
|
||||
:root {
|
||||
--pico-form-element-spacing-vertical: .5rem;
|
||||
--pico-form-element-spacing-horizontal: .625rem;
|
||||
}
|
||||
|
||||
[type=search] {
|
||||
--pico-border-radius: inherit;
|
||||
}
|
||||
|
||||
[role=search] {
|
||||
--pico-border-radius: inherit;
|
||||
}
|
||||
|
||||
[role=search]>:first-child {
|
||||
border-top-left-radius: var(--pico-border-radius);
|
||||
border-bottom-left-radius: var(--pico-border-radius);
|
||||
}
|
||||
|
||||
[role=search]>:last-child {
|
||||
border-top-right-radius: var(--pico-border-radius);
|
||||
border-bottom-right-radius: var(--pico-border-radius);
|
||||
}
|
||||
|
||||
body>footer, body>header, body>main {
|
||||
padding-block: 0;
|
||||
}
|
||||
|
||||
header>nav {
|
||||
border-bottom: var(--pico-border-width) solid var(--pico-muted-border-color);
|
||||
}
|
||||
|
||||
.wrapper {
|
||||
display: flex;
|
||||
}
|
||||
|
||||
|
||||
.hidden{
|
||||
display: none;
|
||||
}
|
||||
|
||||
.sidebar {
|
||||
width: 20rem;
|
||||
flex-shrink: 0;
|
||||
padding-top: var(--pico-block-spacing-vertical);
|
||||
padding-right: var(--pico-block-spacing-horizontal);
|
||||
padding-bottom: var(--pico-block-spacing-vertical);
|
||||
border-right: var(--pico-border-width) solid var(--pico-muted-border-color);
|
||||
display: flex;
|
||||
flex-direction: column;
|
||||
}
|
||||
|
||||
.content {
|
||||
padding-top: var(--pico-block-spacing-vertical);
|
||||
padding-bottom: var(--pico-block-spacing-vertical);
|
||||
padding-left: var(--pico-block-spacing-horizontal);
|
||||
overflow: auto;
|
||||
}
|
||||
|
||||
article {
|
||||
border: var(--pico-border-width) solid var(--pico-card-border-color);
|
||||
box-shadow: none;
|
||||
}
|
||||
|
||||
.repo-list-item {
|
||||
display: flex;
|
||||
justify-content: space-between;
|
||||
gap: var(--pico-block-spacing-horizontal);
|
||||
}
|
||||
|
||||
.repo-list-item-link-wrapper {
|
||||
display: flex;
|
||||
align-items: center;
|
||||
margin-bottom: var(--pico-typography-spacing-vertical);
|
||||
}
|
||||
|
||||
.copy-button {
|
||||
margin-left: calc(var(--pico-spacing) * .5);
|
||||
background-color: transparent;
|
||||
border: none;
|
||||
padding: 0;
|
||||
border-radius: 0;
|
||||
box-shadow: none;
|
||||
color: var(--pico-secondary);
|
||||
transition: color var(--pico-transition);
|
||||
}
|
||||
|
||||
.copy-button:hover {
|
||||
color: var(--pico-secondary-hover);
|
||||
}
|
||||
|
||||
.copy-button .icon {
|
||||
width: 1.125rem;
|
||||
height: 1.125rem;
|
||||
}
|
||||
|
||||
.inline-icon-wrapper {
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
.inline-icon-wrapper .icon {
|
||||
margin-right: calc(var(--pico-spacing) * .25);
|
||||
vertical-align: middle;
|
||||
}
|
||||
|
||||
.info-block {
|
||||
margin-bottom: var(--pico-block-spacing-vertical);
|
||||
}
|
||||
|
||||
.repo-menu {
|
||||
--pico-nav-breadcrumb-divider: '|';
|
||||
}
|
||||
|
||||
.repo-menu li.active {
|
||||
color: var(--pico-primary);
|
||||
}
|
||||
|
||||
aside li {
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
aside ul {
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
aside li :where(a,[role=link]):not(:hover) {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.sidebar-title {
|
||||
margin-bottom: calc(var(--pico-typography-spacing-vertical) * .25);
|
||||
}
|
||||
|
||||
.issue-info-card {
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
.issue-info-card>header {
|
||||
margin: 0;
|
||||
}
|
||||
|
||||
.issue-info-card>header h5 {
|
||||
color: inherit;
|
||||
margin-bottom: 0;
|
||||
}
|
||||
|
||||
.issue-info-table tr:hover {
|
||||
background-color: var(--pico-background-color);
|
||||
}
|
||||
|
||||
.issue-info-table td,
|
||||
.issue-info-table th {
|
||||
border-bottom-color: var(--pico-card-border-color);
|
||||
}
|
||||
|
||||
.issue-info-table tr:last-child>td,
|
||||
.issue-info-table tr:last-child>th {
|
||||
border-bottom: none;
|
||||
}
|
||||
|
||||
.issue-info-table tr:last-child>td:first-child,
|
||||
.issue-info-table tr:last-child>th:first-child {
|
||||
border-bottom-left-radius: var(--pico-border-radius);
|
||||
}
|
||||
|
||||
.issue-info-table tr:last-child>td:last-child,
|
||||
.issue-info-table tr:last-child>th:last-child {
|
||||
border-bottom-right-radius: var(--pico-border-radius);
|
||||
}
|
||||
|
||||
.issue-info-card .issue-id {
|
||||
cursor: pointer;
|
||||
border-bottom: none;
|
||||
color: var(--pico-secondary);
|
||||
}
|
||||
|
||||
|
||||
.issue-info-card .issue-id:hover {
|
||||
text-decoration: underline;
|
||||
color: var(--pico-secondary-hover);
|
||||
}
|
||||
|
||||
/* Tailwind-style classes */
|
||||
.mb-0 {
|
||||
margin-bottom: 0;
|
||||
}
|
||||
|
||||
.mb-1 {
|
||||
margin-bottom: var(--pico-spacing);
|
||||
}
|
||||
|
||||
.p-0 {
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
.py-0 {
|
||||
padding-top: 0;
|
||||
padding-bottom: 0;
|
||||
}
|
||||
|
||||
.w-full {
|
||||
width: 100%;
|
||||
}
|
||||
|
||||
.whitespace-nowrap {
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
.font-normal {
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
.text-secondary {
|
||||
color: var(--pico-secondary);
|
||||
}
|
||||
|
||||
.overflow-x-auto {
|
||||
overflow-x: auto;
|
||||
}
|
||||
|
||||
/* fastpok CSS end */
|
||||
|
||||
|
||||
ul.misc-menu {
|
||||
margin: 0 0 0 0;
|
||||
padding: 0 0 0 0;
|
||||
}
|
||||
|
||||
ul.misc-menu li {
|
||||
padding: 0 0 0 0;
|
||||
margin-right: 1em;
|
||||
display: inline;
|
||||
}
|
||||
|
||||
.mono {
|
||||
font-family: 'Courier New', Courier, monospace;
|
||||
}
|
||||
|
||||
.tree {
|
||||
font-weight: 600;
|
||||
}
|
||||
|
||||
td.tree-locator {
|
||||
border-bottom: none;
|
||||
}
|
||||
|
||||
td.tree-locator span {
|
||||
margin-right: .5rem;
|
||||
}
|
||||
|
||||
tr.commit-brief-title td,
|
||||
tr.commit-brief-title th {
|
||||
border-bottom: none;
|
||||
vertical-align: top;
|
||||
}
|
||||
|
||||
tr.commit-brief-details td,
|
||||
tr.commit-brief-details th {
|
||||
border-top: none;
|
||||
}
|
||||
|
||||
td.commit-brief-title {
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
tr.commit-brief-last td {
|
||||
border: none;
|
||||
}
|
||||
|
||||
tr.commit-brief-last th {
|
||||
border: none;
|
||||
}
|
||||
|
||||
td.commit-icon {
|
||||
width: 4rem;
|
||||
/* width: px; */
|
||||
}
|
||||
|
||||
td.commit-hash {
|
||||
width: 10rem;
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
table.minimal {
|
||||
}
|
||||
|
||||
table.minimal tr td {
|
||||
border: none;
|
||||
padding: 0.15em;
|
||||
}
|
||||
|
||||
table.minimal tr {
|
||||
border: none;
|
||||
}
|
||||
|
||||
table tr:hover {
|
||||
background-color: #f1f1f1;
|
||||
}
|
||||
|
||||
.lim-text {
|
||||
max-width: 80ch;
|
||||
word-wrap: break-word;
|
||||
}
|
||||
|
||||
|
||||
pre > code.sourceCode { white-space: pre; position: relative; }
|
||||
pre > code.sourceCode > span { line-height: 1.25; }
|
||||
pre > code.sourceCode > span:empty { height: 1.2em; }
|
||||
.sourceCode { overflow: auto; }
|
||||
code.sourceCode > span { color: inherit; text-decoration: inherit; overflow: auto; }
|
||||
div.sourceCode { margin: 1em 0; overflow: auto; }
|
||||
pre.sourceCode { margin: 0; }
|
||||
@media screen {
|
||||
div.sourceCode { overflow: auto; max-width: 120rem; }
|
||||
}
|
||||
@media print {
|
||||
pre > code.sourceCode { white-space: pre-wrap; }
|
||||
pre > code.sourceCode > span { display: inline-block; text-indent: -5em; padding-left: 5em; }
|
||||
}
|
||||
pre.numberSource code
|
||||
{ counter-reset: source-line 0; }
|
||||
pre.numberSource code > span
|
||||
{ position: relative; left: -4em; counter-increment: source-line; }
|
||||
pre.numberSource code > span > a:first-child::before
|
||||
{ content: counter(source-line);
|
||||
position: relative; left: -1em; text-align: right; vertical-align: baseline;
|
||||
border: none; display: inline-block;
|
||||
-webkit-touch-callout: none; -webkit-user-select: none;
|
||||
-khtml-user-select: none; -moz-user-select: none;
|
||||
-ms-user-select: none; user-select: none;
|
||||
padding: 0 4px; width: 4em;
|
||||
color: #aaaaaa;
|
||||
}
|
||||
pre.numberSource { margin-left: 3em; border-left: 1px solid #aaaaaa; padding-left: 4px; }
|
||||
@media screen {
|
||||
pre > code.sourceCode > span > a:first-child::before { text-decoration: underline; }
|
||||
}
|
||||
code span.al { color: #ef2929; } /* Alert */
|
||||
code span.an { color: #8f5902; font-weight: bold; font-style: italic; } /* Annotation */
|
||||
code span.at { color: #204a87; } /* Attribute */
|
||||
code span.bn { color: #0000cf; } /* BaseN */
|
||||
code span.cf { color: #204a87; font-weight: bold; } /* ControlFlow */
|
||||
code span.ch { color: #4e9a06; } /* Char */
|
||||
code span.cn { color: #8f5902; } /* Constant */
|
||||
code span.co { color: #8f5902; font-style: italic; } /* Comment */
|
||||
code span.cv { color: #8f5902; font-weight: bold; font-style: italic; } /* CommentVar */
|
||||
code span.do { color: #8f5902; font-weight: bold; font-style: italic; } /* Documentation */
|
||||
code span.dt { color: #204a87; } /* DataType */
|
||||
code span.dv { color: #0000cf; } /* DecVal */
|
||||
code span.er { color: #a40000; font-weight: bold; } /* Error */
|
||||
code span.ex { } /* Extension */
|
||||
code span.fl { color: #0000cf; } /* Float */
|
||||
code span.fu { color: #204a87; font-weight: bold; } /* Function */
|
||||
code span.im { } /* Import */
|
||||
code span.in { color: #8f5902; font-weight: bold; font-style: italic; } /* Information */
|
||||
code span.kw { color: #204a87; font-weight: bold; } /* Keyword */
|
||||
code span.op { color: #ce5c00; font-weight: bold; } /* Operator */
|
||||
code span.ot { color: #8f5902; } /* Other */
|
||||
code span.pp { color: #8f5902; font-style: italic; } /* Preprocessor */
|
||||
code span.sc { color: #ce5c00; font-weight: bold; } /* SpecialChar */
|
||||
code span.ss { color: #4e9a06; } /* SpecialString */
|
||||
code span.st { color: #4e9a06; } /* String */
|
||||
code span.va { color: #000000; } /* Variable */
|
||||
code span.vs { color: #4e9a06; } /* VerbatimString */
|
||||
code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */
|
||||
|
||||
|
||||
|
||||
|
||||
File diff suppressed because one or more lines are too long
|
|
@ -1,142 +0,0 @@
|
|||
module HBS2.Git.DashBoard.Fixme
|
||||
( F.HasPredicate(..)
|
||||
, F.HasLimit(..)
|
||||
, HasItemOrder(..)
|
||||
, ItemOrder(..)
|
||||
, Reversed(..)
|
||||
, F.SelectPredicate(..)
|
||||
, WithLimit(..)
|
||||
, QueryOffset
|
||||
, QueryLimit
|
||||
, runInFixme
|
||||
, countFixme
|
||||
, countFixmeByAttribute
|
||||
, listFixme
|
||||
, getFixme
|
||||
, RunInFixmeError(..)
|
||||
, Fixme(..)
|
||||
, FixmeKey(..)
|
||||
, FixmeTitle(..)
|
||||
, FixmeTag(..)
|
||||
, FixmePlainLine(..)
|
||||
, FixmeAttrName(..)
|
||||
, FixmeAttrVal(..)
|
||||
, FixmeOpts(..)
|
||||
, fixmePageSize
|
||||
, fixmeGet
|
||||
) where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
import Fixme.State qualified as F
|
||||
import Fixme.State ( HasPredicate(..)
|
||||
, HasLimit(..)
|
||||
, HasItemOrder(..)
|
||||
, WithLimit(..)
|
||||
, QueryOffset
|
||||
, QueryLimit
|
||||
, ItemOrder
|
||||
, Reversed
|
||||
)
|
||||
import Fixme.Types
|
||||
import Fixme.Config
|
||||
|
||||
import DBPipe.SQLite (shutdown)
|
||||
|
||||
import Data.Either
|
||||
import Data.Generics.Product.Fields (field)
|
||||
|
||||
data RunInFixmeError =
|
||||
FixmeRefChanNotFound RepoLww
|
||||
deriving stock (Generic, Typeable, Show)
|
||||
|
||||
instance Exception RunInFixmeError
|
||||
|
||||
fixmePageSize :: QueryLimit
|
||||
fixmePageSize = 100
|
||||
|
||||
|
||||
-- TODO: less-hacky-approach
|
||||
-- этот код подразумевает, что мы знаем довольно много деталей
|
||||
-- реализации про fixme-new
|
||||
--
|
||||
-- Хорошо бы как-то абстрагировать, изолировать и т.п.
|
||||
--
|
||||
runInFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoLww
|
||||
-> FixmeM m a
|
||||
-> m a
|
||||
|
||||
runInFixme repo m = do
|
||||
|
||||
denv <- ask
|
||||
|
||||
fixmeRChan <- withDashBoardEnv denv $ selectRepoFixmeRefChan repo
|
||||
>>= orThrow (FixmeRefChanNotFound repo)
|
||||
|
||||
p <- fixmeDataPath fixmeRChan
|
||||
|
||||
-- TODO: check-if-database-exists
|
||||
|
||||
fenv <- fixmeEnvBare
|
||||
fo <- newTVarIO (FixmeOpts True)
|
||||
|
||||
twd <- newTVarIO p
|
||||
let fenvNew = fenv & set (field @"fixmeEnvWorkDir") twd
|
||||
& set (field @"fixmeEnvOpts") fo
|
||||
|
||||
flip runContT pure do
|
||||
dbe <- lift $ withFixmeEnv fenvNew $ F.withState ask
|
||||
|
||||
void $ ContT $ bracket none (const $ shutdown False dbe)
|
||||
|
||||
lift $ withFixmeEnv fenvNew do
|
||||
dbp <- localDBPath
|
||||
wd <- fixmeWorkDir
|
||||
cfg <- localConfig
|
||||
trace $ "fixme:dir" <+> pretty wd
|
||||
trace $ "fixme:config" <+> pretty cfg
|
||||
trace $ "fixme:db" <+> pretty dbp
|
||||
|
||||
m
|
||||
|
||||
listFixme :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
, HasPredicate q
|
||||
, HasLimit q
|
||||
, HasItemOrder q
|
||||
) => RepoLww -> q -> m [Fixme]
|
||||
listFixme repo q = do
|
||||
runInFixme repo $ F.listFixme q
|
||||
-- FIXME: error-handling
|
||||
-- at least print log entry
|
||||
& try @_ @SomeException
|
||||
<&> fromRight mempty
|
||||
|
||||
|
||||
getFixme :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
) => RepoLww -> FixmeKey -> m (Maybe Fixme)
|
||||
getFixme repo fk = do
|
||||
-- FIXME: error-handling
|
||||
-- at least print log entry
|
||||
try @_ @SomeException (runInFixme repo $ runMaybeT do
|
||||
k <- lift (F.selectFixmeKey (coerce fk)) >>= toMPlus
|
||||
lift (F.getFixme k) >>= toMPlus ) <&> fromRight Nothing
|
||||
|
||||
countFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> m (Maybe Int)
|
||||
countFixme repo = do
|
||||
runInFixme repo $ F.countFixme
|
||||
& try @_ @SomeException
|
||||
<&> either (const Nothing) Just
|
||||
|
||||
countFixmeByAttribute :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> String -> m [(FixmeAttrVal, Int)]
|
||||
countFixmeByAttribute repo name = do
|
||||
runInFixme repo $ F.countByAttribute (fromString name)
|
||||
& try @_ @SomeException
|
||||
<&> fromRight mempty
|
||||
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
module HBS2.Git.DashBoard.Manifest where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.Data.RepoHead
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Data.Either
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
|
||||
pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c
|
||||
pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:"
|
||||
, ListVal [ SymbolVal "refchan", SignPubKeyLike x
|
||||
]]
|
||||
|
||||
|
||||
pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c
|
||||
pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob"
|
||||
, SymbolVal (Id syn)
|
||||
, LitStrVal name
|
||||
, asGitHash -> Just hash
|
||||
]
|
||||
{-# COMPLETE PinnedRefBlob #-}
|
||||
|
||||
asGitHash :: forall c . Syntax c -> Maybe GitHash
|
||||
asGitHash = \case
|
||||
LitStrVal s -> fromStringMay (Text.unpack s)
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
|
||||
parseManifest :: Monad m => RepoHead -> m ([Syntax C], Text)
|
||||
parseManifest mhead = do
|
||||
|
||||
let rawManifest = maybe mempty Text.lines (_repoManifest mhead)
|
||||
|
||||
w <- S.toList_ do
|
||||
flip fix rawManifest $ \next ss -> do
|
||||
case ss of
|
||||
( "" : rest ) -> S.yield (Right (Text.stripStart (Text.unlines rest)))
|
||||
( a : rest ) -> S.yield (Left a ) >> next rest
|
||||
[] -> pure ()
|
||||
|
||||
let meta = Text.unlines (lefts w)
|
||||
& Text.unpack
|
||||
& parseTop
|
||||
& fromRight mempty
|
||||
|
||||
let manifest = mconcat $ rights w
|
||||
|
||||
pure (meta, manifest)
|
||||
|
||||
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module HBS2.Git.DashBoard.Prelude
|
||||
( module HBS2.Git.DashBoard.Prelude
|
||||
, module HBS2.Prelude.Plated
|
||||
, module HBS2.Data.Types.Refs
|
||||
, module HBS2.Base58
|
||||
, module HBS2.Merkle
|
||||
, module HBS2.Net.Proto.Service
|
||||
, module HBS2.Storage
|
||||
, module API
|
||||
, module Config
|
||||
, module Logger
|
||||
, module Maybe
|
||||
, module Reader
|
||||
, module Coerce
|
||||
, module TransCont
|
||||
, module TransMaybe
|
||||
, module Lens.Micro.Platform
|
||||
, module UnliftIO
|
||||
, module Codec.Serialise
|
||||
, GitRef(..), GitHash(..), GitObjectType(..)
|
||||
, pattern SignPubKeyLike
|
||||
, qc, q
|
||||
) where
|
||||
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Base58
|
||||
import HBS2.Net.Proto.Service hiding (encode,decode)
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Storage
|
||||
import HBS2.Merkle
|
||||
|
||||
import HBS2.System.Logger.Simple.ANSI as Logger
|
||||
import HBS2.Misc.PrettyStuff as Logger
|
||||
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
import HBS2.Peer.RPC.API.RefChan as API
|
||||
import HBS2.Peer.RPC.API.RefLog as API
|
||||
import HBS2.Peer.RPC.API.Peer as API
|
||||
import HBS2.Peer.RPC.API.LWWRef as API
|
||||
|
||||
import HBS2.Peer.Proto.RefLog as API
|
||||
import HBS2.Peer.Proto.LWWRef as API
|
||||
import HBS2.Peer.Proto.RefChan.Types as API
|
||||
import HBS2.Peer.Proto.RefChan.RefChanUpdate as API
|
||||
|
||||
import HBS2.Git.Local
|
||||
|
||||
import Data.Config.Suckless as Config
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc,q)
|
||||
|
||||
import Data.Maybe as Maybe
|
||||
import Control.Monad.Reader as Reader
|
||||
import Data.Coerce as Coerce
|
||||
import Control.Monad.Trans.Cont as TransCont
|
||||
import Control.Monad.Trans.Maybe as TransMaybe
|
||||
|
||||
import Lens.Micro.Platform hiding (at)
|
||||
|
||||
import UnliftIO
|
||||
|
||||
import Codec.Serialise
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,162 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module HBS2.Git.DashBoard.State.Commits where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
|
||||
import HBS2.Git.Local
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.Text qualified as Text
|
||||
import Data.Time (UTCTime,LocalTime)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import Data.Either
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
class Monoid a => FromQueryParams a where
|
||||
fromQueryParams :: [(Text,Text)] -> a
|
||||
|
||||
data CommitListStyle = CommitListBrief
|
||||
|
||||
data SelectCommitsPred =
|
||||
SelectCommitsPred
|
||||
{ _commitListStyle :: CommitListStyle
|
||||
, _commitPredOffset :: Int
|
||||
, _commitPredLimit :: Int
|
||||
, _commitRef :: Maybe GitRef
|
||||
}
|
||||
|
||||
makeLenses ''SelectCommitsPred
|
||||
|
||||
instance Semigroup SelectCommitsPred where
|
||||
(<>) _ b = mempty & set commitListStyle (view commitListStyle b)
|
||||
& set commitPredOffset (view commitPredOffset b)
|
||||
& set commitPredLimit (view commitPredLimit b)
|
||||
& set commitRef (view commitRef b)
|
||||
|
||||
instance Monoid SelectCommitsPred where
|
||||
mempty = SelectCommitsPred CommitListBrief 0 100 Nothing
|
||||
|
||||
briefCommits :: SelectCommitsPred
|
||||
briefCommits = mempty
|
||||
|
||||
|
||||
instance FromQueryParams SelectCommitsPred where
|
||||
fromQueryParams args = do
|
||||
let val = headMay [ GitRef (fromString (Text.unpack v)) | ("ref", v) <- args ]
|
||||
mempty & set commitRef val
|
||||
|
||||
newtype Author = Author Text
|
||||
deriving stock (Generic,Data)
|
||||
deriving newtype (Show)
|
||||
|
||||
|
||||
newtype CommitListItemHash = CommitListItemHash GitHash
|
||||
deriving stock (Generic,Data)
|
||||
deriving newtype (Show,Pretty)
|
||||
|
||||
newtype CommitListItemTime = CommitListItemTime Integer
|
||||
deriving stock (Generic,Data)
|
||||
deriving newtype (Show)
|
||||
|
||||
newtype CommitListItemTitle = CommitListItemTitle Text
|
||||
deriving stock (Generic,Data)
|
||||
deriving newtype (Show)
|
||||
|
||||
newtype CommitListItemAuthor = CommitListItemAuthor Author
|
||||
deriving stock (Generic,Data)
|
||||
deriving newtype (Show)
|
||||
|
||||
data CommitListItem =
|
||||
CommitListItemBrief
|
||||
{ commitListHash :: CommitListItemHash
|
||||
, commitListTime :: CommitListItemTime
|
||||
, commitListTitle :: CommitListItemTitle
|
||||
, commitListAuthor :: CommitListItemAuthor
|
||||
}
|
||||
deriving stock (Generic,Data)
|
||||
|
||||
selectCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> SelectCommitsPred
|
||||
-> m [CommitListItem]
|
||||
|
||||
selectCommits lww SelectCommitsPred{..} = do
|
||||
let lim = _commitPredLimit
|
||||
let off = _commitPredOffset
|
||||
let delim = "|||" :: Text
|
||||
dir <- repoDataPath lww
|
||||
|
||||
let what = maybe "--all" (show . pretty) _commitRef
|
||||
|
||||
let cmd = case _commitListStyle of
|
||||
CommitListBrief -> do
|
||||
let fmt = [qc|--pretty=format:"%H{delim}%at{delim}%an{delim}%s"|] :: String
|
||||
[qc|git --git-dir={dir} log {what} --max-count {lim} --skip {off} {fmt}|]
|
||||
|
||||
debug $ red "selectCommits" <+> pretty cmd
|
||||
|
||||
ls <- gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> LBS8.lines
|
||||
<&> fmap (Text.decodeUtf8 . LBS8.toStrict)
|
||||
|
||||
S.toList_ do
|
||||
for_ ls $ \l -> do
|
||||
case Text.splitOn "|||" l of
|
||||
z@[cohash,ts,au,msg] -> do
|
||||
|
||||
let utc = readMay @Integer (Text.unpack ts)
|
||||
<&> CommitListItemTime
|
||||
|
||||
let hash = fromStringMay @GitHash (Text.unpack cohash)
|
||||
<&> CommitListItemHash
|
||||
|
||||
let co = CommitListItemBrief
|
||||
<$> hash
|
||||
<*> utc
|
||||
<*> pure (CommitListItemTitle msg)
|
||||
<*> pure (CommitListItemAuthor (Author au))
|
||||
|
||||
maybe1 co none S.yield
|
||||
|
||||
_ -> none
|
||||
|
||||
getCommitRawBrief :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> m Text
|
||||
|
||||
getCommitRawBrief lww hash = do
|
||||
|
||||
dir <- repoDataPath lww
|
||||
|
||||
let cmd = [qc|git --git-dir={dir} show --stat {pretty hash}|]
|
||||
|
||||
debug $ red "getCommitRawBrief" <+> viaShow cmd
|
||||
|
||||
gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> Text.decodeUtf8 . LBS8.toStrict
|
||||
|
||||
getCommitRawPatch :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> m Text
|
||||
|
||||
getCommitRawPatch lww hash = do
|
||||
|
||||
dir <- repoDataPath lww
|
||||
|
||||
let cmd = [qc|git --git-dir={dir} show {pretty hash}|]
|
||||
|
||||
debug $ red "getCommitRawPatch" <+> viaShow cmd
|
||||
|
||||
gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> Text.decodeUtf8 . LBS8.toStrict
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
module HBS2.Git.DashBoard.State.Index
|
||||
( module HBS2.Git.DashBoard.State.Index
|
||||
, module HBS2.Git.DashBoard.State.Index.Channels
|
||||
, module HBS2.Git.DashBoard.State.Index.Peer
|
||||
|
||||
) where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State.Index.Channels
|
||||
import HBS2.Git.DashBoard.State.Index.Peer
|
||||
|
||||
updateIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndex = do
|
||||
debug "updateIndex"
|
||||
updateIndexFromPeer
|
||||
updateIndexFromChannels
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
module HBS2.Git.DashBoard.State.Index.Channels where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
|
||||
import DBPipe.SQLite hiding (insert)
|
||||
import DBPipe.SQLite.Generic as G
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
updateIndexFromChannels :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromChannels = do
|
||||
debug "updateIndexChannels"
|
||||
|
||||
rchanAPI <- asks _refChanAPI
|
||||
sto <- asks _sto
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
es <- lift getIndexEntries
|
||||
|
||||
for_ es $ \rc -> do
|
||||
callCC \next -> do
|
||||
debug $ red (pretty (AsBase58 rc))
|
||||
|
||||
h <- lift (callRpcWaitMay @RpcRefChanGet (1 :: Timeout 'Seconds) rchanAPI rc)
|
||||
<&> join
|
||||
>>= maybe (next ()) pure
|
||||
|
||||
debug $ "rechan val" <+> red (pretty h)
|
||||
|
||||
txs <- S.toList_ do
|
||||
walkMerkle @[HashRef] (coerce h) (getBlock sto) $ \case
|
||||
Left{} -> pure ()
|
||||
Right hs -> mapM_ S.yield hs
|
||||
|
||||
for_ txs $ \txh -> void $ runMaybeT do
|
||||
|
||||
done <- lift $ lift $ withState do
|
||||
select @(Only Int)
|
||||
[qc|select 1 from processed where hash = ? limit 1|]
|
||||
(Only (TxHash txh)) <&> isJust . listToMaybe
|
||||
|
||||
guard (not done)
|
||||
|
||||
tx@GitIndexTx{..} <- getBlock sto (coerce txh)
|
||||
>>= toMPlus
|
||||
>>= readProposeTranMay @(GitIndexTx 'HBS2Basic) @L4Proto
|
||||
>>= toMPlus
|
||||
|
||||
lift $ lift $ withState $ transactional do
|
||||
let nm = [ RepoName n | GitIndexRepoName n <- universeBi gitIndexTxPayload ] & headMay
|
||||
let bri = [ RepoBrief n | GitIndexRepoBrief n <- universeBi gitIndexTxPayload ] & headMay
|
||||
|
||||
insert @RepoTable $ onConflictIgnore @RepoTable (Only (RepoLww gitIndexTxRef))
|
||||
|
||||
insert @RepoChannelTable $
|
||||
onConflictIgnore @RepoChannelTable (RepoLww gitIndexTxRef, RepoChannel rc)
|
||||
|
||||
-- FIXME: on-conflict-update!
|
||||
for_ nm $ \n -> do
|
||||
insert @RepoNameTable $
|
||||
onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
|
||||
|
||||
for_ bri $ \n -> do
|
||||
insert @RepoBriefTable $
|
||||
onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
|
||||
|
||||
lift $ withState $ transactional do
|
||||
for_ txs $ \t -> do
|
||||
insert @TxProcessedTable $ onConflictIgnore @TxProcessedTable (Only (TxHash t))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,146 +0,0 @@
|
|||
module HBS2.Git.DashBoard.State.Index.Peer where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Manifest
|
||||
import HBS2.Git.Data.LWWBlock
|
||||
import HBS2.Git.Data.Tx.Git
|
||||
|
||||
import HBS2.Hash
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import System.Process.Typed
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
seconds = TimeoutSec
|
||||
|
||||
|
||||
addRepoIndexJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
addRepoIndexJob lww = do
|
||||
|
||||
e <- ask
|
||||
let wip = _repoCommitIndexWIP e
|
||||
|
||||
n <- atomically do
|
||||
modifyTVar wip (HM.insertWith (+) (coerce lww) 1)
|
||||
readTVar wip <&> HM.lookup (coerce lww) <&> fromMaybe 0
|
||||
|
||||
when ( n < 2 ) do
|
||||
addJob $ withDashBoardEnv e do
|
||||
buildCommitTreeIndex (coerce lww)
|
||||
`finally` do
|
||||
atomically do
|
||||
modifyTVar wip (HM.adjust pred (coerce lww))
|
||||
|
||||
updateFixmeFor :: ( MonadUnliftIO m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> RepoLww
|
||||
-> MyRefChan
|
||||
-> m ()
|
||||
updateFixmeFor (RepoLww lw) f = do
|
||||
p <- fixmeDataPath f
|
||||
debug $ red "UPDATE-FIXME-FOR" <+> pretty (AsBase58 lw) <+> pretty (AsBase58 f) <+> pretty p
|
||||
|
||||
let rcp = show $ pretty (AsBase58 f)
|
||||
|
||||
mkdir p
|
||||
|
||||
let cmdStr = [qc|fixme-new refchan {rcp} and fixme:refchan:import|]
|
||||
let cmd = shell cmdStr & setWorkingDir p
|
||||
|
||||
debug $ "run fixme for:" <+> pretty rcp <+> pretty cmdStr
|
||||
|
||||
void $ runProcess cmd
|
||||
|
||||
|
||||
updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromPeer = do
|
||||
debug "updateIndexFromPeer"
|
||||
|
||||
peer <- asks _peerAPI
|
||||
reflog <- asks _refLogAPI
|
||||
lwwAPI <- asks _lwwRefAPI
|
||||
sto <- asks _sto
|
||||
|
||||
|
||||
polls <- callRpcWaitMay @RpcPollList2 (TimeoutSec 1) peer (Just "lwwref", Nothing)
|
||||
<&> join . maybeToList
|
||||
<&> fmap (LWWRefKey @HBS2Basic . view _1)
|
||||
|
||||
repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do
|
||||
|
||||
lwval <- liftIO (callRpcWaitMay @RpcLWWRefGet (seconds 1) lwwAPI r)
|
||||
>>= toMPlus >>= toMPlus
|
||||
|
||||
(lw,blk) <- readLWWBlock sto r >>= toMPlus
|
||||
let rk = lwwRefLogPubKey blk
|
||||
|
||||
lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk)
|
||||
|
||||
|
||||
for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do
|
||||
|
||||
mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk)
|
||||
<&> join
|
||||
|
||||
for_ mhead $ \mh -> do
|
||||
|
||||
txs <- S.toList_ $ do
|
||||
walkMerkle @[HashRef] (fromHashRef mh) (getBlock sto) $ \case
|
||||
Left{} -> do
|
||||
pure ()
|
||||
|
||||
Right hxs -> do
|
||||
for_ hxs $ \htx -> void $ runMaybeT do
|
||||
|
||||
done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
|
||||
|
||||
guard (not done)
|
||||
|
||||
getBlock sto (fromHashRef htx) >>= toMPlus
|
||||
<&> deserialiseOrFail @(RefLogUpdate L4Proto)
|
||||
>>= toMPlus
|
||||
>>= unpackTx
|
||||
>>= \(n,h,blk) -> lift (S.yield (n,htx,blk))
|
||||
|
||||
|
||||
headz <- S.toList_ do
|
||||
for_ txs $ \(n,tx,blk) -> void $ runMaybeT do
|
||||
(rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus
|
||||
debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw
|
||||
(man, _) <- parseManifest rhead
|
||||
let fme = headMay [ x | FixmeRefChanP x <- man ]
|
||||
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme)
|
||||
|
||||
withState $ transactional do
|
||||
-- withState do
|
||||
for_ headz $ \(l, tx, rh, rhead, fme) -> do
|
||||
let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
|
||||
insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
|
||||
|
||||
insertProcessed (HashRef $ hashObject @HbSync (serialise (l,coerce @_ @HashRef tx)))
|
||||
|
||||
for_ fme $ \f -> do
|
||||
insertRepoFixme l rlwwseq f
|
||||
|
||||
-- WTF?
|
||||
env <- ask
|
||||
buildCommitTreeIndex (coerce lw)
|
||||
|
||||
fxe <- selectRepoFixme
|
||||
|
||||
for_ fxe $ \(r,f) -> do
|
||||
allowed <- checkFixmeAllowed r
|
||||
when allowed do
|
||||
env <-ask
|
||||
addJob (withDashBoardEnv env $ updateFixmeFor r f)
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,174 +0,0 @@
|
|||
{-# 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
|
||||
) where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
|
||||
import HBS2.Git.Data.Tx.Index
|
||||
|
||||
import HBS2.Net.Messaging.Unix
|
||||
|
||||
import DBPipe.SQLite
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Data.Word
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Text qualified as Text
|
||||
|
||||
type MyRefChan = RefChanId L4Proto
|
||||
type MyRefLogKey = RefLogKey 'HBS2Basic
|
||||
|
||||
data HttpPortOpt
|
||||
|
||||
data DevelopAssetsOpt
|
||||
|
||||
instance HasCfgKey HttpPortOpt a where
|
||||
key = "port"
|
||||
|
||||
|
||||
instance HasCfgKey DevelopAssetsOpt a where
|
||||
key = "develop-assets"
|
||||
|
||||
data RunDashBoardOpts = RunDashBoardOpts
|
||||
{ configPath :: Maybe FilePath }
|
||||
|
||||
instance Monoid RunDashBoardOpts where
|
||||
mempty = RunDashBoardOpts Nothing
|
||||
|
||||
instance Semigroup RunDashBoardOpts where
|
||||
(<>) _ b = RunDashBoardOpts { configPath = configPath b }
|
||||
|
||||
|
||||
data DashBoardEnv =
|
||||
DashBoardEnv
|
||||
{ _peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, _refLogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, _refChanAPI :: ServiceCaller RefChanAPI UNIX
|
||||
, _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, _sto :: AnyStorage
|
||||
, _dataDir :: FilePath
|
||||
, _db :: TVar (Maybe DBPipeEnv)
|
||||
, _pipeline :: TQueue (IO ())
|
||||
, _dashBoardHttpPort :: TVar (Maybe Word16)
|
||||
, _dashBoardDevAssets :: TVar (Maybe FilePath)
|
||||
, _dashBoardBaseUrl :: TVar (Maybe Text)
|
||||
, _dashBoardIndexIgnoreCaches :: TVar Bool
|
||||
, _repoCommitIndexWIP :: TVar (HashMap (LWWRefKey 'HBS2Basic) Int)
|
||||
}
|
||||
|
||||
makeLenses 'DashBoardEnv
|
||||
|
||||
repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath
|
||||
repoDataPath lw = asks _dataDir <&> (</> (show $ pretty lw)) >>= canonicalizePath
|
||||
|
||||
fixmeDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => MyRefChan -> m FilePath
|
||||
fixmeDataPath rchan = asks _dataDir <&> (</> (show $ "fixme-" <> pretty (AsBase58 rchan))) >>= canonicalizePath
|
||||
|
||||
type DashBoardPerks m = MonadUnliftIO m
|
||||
|
||||
newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a }
|
||||
deriving newtype
|
||||
( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadTrans
|
||||
, MonadReader DashBoardEnv
|
||||
)
|
||||
|
||||
newDashBoardEnv :: MonadIO m
|
||||
=> FilePath
|
||||
-> ServiceCaller PeerAPI UNIX
|
||||
-> ServiceCaller RefLogAPI UNIX
|
||||
-> ServiceCaller RefChanAPI UNIX
|
||||
-> ServiceCaller LWWRefAPI UNIX
|
||||
-> AnyStorage
|
||||
-> m DashBoardEnv
|
||||
newDashBoardEnv ddir peer rlog rchan lww sto = do
|
||||
DashBoardEnv peer rlog rchan lww sto ddir
|
||||
<$> newTVarIO mzero
|
||||
<*> newTQueueIO
|
||||
<*> newTVarIO (Just 8911)
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO False
|
||||
<*> newTVarIO mempty
|
||||
|
||||
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
|
||||
|
||||
|
||||
getIgnoreCaches :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m Bool
|
||||
getIgnoreCaches = do
|
||||
asks _dashBoardIndexIgnoreCaches
|
||||
>>= readTVarIO
|
||||
|
||||
asksBaseUrl :: (MonadIO m, MonadReader DashBoardEnv m) => (Text -> m a) -> m a
|
||||
asksBaseUrl thingInside = do
|
||||
mUrl <- readTVarIO =<< asks _dashBoardBaseUrl
|
||||
thingInside (fromMaybe (Text.pack "") mUrl)
|
||||
|
||||
withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
|
||||
withDashBoardEnv env m = runReaderT (fromDashBoardM m) env
|
||||
|
||||
data StateFSM m a =
|
||||
S0
|
||||
| SConnect
|
||||
|
||||
withState :: forall m a . (MonadIO m, MonadReader DashBoardEnv m) => DBPipeM m a -> m a
|
||||
withState f = do
|
||||
|
||||
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 {dbPipeBatchTime = 1}) 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 ()
|
||||
addJob f = do
|
||||
q <- asks _pipeline
|
||||
atomically $ writeTQueue q f
|
||||
|
||||
|
||||
|
||||
hbs2_git_dashboard :: FilePath
|
||||
hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||
|
|
@ -1,102 +0,0 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module HBS2.Git.Web.Html.Fixme where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
import Lucid.Htmx
|
||||
|
||||
import Data.Word
|
||||
import Data.List qualified as List
|
||||
|
||||
import Web.Scotty.Trans as Scotty
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 906
|
||||
import Control.Applicative -- add liftA2 into scope
|
||||
#endif
|
||||
|
||||
instance ToHtml (H FixmeKey) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ take 10 $ show $ pretty k
|
||||
toHtml (H k) = toHtml $ take 10 $ show $ pretty k
|
||||
|
||||
instance ToHtml (H FixmeTag) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ coerce @_ @Text k
|
||||
toHtml (H k) = toHtml $ coerce @_ @Text k
|
||||
|
||||
instance ToHtml (H FixmeTitle) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ coerce @_ @Text k
|
||||
toHtml (H k) = toHtml $ coerce @_ @Text k
|
||||
|
||||
repoFixme :: ( MonadReader DashBoardEnv m
|
||||
, DashBoardPerks m
|
||||
, HasLimit q
|
||||
, HasPredicate q
|
||||
, q ~ FromParams 'FixmeDomain [Param]
|
||||
)
|
||||
=> q
|
||||
-> LWWRefKey HBS2Basic
|
||||
-> HtmlT m ()
|
||||
|
||||
repoFixme q@(FromParams p') lww = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
let p = Map.fromList p'
|
||||
|
||||
now <- liftIO $ getPOSIXTime <&> round
|
||||
|
||||
debug $ blue "repoFixme" <+> "LIMITS" <+> viaShow (limit q)
|
||||
|
||||
let offset = maybe 0 fst (limit q)
|
||||
|
||||
fme <- lift $ listFixme (RepoLww lww) (Reversed q)
|
||||
|
||||
for_ fme $ \fixme -> do
|
||||
tr_ [class_ "commit-brief-title"] $ do
|
||||
td_ [class_ "mono", width_ "10"] do
|
||||
a_ [ href_ (toBaseURL (IssuePage (RepoLww lww) (fixmeKey fixme)))
|
||||
] $ toHtml (H $ fixmeKey fixme)
|
||||
td_ [width_ "10"] do
|
||||
strong_ [] $ toHtml (H $ fixmeTag fixme)
|
||||
td_ [] do
|
||||
toHtml (H $ fixmeTitle fixme)
|
||||
tr_ [class_ "commit-brief-details"] $ do
|
||||
td_ [colspan_ "3"] do
|
||||
let mco = fixmeGet "commit-time" fixme & pretty & show & readMay @Word64
|
||||
let mw = fixmeGet "workflow" fixme <&> coerce @_ @Text
|
||||
let cla = fixmeGet "class" fixme <&> coerce @_ @Text
|
||||
let mn = liftA2 (-) (fixmeEnd fixme) (fixmeStart fixme)
|
||||
|
||||
small_ do
|
||||
for_ mw $ \w -> do
|
||||
span_ [] (toHtml $ show $ brackets $ pretty w)
|
||||
" "
|
||||
|
||||
for_ mco $ \co ->
|
||||
span_ [] $ toHtml $ show $ brackets ("commited" <+> pretty (agePure co now))
|
||||
|
||||
for_ cla $ \c ->
|
||||
span_ [] $ toHtml $ show $ brackets (pretty c)
|
||||
|
||||
for_ mn $ \n -> do
|
||||
when (n > 0) do
|
||||
span_ [] $ toHtml $ show $ brackets ("text:" <+> pretty n)
|
||||
|
||||
|
||||
unless (List.null fme) do
|
||||
tr_ [ class_ "commit-brief-last"
|
||||
, hxGet_ (toBaseURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))
|
||||
, hxTrigger_ "revealed"
|
||||
, hxSwap_ "afterend"
|
||||
] do
|
||||
td_ [colspan_ "3"] mempty
|
||||
|
||||
|
||||
|
|
@ -1,156 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module HBS2.Git.Web.Html.Issue (issuePage) where
|
||||
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.Git.Web.Assets
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
import HBS2.Git.Web.Html.Root
|
||||
import HBS2.Git.Web.Html.Markdown
|
||||
import HBS2.Git.Web.Html.Fixme()
|
||||
import HBS2.Git.Web.Html.Parts.Blob
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 906
|
||||
import Control.Applicative -- add liftA2 into scope
|
||||
#endif
|
||||
|
||||
data IssueOptionalArg w t = IssueOptionalArg w t
|
||||
|
||||
issueOptionalArg :: Fixme -> FixmeAttrName -> IssueOptionalArg Fixme FixmeAttrName
|
||||
issueOptionalArg = IssueOptionalArg
|
||||
|
||||
instance ToHtml (IssueOptionalArg Fixme FixmeAttrName) where
|
||||
toHtml (IssueOptionalArg fxm n) = do
|
||||
for_ (fixmeGet n fxm) $ \t -> do
|
||||
tr_ do
|
||||
td_ [class_ "whitespace-nowrap"] $ strong_ (toHtml $ show $ pretty n)
|
||||
td_ [class_ "w-full"] (toHtml $ show $ pretty t)
|
||||
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
issuePage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoLww
|
||||
-> FixmeKey
|
||||
-> HtmlT m ()
|
||||
|
||||
issuePage repo@(RepoLww lww) f = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
ti@TopInfoBlock{} <- lift $ getTopInfoBlock (coerce repo)
|
||||
|
||||
fxm <- lift (getFixme repo f)
|
||||
>>= orThrow (itemNotFound f)
|
||||
|
||||
let txt = fixmePlain fxm & fmap coerce & Text.intercalate "\n"
|
||||
|
||||
let mbFile = fixmeGet "file" fxm
|
||||
|
||||
mbBlob <- runMaybeT do
|
||||
blobHashText <- fixmeGet "blob" fxm & toMPlus
|
||||
debug $ red "BLOB HASH TEXT" <+> pretty blobHashText
|
||||
hash <- coerce blobHashText
|
||||
& Text.unpack
|
||||
& fromStringMay @GitHash
|
||||
& toMPlus
|
||||
debug $ red "BLOB" <+> pretty hash
|
||||
lift (lift $ selectBlobInfo (BlobHash hash))
|
||||
>>= toMPlus
|
||||
|
||||
debug $ "BLOB INFO" <> line <> pretty (fmap blobHash mbBlob)
|
||||
|
||||
main_ [class_ "container-fluid"] do
|
||||
div_ [class_ "wrapper"] do
|
||||
aside_ [class_ "sidebar"] do
|
||||
|
||||
-- issuesSidebar (coerce repo) ti mempty
|
||||
repoTopInfoBlock (coerce repo) ti
|
||||
|
||||
div_ [class_ "content"] $ do
|
||||
|
||||
nav_ [class_ "mb-1"] do
|
||||
|
||||
div_ do
|
||||
small_ do
|
||||
a_ [ href_ (toBaseURL (RepoPage IssuesTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft
|
||||
span_ [] "back to issues"
|
||||
|
||||
article_ [class_ "issue-info-card"] do
|
||||
header_ do
|
||||
h5_ do
|
||||
toHtml (coerce @_ @Text $ fixmeTag fxm)
|
||||
" "
|
||||
span_ [class_ "font-normal"] do
|
||||
let fkKey = coerce @_ @Text $ fixmeKey fxm
|
||||
span_ [ class_ "issue-id secondary"
|
||||
, data_ "tooltip" "Copy"
|
||||
, onClickCopyText $ Text.take 10 fkKey
|
||||
] $ toHtml (H $ fixmeKey fxm)
|
||||
" "
|
||||
toHtml (coerce @_ @Text $ fixmeTitle fxm)
|
||||
|
||||
div_ [class_ "overflow-x-auto"] $ table_ [class_ "issue-info-table mb-0"] do
|
||||
|
||||
toHtml (issueOptionalArg fxm "workflow")
|
||||
toHtml (issueOptionalArg fxm "class")
|
||||
toHtml (issueOptionalArg fxm "assigned")
|
||||
toHtml (issueOptionalArg fxm "scope")
|
||||
toHtml (issueOptionalArg fxm "committer-name")
|
||||
toHtml (issueOptionalArg fxm "commit")
|
||||
|
||||
|
||||
maybe1 mbFile none $ \file -> do
|
||||
tr_ do
|
||||
th_ $ strong_ [] $ "file"
|
||||
|
||||
case mbBlob of
|
||||
Nothing -> do
|
||||
td_ do
|
||||
toHtml $ show $ pretty file
|
||||
Just (BlobInfo{}) -> do
|
||||
td_ do
|
||||
a_ [ href_ "#"
|
||||
, hyper_ "on click toggle .hidden on #issue-blob"
|
||||
] do
|
||||
toHtml $ show $ pretty file
|
||||
|
||||
-- toHtml (issueOptionalArg fxm "file")
|
||||
|
||||
section_ [class_ "lim-text"] do
|
||||
toHtmlRaw $ renderMarkdown txt
|
||||
|
||||
let s0 = fixmeStart fxm
|
||||
let e0 = fixmeEnd fxm
|
||||
let n = liftA2 (-) e0 s0 & fromMaybe 0
|
||||
|
||||
let hide = if n > 3 then "hidden" else ""
|
||||
|
||||
section_ [id_ "issue-blob", class_ hide ] $ void $ runMaybeT do
|
||||
blob <- toMPlus mbBlob
|
||||
s <- s0 & toMPlus <&> fromIntegral
|
||||
e <- e0 & toMPlus <&> fromIntegral
|
||||
|
||||
let before = max 0 (s - 2)
|
||||
let seize = max 1 (e - s + 100)
|
||||
|
||||
debug $ "PREPROCESS BLOB" <+> pretty before <+> pretty seize
|
||||
|
||||
lift $ doRenderBlob' (pure mempty) (trim before seize) lww blob
|
||||
|
||||
where
|
||||
trim before seize txt =
|
||||
Text.lines txt & drop before & take seize & Text.unlines
|
||||
|
||||
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
module HBS2.Git.Web.Html.Markdown where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
|
||||
import Text.Pandoc hiding (getPOSIXTime)
|
||||
|
||||
markdownToHtml :: Text -> Either PandocError String
|
||||
markdownToHtml markdown = runPure $ do
|
||||
doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown
|
||||
html <- writeHtml5String def {writerExtensions = pandocExtensions} doc
|
||||
return $ Text.unpack html
|
||||
|
||||
renderMarkdown' :: Text -> Text
|
||||
renderMarkdown' markdown = case markdownToHtml markdown of
|
||||
Left{} -> markdown
|
||||
Right html -> Text.pack html
|
||||
|
||||
renderMarkdown :: Text -> Html ()
|
||||
renderMarkdown markdown = case markdownToHtml markdown of
|
||||
Left{} -> blockquote_ (toHtml markdown)
|
||||
Right html -> toHtmlRaw $ Text.pack html
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
module HBS2.Git.Web.Html.Parts.Blob where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Types
|
||||
|
||||
import HBS2.Git.Web.Html.Markdown
|
||||
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
|
||||
import Skylighting qualified as Sky
|
||||
import Skylighting.Tokenizer
|
||||
import Skylighting.Format.HTML.Lucid as Lucid
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
{-HLINT ignore "Functor law"-}
|
||||
|
||||
|
||||
doRenderBlob :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
|
||||
=> (Text -> HtmlT m ())
|
||||
-> LWWRefKey HBS2Basic
|
||||
-> BlobInfo
|
||||
-> HtmlT m ()
|
||||
|
||||
doRenderBlob fallback = doRenderBlob' fallback id
|
||||
|
||||
doRenderBlob' :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
|
||||
=> (Text -> HtmlT m ())
|
||||
-> (Text -> Text)
|
||||
-> LWWRefKey HBS2Basic
|
||||
-> BlobInfo
|
||||
-> HtmlT m ()
|
||||
|
||||
doRenderBlob' fallback preprocess lww BlobInfo{..} = do
|
||||
fromMaybe mempty <$> runMaybeT do
|
||||
|
||||
guard (blobSize < 10485760)
|
||||
|
||||
let fn = blobName & coerce
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
syn <- ( Sky.syntaxesByFilename syntaxMap fn
|
||||
& headMay
|
||||
) <|> Sky.syntaxByName syntaxMap "default"
|
||||
& toMPlus
|
||||
|
||||
lift do
|
||||
|
||||
txt <- lift (readBlob lww blobHash)
|
||||
<&> LBS.toStrict
|
||||
<&> Text.decodeUtf8
|
||||
|
||||
case blobSyn of
|
||||
BlobSyn (Just "markdown") -> do
|
||||
|
||||
div_ [class_ "lim-text"] do
|
||||
toHtmlRaw (renderMarkdown' txt)
|
||||
|
||||
_ -> do
|
||||
|
||||
txt <- lift (readBlob lww blobHash)
|
||||
<&> LBS.toStrict
|
||||
<&> Text.decodeUtf8
|
||||
<&> preprocess
|
||||
|
||||
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
||||
|
||||
case tokenize config syn txt of
|
||||
Left _ -> fallback txt
|
||||
Right tokens -> do
|
||||
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
||||
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
||||
toHtmlRaw code
|
||||
|
||||
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
module HBS2.Git.Web.Html.Parts.Issues.Sidebar where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
import HBS2.Git.Web.Html.Parts.TopInfoBlock
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
import Lucid.Htmx
|
||||
|
||||
|
||||
|
||||
issuesSidebar :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> TopInfoBlock
|
||||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
issuesSidebar lww topInfoBlock p' = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
let p = Map.fromList p'
|
||||
|
||||
tot <- lift $ countFixme (RepoLww lww)
|
||||
fmw <- lift $ countFixmeByAttribute (RepoLww lww) "workflow"
|
||||
fmt <- lift $ countFixmeByAttribute (RepoLww lww) "fixme-tag"
|
||||
ass <- lift $ countFixmeByAttribute (RepoLww lww) "assigned"
|
||||
cla <- lift $ countFixmeByAttribute (RepoLww lww) "class"
|
||||
|
||||
repoTopInfoBlock lww topInfoBlock
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Tag"
|
||||
|
||||
-- TODO: make-this-block-properly
|
||||
|
||||
ul_ do
|
||||
for_ fmt $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "fixme-tag" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
toHtml $ show $ pretty n
|
||||
|
||||
span_ [] $ toHtml $ show $ pretty s
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Status"
|
||||
|
||||
ul_ do
|
||||
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.delete "workflow" p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
toHtml $ show $ pretty (fromMaybe 0 tot)
|
||||
|
||||
span_ [] $ toHtml $ show $ pretty "[all]"
|
||||
|
||||
for_ fmw $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "workflow" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
toHtml $ show $ pretty n
|
||||
|
||||
span_ [] $ toHtml $ show $ pretty s
|
||||
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Assigned"
|
||||
|
||||
for_ ass $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "assigned" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
toHtml $ show $ pretty n
|
||||
|
||||
span_ [] $ toHtml $ show $ pretty s
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Class"
|
||||
|
||||
for_ cla $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "class" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
toHtml $ show $ pretty n
|
||||
|
||||
span_ [] $ toHtml $ show $ pretty s
|
||||
|
||||
pure ()
|
||||
|
|
@ -1,152 +0,0 @@
|
|||
module HBS2.Git.Web.Html.Parts.TopInfoBlock where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Manifest
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.Git.Data.Tx.Git
|
||||
import HBS2.Git.Web.Assets
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
|
||||
data TopInfoBlock =
|
||||
TopInfoBlock
|
||||
{ author :: Maybe Text
|
||||
, public :: Maybe Text
|
||||
, forksNum :: RepoForks
|
||||
, commitsNum :: RepoCommitsNum
|
||||
, manifest :: Text
|
||||
, fixme :: Maybe MyRefChan
|
||||
, fixmeCnt :: Int
|
||||
, pinned :: [(Text, Syntax C)]
|
||||
, repoHeadRef :: RepoHeadRef
|
||||
, repoHead :: Maybe RepoHead
|
||||
, repoName :: RepoName
|
||||
}
|
||||
|
||||
repoTopInfoBlock :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> TopInfoBlock
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTopInfoBlock lww TopInfoBlock{..} = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
let url = toBaseURL (RepoPage (CommitsTab Nothing) lww)
|
||||
let txt = toHtml (ShortRef lww)
|
||||
a_ [href_ url, class_ "secondary"] txt
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "About"
|
||||
ul_ [class_ "mb-0"] do
|
||||
for_ author $ \a -> do
|
||||
li_ $ small_ do
|
||||
"Author: "
|
||||
toHtml a
|
||||
|
||||
for_ public $ \p -> do
|
||||
li_ $ small_ do
|
||||
"Public: "
|
||||
toHtml p
|
||||
|
||||
when (Text.length manifest > 100) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toBaseURL (RepoPage ManifestTab lww))] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLicense
|
||||
"Manifest"
|
||||
|
||||
for_ fixme $ \_ -> do
|
||||
li_ $ small_ do
|
||||
a_ [ class_ "secondary"
|
||||
, href_ (toBaseURL (RepoPage IssuesTab lww)) ] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconFixme
|
||||
toHtml $ show fixmeCnt
|
||||
" Issues"
|
||||
|
||||
when (forksNum > 0) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toBaseURL (RepoPage ForksTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
toHtml $ show forksNum
|
||||
" forks"
|
||||
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
||||
toHtml $ show commitsNum
|
||||
" commits"
|
||||
|
||||
for_ pinned $ \(_,ref) -> do
|
||||
case ref of
|
||||
PinnedRefBlob s n hash -> small_ do
|
||||
li_ $ a_ [class_ "secondary"
|
||||
, href_ (toBaseURL (RepoPage (PinnedTab (Just (s,n,hash))) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned
|
||||
toHtml (Text.take 12 n)
|
||||
" "
|
||||
toHtml $ ShortRef hash
|
||||
|
||||
parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text)
|
||||
parsedManifest RepoListItem{..} = do
|
||||
|
||||
sto <- asks _sto
|
||||
mhead <- readRepoHeadFromTx sto (coerce rlRepoTx)
|
||||
|
||||
case mhead of
|
||||
Just x -> parseManifest (snd x)
|
||||
Nothing -> pure (mempty, coerce rlRepoBrief)
|
||||
|
||||
|
||||
getTopInfoBlock :: ( MonadUnliftIO m, MonadIO m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> LWWRefKey HBS2Basic -> m TopInfoBlock
|
||||
getTopInfoBlock lww = do
|
||||
|
||||
debug $ red "getTopInfoBlock"
|
||||
|
||||
it@RepoListItem{..} <- (selectRepoList ( mempty
|
||||
& set repoListByLww (Just lww)
|
||||
& set repoListLimit (Just 1))
|
||||
<&> listToMaybe
|
||||
) >>= orThrow (itemNotFound lww)
|
||||
|
||||
sto <- asks _sto
|
||||
mhead <- readRepoHeadFromTx sto (coerce rlRepoTx)
|
||||
|
||||
let repoHead = snd <$> mhead
|
||||
|
||||
(meta, manifest) <- parsedManifest it
|
||||
|
||||
let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
|
||||
let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
|
||||
let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
|
||||
|
||||
allowed <- checkFixmeAllowed (RepoLww lww)
|
||||
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
|
||||
|
||||
fixmeCnt <- if allowed then
|
||||
Fixme.countFixme (RepoLww lww) <&> fromMaybe 0
|
||||
else
|
||||
pure 0
|
||||
|
||||
let forksNum = rlRepoForks
|
||||
let commitsNum = rlRepoCommits
|
||||
let repoHeadRef = rlRepoHead
|
||||
let repoName = rlRepoName
|
||||
|
||||
pure $ TopInfoBlock{..}
|
||||
|
|
@ -1,593 +0,0 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
module HBS2.Git.Web.Html.Repo where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.State.Commits
|
||||
import HBS2.Git.DashBoard.Manifest
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.Git.Data.Tx.Git
|
||||
import HBS2.Git.Data.RepoHead
|
||||
import HBS2.Git.Web.Assets
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
import HBS2.Git.Web.Html.Root
|
||||
import HBS2.Git.Web.Html.Markdown
|
||||
import HBS2.Git.Web.Html.Parts.Issues.Sidebar
|
||||
import HBS2.Git.Web.Html.Parts.Blob
|
||||
|
||||
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
import Lucid.Htmx
|
||||
|
||||
import Skylighting qualified as Sky
|
||||
import Skylighting.Tokenizer
|
||||
import Skylighting.Format.HTML.Lucid as Lucid
|
||||
|
||||
import Data.Either
|
||||
import Data.List qualified as List
|
||||
import Data.List (sortOn)
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
isActiveTab :: RepoPageTabs -> RepoPageTabs -> Bool
|
||||
isActiveTab a b = case (a,b) of
|
||||
(CommitsTab{},CommitsTab{}) -> True
|
||||
(ManifestTab{},ManifestTab{}) -> True
|
||||
(TreeTab{},TreeTab{}) -> True
|
||||
_ -> False
|
||||
|
||||
|
||||
|
||||
repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoPageTabs
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
|
||||
repoPage IssuesTab lww p' = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
ti@TopInfoBlock{..} <- lift $ getTopInfoBlock lww
|
||||
|
||||
main_ [class_ "container-fluid"] do
|
||||
div_ [class_ "wrapper"] do
|
||||
aside_ [class_ "sidebar"] do
|
||||
|
||||
issuesSidebar lww ti p'
|
||||
|
||||
div_ [class_ "content"] $ do
|
||||
|
||||
section_ do
|
||||
h5_ $ toHtml (show $ "Issues ::" <+> pretty repoName)
|
||||
|
||||
form_ [role_ "search"] do
|
||||
input_ [name_ "search", type_ "search"]
|
||||
input_ [type_ "submit", value_ "Search"]
|
||||
|
||||
table_ [] do
|
||||
tbody_ [id_ "fixme-tab-data"] mempty
|
||||
|
||||
div_ [ id_ "repo-tab-data"
|
||||
, hxTrigger_ "load"
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
, hxGet_ (toBaseURL (RepoFixmeHtmx mempty (RepoLww lww)))
|
||||
] mempty
|
||||
|
||||
div_ [id_ "repo-tab-data-embedded"] mempty
|
||||
|
||||
|
||||
repoPage tab lww params = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
sto <- asks _sto
|
||||
|
||||
topInfoBlock@TopInfoBlock{..} <- lift $ getTopInfoBlock lww
|
||||
|
||||
main_ [class_ "container-fluid"] do
|
||||
div_ [class_ "wrapper"] do
|
||||
aside_ [class_ "sidebar"] do
|
||||
|
||||
|
||||
repoTopInfoBlock lww topInfoBlock
|
||||
|
||||
for_ repoHead $ \rh -> do
|
||||
|
||||
let theHead = headMay [ v | (GitRef "HEAD", v) <- view repoHeadRefs rh ]
|
||||
|
||||
let checkHead v what | v == theHead = strong_ what
|
||||
| otherwise = what
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Heads"
|
||||
ul_ [class_ "mb-0"] $ do
|
||||
for_ (view repoHeadHeads rh) $ \(branch,v) -> do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toBaseURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
||||
checkHead (Just v) $ toHtml branch
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Tags"
|
||||
ul_ [class_ "mb-0"] $ do
|
||||
for_ (view repoHeadTags rh) $ \(tag,v) -> do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toBaseURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
||||
checkHead (Just v) $ toHtml tag
|
||||
|
||||
div_ [class_ "content"] $ do
|
||||
|
||||
article_ [class_ "py-0"] $ nav_ [ariaLabel_ "breadcrumb", class_ "repo-menu"] $ ul_ do
|
||||
|
||||
let menuTabClasses isActive = if isActive then "tab contrast" else "tab"
|
||||
menuTab t misc name = li_ do
|
||||
a_ ([class_ $ menuTabClasses $ isActiveTab tab t] <> misc <> [tabClick]) do
|
||||
name
|
||||
|
||||
menuTab (CommitsTab Nothing)
|
||||
[ href_ "#"
|
||||
, hxGet_ (toBaseURL (RepoCommits lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "commits"
|
||||
|
||||
menuTab (TreeTab Nothing)
|
||||
[ href_ "#"
|
||||
, hxGet_ (toBaseURL (RepoRefs lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "tree"
|
||||
|
||||
section_ do
|
||||
strong_ $ toHtml repoName
|
||||
|
||||
div_ [id_ "repo-tab-data"] do
|
||||
|
||||
case tab of
|
||||
|
||||
TreeTab{} -> do
|
||||
|
||||
let tree = [ fromStringMay @GitHash (Text.unpack v)
|
||||
| ("tree", v) <- params
|
||||
] & catMaybes & headMay
|
||||
|
||||
maybe (repoRefs lww) (\t -> repoTree lww t t) tree
|
||||
|
||||
ManifestTab -> do
|
||||
for_ repoHead $ thisRepoManifest
|
||||
|
||||
CommitsTab{} -> do
|
||||
let predicate = Right (fromQueryParams params)
|
||||
repoCommits lww predicate
|
||||
|
||||
ForksTab -> do
|
||||
repoForks lww
|
||||
|
||||
PinnedTab w -> do
|
||||
|
||||
pinned' <- S.toList_ $ for_ pinned $ \(_,ref) -> case ref of
|
||||
PinnedRefBlob s n hash -> do
|
||||
S.yield (hash, (s,n))
|
||||
|
||||
let pinned = Map.fromList pinned'
|
||||
|
||||
void $ runMaybeT do
|
||||
ref <- [ fromStringMay @GitHash (Text.unpack v)
|
||||
| ("ref", v) <- params
|
||||
] & catMaybes
|
||||
& headMay
|
||||
& toMPlus
|
||||
|
||||
(s,n) <- Map.lookup ref pinned & toMPlus
|
||||
|
||||
lift $ repoSomeBlob lww s ref
|
||||
|
||||
mempty
|
||||
|
||||
div_ [id_ "repo-tab-data-embedded"] mempty
|
||||
|
||||
|
||||
thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoHead -> HtmlT m ()
|
||||
thisRepoManifest rh = do
|
||||
(_, man) <- lift $ parseManifest rh
|
||||
div_ [class_ "lim-text"] $ toHtmlRaw (renderMarkdown' man)
|
||||
|
||||
repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> HtmlT m ()
|
||||
repoRefs lww = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
refs <- lift $ gitShowRefs lww
|
||||
table_ [] do
|
||||
for_ refs $ \(r,h) -> do
|
||||
let r_ = Text.pack $ show $ pretty r
|
||||
let co = show $ pretty h
|
||||
let uri = toBaseURL (RepoTree lww h h)
|
||||
|
||||
let showRef = Text.isPrefixOf "refs" r_
|
||||
|
||||
when showRef do
|
||||
tr_ do
|
||||
td_ do
|
||||
|
||||
if | Text.isPrefixOf "refs/heads" r_ -> do
|
||||
svgIcon IconGitBranch
|
||||
| Text.isPrefixOf "refs/tags" r_ -> do
|
||||
svgIcon IconTag
|
||||
| otherwise -> mempty
|
||||
|
||||
td_ (toHtml r_)
|
||||
td_ [class_ "mono"] $ do
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ uri
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] (toHtml $ show $ pretty h)
|
||||
|
||||
|
||||
treeLocator :: (WithBaseUrl, DashBoardPerks m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> TreeLocator
|
||||
-> HtmlT m ()
|
||||
-> HtmlT m ()
|
||||
|
||||
treeLocator lww co locator next = do
|
||||
|
||||
let repo = show $ pretty $ lww
|
||||
|
||||
let co_ = show $ pretty co
|
||||
|
||||
let prefixSlash x = if fromIntegral x > 1 then span_ "/" else ""
|
||||
let showRoot =
|
||||
[ hxGet_ (toBaseURL (RepoTree lww co co))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, href_ "#"
|
||||
]
|
||||
|
||||
span_ [] $ a_ [ hxGet_ (toBaseURL (RepoRefs lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, href_ "#"
|
||||
] $ toHtml (take 10 repo <> "..")
|
||||
span_ [] "/"
|
||||
span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..")
|
||||
unless (List.null locator) do
|
||||
span_ [] "/"
|
||||
for_ locator $ \(_,this,level,name) -> do
|
||||
prefixSlash level
|
||||
let uri = toBaseURL (RepoTree lww co (coerce @_ @GitHash this))
|
||||
span_ [] do
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ uri
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] (toHtml (show $ pretty name))
|
||||
next
|
||||
|
||||
|
||||
repoTreeEmbedded :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash -- ^ this
|
||||
-> GitHash -- ^ this
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTreeEmbedded = repoTree_ True
|
||||
|
||||
|
||||
repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash -- ^ this
|
||||
-> GitHash -- ^ this
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTree = repoTree_ False
|
||||
|
||||
repoTree_ :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> Bool
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> GitHash -- ^ this
|
||||
-> GitHash -- ^ this
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTree_ embed lww co root = asksBaseUrl $ withBaseUrl $ do
|
||||
|
||||
tree <- lift $ gitShowTree lww root
|
||||
back' <- lift $ selectParentTree (TreeCommit co) (TreeTree root)
|
||||
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree
|
||||
where
|
||||
tpOrder Tree = (0 :: Int)
|
||||
tpOrder Blob = 1
|
||||
tpOrder _ = 2
|
||||
|
||||
locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root)
|
||||
|
||||
let target = if embed then "#repo-tab-data-embedded" else "#repo-tab-data"
|
||||
|
||||
table_ [] do
|
||||
|
||||
unless embed do
|
||||
|
||||
tr_ do
|
||||
td_ [class_ "tree-locator", colspan_ "3"] do
|
||||
treeLocator lww co locator none
|
||||
|
||||
tr_ mempty do
|
||||
|
||||
for_ back' $ \r -> do
|
||||
let rootLink = toBaseURL (RepoTree lww co (coerce @_ @GitHash r))
|
||||
td_ $ svgIcon IconArrowUturnLeft
|
||||
td_ ".."
|
||||
td_ do a_ [ href_ "#"
|
||||
, hxGet_ rootLink
|
||||
, hxTarget_ target
|
||||
] (toHtml $ show $ pretty r)
|
||||
|
||||
for_ sorted $ \(tp,h,name) -> do
|
||||
let itemClass = pretty tp & show & Text.pack
|
||||
let hash_ = show $ pretty h
|
||||
let uri = toBaseURL $ RepoTree lww co h
|
||||
tr_ mempty do
|
||||
td_ $ case tp of
|
||||
Commit -> mempty
|
||||
Tree -> svgIcon IconFolderFilled
|
||||
Blob -> do
|
||||
let syn = Sky.syntaxesByFilename syntaxMap (Text.unpack name)
|
||||
& headMay
|
||||
<&> Text.toLower . Sky.sName
|
||||
|
||||
let icon = case syn of
|
||||
Just "haskell" -> IconHaskell
|
||||
Just "markdown" -> IconMarkdown
|
||||
Just "nix" -> IconNix
|
||||
Just "bash" -> IconBash
|
||||
Just "python" -> IconPython
|
||||
Just "javascript" -> IconJavaScript
|
||||
Just "sql" -> IconSql
|
||||
Just s | s `elem` ["cabal","makefile","toml","ini","yaml"]
|
||||
-> IconSettingsFilled
|
||||
_ -> IconFileFilled
|
||||
|
||||
svgIcon icon
|
||||
|
||||
-- debug $ red "PUSH URL" <+> pretty (path ["back", wtf])
|
||||
|
||||
td_ [class_ itemClass] (toHtml $ show $ pretty name)
|
||||
td_ [class_ "mono"] do
|
||||
case tp of
|
||||
Blob -> do
|
||||
let blobUri = toBaseURL $ RepoBlob lww co root h
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ blobUri
|
||||
, hxTarget_ target
|
||||
] (toHtml hash_)
|
||||
|
||||
Tree -> do
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ uri
|
||||
, hxTarget_ target
|
||||
] (toHtml hash_)
|
||||
|
||||
_ -> mempty
|
||||
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
data RepoCommitStyle = RepoCommitSummary | RepoCommitPatch
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoCommitStyle
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> HtmlT m ()
|
||||
|
||||
repoCommit style lww hash = asksBaseUrl $ withBaseUrl do
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
txt <- lift $ getCommitRawBrief lww hash
|
||||
|
||||
let header = Text.lines txt & takeWhile (not . Text.null)
|
||||
& fmap Text.words
|
||||
|
||||
let au = [ Text.takeWhile (/= '<') (Text.unwords a)
|
||||
| ("Author:" : a) <- header
|
||||
] & headMay
|
||||
|
||||
table_ [class_ "item-attr"] do
|
||||
|
||||
tr_ do
|
||||
th_ [width_ "16rem"] $ strong_ "back"
|
||||
td_ $ a_ [ href_ (toBaseURL (RepoPage (CommitsTab (Just hash)) lww))
|
||||
] $ toHtml $ show $ pretty hash
|
||||
|
||||
for_ au $ \author -> do
|
||||
tr_ do
|
||||
th_ $ strong_ "author"
|
||||
td_ $ toHtml author
|
||||
|
||||
tr_ $ do
|
||||
th_ $ strong_ "view"
|
||||
td_ do
|
||||
ul_ [class_ "misc-menu"]do
|
||||
li_ $ a_ [ href_ "#"
|
||||
, hxGet_ (toBaseURL (RepoCommitSummaryQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "summary"
|
||||
|
||||
li_ $ a_ [ href_ "#"
|
||||
, hxGet_ (toBaseURL (RepoCommitPatchQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "patch"
|
||||
|
||||
li_ $ a_ [ href_ (toBaseURL (RepoPage (TreeTab (Just hash)) lww))
|
||||
] "tree"
|
||||
|
||||
case style of
|
||||
RepoCommitSummary -> do
|
||||
|
||||
let msyn = Sky.syntaxByName syntaxMap "default"
|
||||
|
||||
for_ msyn $ \syn -> do
|
||||
|
||||
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
||||
|
||||
case tokenize config syn txt of
|
||||
Left _ -> mempty
|
||||
Right tokens -> do
|
||||
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
||||
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
||||
toHtmlRaw code
|
||||
|
||||
RepoCommitPatch -> do
|
||||
|
||||
let msyn = Sky.syntaxByName syntaxMap "diff"
|
||||
|
||||
for_ msyn $ \syn -> do
|
||||
|
||||
txt <- lift $ getCommitRawPatch lww hash
|
||||
|
||||
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
||||
|
||||
case tokenize config syn txt of
|
||||
Left _ -> mempty
|
||||
Right tokens -> do
|
||||
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
||||
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
||||
toHtmlRaw code
|
||||
|
||||
|
||||
repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> HtmlT m ()
|
||||
|
||||
repoForks lww = asksBaseUrl $ withBaseUrl do
|
||||
forks <- lift $ selectRepoForks lww
|
||||
now <- getEpoch
|
||||
|
||||
unless (List.null forks) do
|
||||
table_ $ do
|
||||
tr_ $ th_ [colspan_ "3"] mempty
|
||||
for_ forks $ \it@RepoListItem{..} -> do
|
||||
let lwwTo = coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww
|
||||
tr_ [class_ "commit-brief-title"] do
|
||||
td_ $ svgIcon IconGitFork
|
||||
td_ [class_ "mono"] $
|
||||
a_ [ href_ (toBaseURL (RepoPage (CommitsTab Nothing) lwwTo))
|
||||
] do
|
||||
toHtmlRaw $ view rlRepoLwwAsText it
|
||||
td_ $ small_ $ toHtml (agePure rlRepoSeq now)
|
||||
|
||||
|
||||
repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> Either SelectCommitsPred SelectCommitsPred
|
||||
-> HtmlT m ()
|
||||
|
||||
repoCommits lww predicate' = asksBaseUrl $ withBaseUrl do
|
||||
now <- getEpoch
|
||||
|
||||
debug $ red "repoCommits"
|
||||
|
||||
let predicate = either id id predicate'
|
||||
|
||||
co <- lift $ selectCommits lww predicate
|
||||
|
||||
let off = view commitPredOffset predicate
|
||||
let lim = view commitPredLimit predicate
|
||||
let noff = off + lim
|
||||
|
||||
let query = RepoCommitsQ lww noff lim --) path ["repo", repo, "commits", show noff, show lim]
|
||||
|
||||
let normalizeText s = l $ (Text.take 60 . Text.unwords . Text.words) s
|
||||
where l x | Text.length x < 60 = x
|
||||
| otherwise = x <> "..."
|
||||
|
||||
let rows = do
|
||||
tr_ $ th_ [colspan_ "5"] mempty
|
||||
for_ co $ \case
|
||||
CommitListItemBrief{..} -> do
|
||||
tr_ [class_ "commit-brief-title"] do
|
||||
td_ [class_ "commit-icon"] $ svgIcon IconGitCommit
|
||||
|
||||
td_ [class_ "commit-hash mono"] do
|
||||
let hash = coerce @_ @GitHash commitListHash
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ (toBaseURL (RepoCommitDefault lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, hxPushUrl_ (toBaseURL query)
|
||||
] $ toHtml (ShortRef hash)
|
||||
|
||||
td_ [class_ "commit-brief-title"] do
|
||||
toHtml $ normalizeText $ coerce @_ @Text commitListTitle
|
||||
|
||||
tr_ [class_ "commit-brief-details"] do
|
||||
td_ [colspan_ "3"] do
|
||||
small_ do
|
||||
toHtml (agePure (coerce @_ @Integer commitListTime) now)
|
||||
toHtml " by "
|
||||
toHtml $ coerce @_ @Text commitListAuthor
|
||||
|
||||
unless (List.null co) do
|
||||
tr_ [ class_ "commit-brief-last"
|
||||
, hxGet_ (toBaseURL query)
|
||||
, hxTrigger_ "revealed"
|
||||
, hxSwap_ "afterend"
|
||||
] do
|
||||
td_ [colspan_ "4"] do
|
||||
mempty
|
||||
|
||||
if isRight predicate' then do
|
||||
table_ rows
|
||||
else do
|
||||
rows
|
||||
|
||||
|
||||
repoSomeBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> Text
|
||||
-> GitHash
|
||||
-> HtmlT m ()
|
||||
|
||||
repoSomeBlob lww syn hash = do
|
||||
|
||||
bi <- lift (selectBlobInfo (BlobHash hash))
|
||||
>>= orThrow (itemNotFound hash)
|
||||
|
||||
doRenderBlob (pure mempty) lww bi
|
||||
|
||||
repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> TreeCommit
|
||||
-> TreeTree
|
||||
-> BlobInfo
|
||||
-> HtmlT m ()
|
||||
|
||||
repoBlob lww co tree bi@BlobInfo{..} = asksBaseUrl $ withBaseUrl do
|
||||
locator <- lift $ selectTreeLocator co tree
|
||||
|
||||
table_ [] do
|
||||
tr_ do
|
||||
td_ [class_ "tree-locator", colspan_ "3"] do
|
||||
treeLocator lww (coerce co) locator do
|
||||
span_ "/"
|
||||
span_ $ toHtml (show $ pretty blobName)
|
||||
|
||||
|
||||
table_ [class_ "item-attr"] do
|
||||
tr_ do
|
||||
th_ $ strong_ "hash"
|
||||
td_ [colspan_ "7"] do
|
||||
span_ [class_ "mono"] $ toHtml $ show $ pretty blobHash
|
||||
|
||||
tr_ do
|
||||
th_ $ strong_ "syntax"
|
||||
td_ $ toHtml $ show $ pretty blobSyn
|
||||
|
||||
th_ $ strong_ "size"
|
||||
td_ $ toHtml $ show $ pretty blobSize
|
||||
|
||||
td_ [colspan_ "3"] mempty
|
||||
|
||||
doRenderBlob (pure mempty) lww bi
|
||||
|
|
@ -1,160 +0,0 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
{-# Language MultiWayIf #-}
|
||||
module HBS2.Git.Web.Html.Root
|
||||
( module HBS2.Git.Web.Html.Root
|
||||
, module HBS2.Git.Web.Html.Types
|
||||
, module HBS2.Git.Web.Html.Parts.TopInfoBlock
|
||||
) where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.Web.Assets
|
||||
|
||||
import HBS2.Git.Web.Html.Types
|
||||
import HBS2.Git.Web.Html.Markdown
|
||||
import HBS2.Git.Web.Html.Parts.TopInfoBlock
|
||||
|
||||
import Lucid.Base
|
||||
import Lucid.Html5 hiding (for_)
|
||||
|
||||
import Data.Word
|
||||
|
||||
|
||||
myCss :: (WithBaseUrl, Monad m) => HtmlT m ()
|
||||
myCss = do
|
||||
link_ [rel_ "stylesheet", href_ (toBaseURL "css/custom.css")]
|
||||
|
||||
hyper_ :: Text -> Attribute
|
||||
hyper_ = makeAttribute "_"
|
||||
|
||||
ariaLabel_ :: Text -> Attribute
|
||||
ariaLabel_ = makeAttribute "aria-label"
|
||||
|
||||
onClickCopy :: Text -> Attribute
|
||||
onClickCopy s =
|
||||
hyper_ [qc|on click writeText('{s}') into the navigator's clipboard
|
||||
set my innerHTML to '{svgIconText IconCopyDone}'
|
||||
set @data-tooltip to 'Copied!'
|
||||
wait 2s
|
||||
set my innerHTML to '{svgIconText IconCopy}'
|
||||
set @data-tooltip to 'Copy'
|
||||
|]
|
||||
|
||||
|
||||
onClickCopyText :: Text -> Attribute
|
||||
onClickCopyText s =
|
||||
hyper_ [qc|on click writeText('{s}') into the navigator's clipboard
|
||||
set @data-tooltip to 'Copied!'
|
||||
wait 2s
|
||||
set @data-tooltip to 'Copy'
|
||||
|]
|
||||
|
||||
|
||||
instance ToHtml RepoBrief where
|
||||
toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
||||
toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
||||
|
||||
data WithTime a = WithTime Integer a
|
||||
|
||||
|
||||
instance ToHtml GitRef where
|
||||
toHtml (GitRef s)= toHtml s
|
||||
toHtmlRaw (GitRef s)= toHtmlRaw s
|
||||
|
||||
rootPage :: (WithBaseUrl, Monad m) => HtmlT m () -> HtmlT m ()
|
||||
rootPage content = do
|
||||
doctypehtml_ do
|
||||
head_ do
|
||||
meta_ [charset_ "UTF-8"]
|
||||
meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
|
||||
-- FIXME: static-local-loading
|
||||
link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"]
|
||||
script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] ""
|
||||
script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] ""
|
||||
myCss
|
||||
|
||||
body_ do
|
||||
|
||||
header_ [class_ "container-fluid"] do
|
||||
nav_ do
|
||||
ul_ $ li_ $ a_ [href_ (toBaseURL RepoListPage)] $ strong_ "hbs2-git dashboard"
|
||||
|
||||
content
|
||||
|
||||
|
||||
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
||||
dashboardRootPage = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
items <- lift $ selectRepoList mempty
|
||||
|
||||
now <- liftIO getPOSIXTime <&> fromIntegral . round
|
||||
|
||||
main_ [class_ "container-fluid"] $ do
|
||||
div_ [class_ "wrapper"] $ do
|
||||
aside_ [class_ "sidebar"] $ do
|
||||
div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
||||
div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
||||
|
||||
div_ [class_ "content"] do
|
||||
|
||||
section_ do
|
||||
h2_ "Git repositories"
|
||||
form_ [role_ "search"] do
|
||||
input_ [name_ "search", type_ "search"]
|
||||
input_ [type_ "submit", value_ "Search"]
|
||||
|
||||
section_ do
|
||||
|
||||
for_ items $ \it@RepoListItem{..} -> do
|
||||
|
||||
let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0
|
||||
|
||||
let url = toBaseURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww))
|
||||
-- path ["repo", Text.unpack $ view rlRepoLwwAsText it]
|
||||
let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq
|
||||
|
||||
let updated = agePure t now
|
||||
|
||||
article_ [class_ "repo-list-item"] do
|
||||
div_ do
|
||||
|
||||
h5_ do
|
||||
toHtml rlRepoName
|
||||
|
||||
div_ [class_ "repo-list-item-link-wrapper"] $ do
|
||||
a_ [href_ url] (toHtml $ view rlRepoLwwAsText it)
|
||||
button_ [class_ "copy-button", onClickCopy (view rlRepoLwwAsText it), data_ "tooltip" "Copy"] do
|
||||
svgIcon IconCopy
|
||||
|
||||
toHtml rlRepoBrief
|
||||
|
||||
div_ do
|
||||
|
||||
div_ [class_ "whitespace-nowrap"] do
|
||||
small_ $ "Updated " <> toHtml updated
|
||||
|
||||
when locked do
|
||||
div_ do
|
||||
small_ do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLockClosed
|
||||
"Encrypted"
|
||||
|
||||
div_ do
|
||||
small_ do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
||||
strong_ $ toHtml $ show rlRepoCommits
|
||||
" commits"
|
||||
|
||||
div_ do
|
||||
small_ do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
strong_ $ toHtml $ show rlRepoForks
|
||||
" forks"
|
||||
|
||||
|
||||
tabClick :: Attribute
|
||||
tabClick =
|
||||
hyper_ "on click take .contrast from .tab for event's target"
|
||||
|
|
@ -1,322 +0,0 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
{-# Language ImplicitParams #-}
|
||||
module HBS2.Git.Web.Html.Types where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
import Data.Kind
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Data.Word
|
||||
import Lucid.Base
|
||||
import Network.URI.Encode
|
||||
import System.FilePath
|
||||
import Web.Scotty.Trans as Scotty
|
||||
|
||||
import Network.HTTP.Types.Status
|
||||
|
||||
newtype H a = H a
|
||||
|
||||
raiseStatus :: forall m . MonadIO m => Status -> Text -> m ()
|
||||
raiseStatus s t = throwIO (StatusError s t)
|
||||
|
||||
itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s)
|
||||
|
||||
rootPath :: [String] -> [String]
|
||||
rootPath = ("/":)
|
||||
|
||||
data Domain = FixmeDomain
|
||||
|
||||
newtype FromParams (e :: Domain) a = FromParams a
|
||||
|
||||
class Path a where
|
||||
path :: [a] -> Text
|
||||
|
||||
instance Path String where
|
||||
path = Text.pack . joinPath . rootPath
|
||||
|
||||
|
||||
class ToRoutePattern a where
|
||||
routePattern :: a -> RoutePattern
|
||||
|
||||
type WithBaseUrl = ?dashBoardBaseUrl :: Text
|
||||
|
||||
getBaseUrl :: WithBaseUrl => Text
|
||||
getBaseUrl = ?dashBoardBaseUrl
|
||||
|
||||
withBaseUrl :: (WithBaseUrl => r) -> Text -> r
|
||||
withBaseUrl thingInside baseUrl =
|
||||
let ?dashBoardBaseUrl = baseUrl in thingInside
|
||||
|
||||
toBaseURL :: (WithBaseUrl, ToURL a) => a -> Text
|
||||
toBaseURL x = getBaseUrl <> toURL x
|
||||
|
||||
class ToURL a where
|
||||
toURL :: a -> Text
|
||||
|
||||
data family Tabs a :: Type
|
||||
|
||||
data RepoListPage = RepoListPage
|
||||
|
||||
data RepoPageTabs = CommitsTab (Maybe GitHash)
|
||||
| ManifestTab
|
||||
| TreeTab (Maybe GitHash)
|
||||
| IssuesTab
|
||||
| ForksTab
|
||||
| PinnedTab (Maybe (Text, Text, GitHash))
|
||||
deriving stock (Eq,Ord,Show)
|
||||
|
||||
data RepoPage s a = RepoPage s a
|
||||
|
||||
data RepoRefs repo = RepoRefs repo
|
||||
|
||||
data RepoTree repo commit tree = RepoTree repo commit tree
|
||||
|
||||
data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree
|
||||
|
||||
data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob
|
||||
|
||||
data RepoSomeBlob repo blob tp = RepoSomeBlob repo blob tp
|
||||
|
||||
data RepoForksHtmx repo = RepoForksHtmx repo
|
||||
|
||||
newtype RepoManifest repo = RepoManifest repo
|
||||
|
||||
newtype RepoCommits repo = RepoCommits repo
|
||||
|
||||
data Paged q = Paged QueryOffset q
|
||||
|
||||
data RepoFixmeHtmx repo = RepoFixmeHtmx (Map Text Text) repo
|
||||
|
||||
data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
|
||||
|
||||
data RepoCommitDefault repo commit = RepoCommitDefault repo commit
|
||||
|
||||
data RepoCommitSummaryQ repo commit = RepoCommitSummaryQ repo commit
|
||||
|
||||
data RepoCommitPatchQ repo commit = RepoCommitPatchQ repo commit
|
||||
|
||||
data IssuePage repo issue = IssuePage repo issue
|
||||
|
||||
|
||||
newtype ShortRef a = ShortRef a
|
||||
|
||||
shortRef :: Int -> Int -> String -> String
|
||||
shortRef n k a = if k > 0 then [qc|{b}..{r}|] else [qc|{b}|]
|
||||
where
|
||||
b = take n a
|
||||
r = reverse $ take k (reverse a)
|
||||
|
||||
instance ToHtml (ShortRef GitHash) where
|
||||
toHtml (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a))
|
||||
toHtmlRaw (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a))
|
||||
|
||||
instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where
|
||||
toHtml (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
|
||||
toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
|
||||
|
||||
|
||||
toArg :: (Semigroup a, IsString a) => a -> a
|
||||
toArg s = ":" <> s
|
||||
|
||||
toPattern :: Text -> RoutePattern
|
||||
toPattern = fromString . Text.unpack
|
||||
|
||||
|
||||
instance Pretty RepoPageTabs where
|
||||
pretty = \case
|
||||
CommitsTab{} -> "commits"
|
||||
ManifestTab{} -> "manifest"
|
||||
TreeTab{} -> "tree"
|
||||
ForksTab{} -> "forks"
|
||||
IssuesTab{} -> "issues"
|
||||
PinnedTab{} -> "pinned"
|
||||
|
||||
instance FromStringMaybe RepoPageTabs where
|
||||
fromStringMay = \case
|
||||
"commits" -> pure (CommitsTab Nothing)
|
||||
"manifest" -> pure ManifestTab
|
||||
"tree" -> pure (TreeTab Nothing)
|
||||
"forks" -> pure ForksTab
|
||||
"issues" -> pure IssuesTab
|
||||
"pinned" -> pure $ PinnedTab Nothing
|
||||
_ -> pure (CommitsTab Nothing)
|
||||
|
||||
|
||||
instance ToRoutePattern RepoListPage where
|
||||
routePattern = \case
|
||||
RepoListPage -> "/"
|
||||
|
||||
instance ToURL String where
|
||||
toURL str = path [str]
|
||||
|
||||
instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoPage s w) = path @String [ "/", show (pretty s), show (pretty w)]
|
||||
<> pred_
|
||||
where
|
||||
-- FIXME: use-uri-encode
|
||||
pred_ = case s of
|
||||
CommitsTab (Just p) -> Text.pack $ "?ref=" <> show (pretty p)
|
||||
TreeTab (Just p) -> Text.pack $ "?tree=" <> show (pretty p)
|
||||
PinnedTab (Just (s,n,h)) -> Text.pack $ "?ref=" <> show (pretty h)
|
||||
_ -> mempty
|
||||
|
||||
instance ToRoutePattern (RepoPage String String) where
|
||||
routePattern (RepoPage s w) = path ["/", toArg s, toArg w] & toPattern
|
||||
|
||||
instance ToURL RepoListPage where
|
||||
toURL _ = "/"
|
||||
|
||||
instance ToURL (RepoRefs (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoRefs repo') = path ["/", "htmx", "refs", repo]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
|
||||
instance ToRoutePattern (RepoRefs String) where
|
||||
routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & toPattern
|
||||
|
||||
|
||||
instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash) where
|
||||
toURL (RepoTree k co tree') = path ["/", "htmx", "tree", repo, commit, tree]
|
||||
where
|
||||
repo = show $ pretty k
|
||||
commit = show $ pretty co
|
||||
tree = show $ pretty tree'
|
||||
|
||||
instance ToRoutePattern (RepoTree String String String) where
|
||||
routePattern (RepoTree r co tree) =
|
||||
path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & toPattern
|
||||
|
||||
instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash) where
|
||||
toURL (RepoBlob k co t bo) = path ["/", "htmx", "blob", repo, commit, tree, blob]
|
||||
where
|
||||
repo = show $ pretty k
|
||||
commit = show $ pretty co
|
||||
tree = show $ pretty t
|
||||
blob = show $ pretty bo
|
||||
|
||||
instance ToRoutePattern (RepoBlob String String String String) where
|
||||
routePattern (RepoBlob r c t b) =
|
||||
path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & toPattern
|
||||
|
||||
|
||||
instance ToURL (RepoSomeBlob (LWWRefKey 'HBS2Basic) Text GitHash) where
|
||||
toURL (RepoSomeBlob k tp' blo) = path ["/", "htmx", "some-blob", repo, tp, blob]
|
||||
where
|
||||
repo = show $ pretty k
|
||||
tp = Text.unpack tp'
|
||||
blob = show $ pretty blo
|
||||
|
||||
instance ToRoutePattern (RepoSomeBlob String String String) where
|
||||
routePattern (RepoSomeBlob r t b) =
|
||||
path ["/", "htmx", "some-blob", toArg r, toArg t, toArg b] & toPattern
|
||||
|
||||
instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
|
||||
instance ToRoutePattern (RepoManifest String) where
|
||||
routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & toPattern
|
||||
|
||||
instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoCommits repo') = path ["/", "htmx", "commits", repo]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
|
||||
instance ToRoutePattern (RepoCommits String) where
|
||||
routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & toPattern
|
||||
|
||||
instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int) where
|
||||
toURL (RepoCommitsQ repo' off lim) = path ["/", "htmx", "commits", repo, show off, show lim]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
|
||||
instance ToRoutePattern (RepoCommitsQ String String String) where
|
||||
routePattern (RepoCommitsQ r o l) =
|
||||
path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & toPattern
|
||||
|
||||
instance ToURL (RepoCommitDefault (LWWRefKey 'HBS2Basic) GitHash) where
|
||||
toURL (RepoCommitDefault repo' h) = toURL (RepoCommitSummaryQ repo' h)
|
||||
|
||||
instance ToRoutePattern (RepoCommitDefault String String) where
|
||||
routePattern (RepoCommitDefault r h) = routePattern (RepoCommitSummaryQ r h)
|
||||
|
||||
instance ToURL (RepoCommitSummaryQ (LWWRefKey 'HBS2Basic) GitHash) where
|
||||
toURL (RepoCommitSummaryQ repo' h) = path ["/", "htmx", "commit", "summary", repo, ha]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
ha = show $ pretty h
|
||||
|
||||
instance ToRoutePattern (RepoCommitSummaryQ String String) where
|
||||
routePattern (RepoCommitSummaryQ r h) =
|
||||
path ["/", "htmx", "commit", "summary", toArg r, toArg h] & toPattern
|
||||
|
||||
instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash) where
|
||||
toURL (RepoCommitPatchQ repo' h) = path ["/", "htmx", "commit", "patch", repo, ha]
|
||||
where
|
||||
repo = show $ pretty repo'
|
||||
ha = show $ pretty h
|
||||
|
||||
instance ToRoutePattern (RepoCommitPatchQ String String) where
|
||||
routePattern (RepoCommitPatchQ r h) =
|
||||
path ["/", "htmx", "commit", "patch", toArg r, toArg h] & toPattern
|
||||
|
||||
|
||||
instance ToURL (RepoTreeEmbedded (LWWRefKey 'HBS2Basic) GitHash GitHash) where
|
||||
toURL (RepoTreeEmbedded k co tree') = path ["/", "htmx", "tree", "embedded", repo, commit, tree]
|
||||
where
|
||||
repo = show $ pretty k
|
||||
commit = show $ pretty co
|
||||
tree = show $ pretty tree'
|
||||
|
||||
instance ToRoutePattern (RepoTreeEmbedded String String String) where
|
||||
routePattern (RepoTreeEmbedded r co tree) =
|
||||
path ["/", "htmx", "tree", "embedded", toArg r, toArg co, toArg tree] & toPattern
|
||||
|
||||
|
||||
instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoForksHtmx k) = path ["/", "htmx", "forks", repo]
|
||||
where
|
||||
repo = show $ pretty k
|
||||
|
||||
instance ToRoutePattern (RepoFixmeHtmx String) where
|
||||
routePattern (RepoFixmeHtmx _ r) =
|
||||
path ["/", "htmx", "fixme", toArg r] & toPattern
|
||||
|
||||
instance ToURL (RepoFixmeHtmx RepoLww) where
|
||||
toURL (RepoFixmeHtmx argz' k) = path ["/", "htmx", "fixme", repo] <> "?" <> filtPart
|
||||
where
|
||||
repo = show $ pretty k
|
||||
filtPart = Text.intercalate "&" [ [qc|{encodeText k}={encodeText v}|] | (k,v) <- argz ]
|
||||
argz = Map.toList argz'
|
||||
|
||||
instance ToURL (Paged (RepoFixmeHtmx RepoLww)) where
|
||||
toURL (Paged p (RepoFixmeHtmx a k)) = toURL (RepoFixmeHtmx paged k)
|
||||
where paged = Map.insert "$page" (Text.pack (show p)) a
|
||||
|
||||
instance ToRoutePattern (RepoForksHtmx String) where
|
||||
routePattern (RepoForksHtmx r) =
|
||||
path ["/", "htmx", "forks", toArg r] & toPattern
|
||||
|
||||
|
||||
instance ToRoutePattern (IssuePage String String) where
|
||||
routePattern (IssuePage s w) = path ["/", "issues", toArg s, toArg w] & toPattern
|
||||
|
||||
instance ToURL (IssuePage RepoLww FixmeKey) where
|
||||
toURL (IssuePage r i) = path ["/", "issues", repo, issue]
|
||||
where
|
||||
repo = show $ pretty r
|
||||
issue = show $ pretty i
|
||||
|
||||
|
||||
agePure :: forall a b . (Integral a,Integral b) => a -> b -> Text
|
||||
agePure t0 t = do
|
||||
let sec = fromIntegral @_ @Word64 t - fromIntegral t0
|
||||
fromString $ show $
|
||||
if | sec > 86400 -> pretty (sec `div` 86400) <+> "days ago"
|
||||
| sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago"
|
||||
| otherwise -> pretty (sec `div` 60) <+> "minutes ago"
|
||||
|
|
@ -1,221 +0,0 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-git-dashboard
|
||||
version: 0.25.0.1
|
||||
license: BSD-3-Clause
|
||||
author: Dmitry Zuikov
|
||||
category: System
|
||||
build-type: Simple
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
-Wall
|
||||
-fno-warn-type-defaults
|
||||
-fno-warn-unused-matches
|
||||
-fno-warn-name-shadowing
|
||||
-O2
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
, BangPatterns
|
||||
, BlockArguments
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, DerivingVia
|
||||
, ExtendedDefaultRules
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, GeneralizedNewtypeDeriving
|
||||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeFamilies
|
||||
|
||||
|
||||
library hbs2-git-dashboard-assets
|
||||
import: shared-properties
|
||||
|
||||
build-depends:
|
||||
base
|
||||
, bytestring
|
||||
, interpolatedstring-perl6
|
||||
, file-embed
|
||||
, lucid
|
||||
, text
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Git.Web.Assets
|
||||
|
||||
hs-source-dirs: hbs2-git-dashboard-assets
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
library hbs2-git-dashboard-core
|
||||
import: shared-properties
|
||||
|
||||
build-depends:
|
||||
, base
|
||||
|
||||
, hbs2-git-dashboard-assets
|
||||
, hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-git
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
, fixme-new
|
||||
|
||||
, aeson
|
||||
, atomic-write
|
||||
, attoparsec
|
||||
, binary
|
||||
, bytestring
|
||||
, containers
|
||||
, deriving-compat
|
||||
, directory
|
||||
, exceptions
|
||||
, filepath
|
||||
, filepattern
|
||||
, generic-data
|
||||
, generic-deriving
|
||||
, generic-lens
|
||||
, http-types
|
||||
, interpolatedstring-perl6
|
||||
, lucid
|
||||
, lucid-htmx
|
||||
, memory
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, network-uri
|
||||
, optparse-applicative
|
||||
, pandoc
|
||||
, prettyprinter
|
||||
, prettyprinter-ansi-terminal
|
||||
, random
|
||||
, safe
|
||||
, scotty >= 0.21
|
||||
, serialise
|
||||
, skylighting
|
||||
, skylighting-core
|
||||
, skylighting-lucid
|
||||
, stm
|
||||
, streaming
|
||||
, split
|
||||
, temporary
|
||||
, text
|
||||
, time
|
||||
, timeit
|
||||
, transformers
|
||||
, typed-process
|
||||
, unix
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, unordered-containers
|
||||
, uri-encode
|
||||
, vector
|
||||
, wai
|
||||
, wai-extra
|
||||
, wai-middleware-static
|
||||
, wai-middleware-static-embedded
|
||||
, zlib
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Git.DashBoard.Prelude
|
||||
HBS2.Git.DashBoard.Types
|
||||
HBS2.Git.DashBoard.State
|
||||
HBS2.Git.DashBoard.State.Commits
|
||||
HBS2.Git.DashBoard.State.Index
|
||||
HBS2.Git.DashBoard.State.Index.Channels
|
||||
HBS2.Git.DashBoard.State.Index.Peer
|
||||
HBS2.Git.DashBoard.Manifest
|
||||
HBS2.Git.DashBoard.Fixme
|
||||
HBS2.Git.Web.Html.Types
|
||||
HBS2.Git.Web.Html.Parts.TopInfoBlock
|
||||
HBS2.Git.Web.Html.Parts.Issues.Sidebar
|
||||
HBS2.Git.Web.Html.Parts.Blob
|
||||
HBS2.Git.Web.Html.Markdown
|
||||
HBS2.Git.Web.Html.Root
|
||||
HBS2.Git.Web.Html.Issue
|
||||
HBS2.Git.Web.Html.Repo
|
||||
HBS2.Git.Web.Html.Fixme
|
||||
|
||||
hs-source-dirs: hbs2-git-dashboard-core
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
executable hbs2-git-dashboard
|
||||
import: shared-properties
|
||||
main-is: GitDashBoard.hs
|
||||
|
||||
ghc-options:
|
||||
-threaded
|
||||
-rtsopts
|
||||
-O2
|
||||
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base
|
||||
|
||||
, hbs2-core
|
||||
, hbs2-git
|
||||
, hbs2-git-dashboard-assets
|
||||
, hbs2-git-dashboard-core
|
||||
, hbs2-peer
|
||||
, suckless-conf
|
||||
, db-pipe
|
||||
|
||||
, binary
|
||||
, bytestring
|
||||
, deriving-compat
|
||||
, directory
|
||||
, filepath
|
||||
, generic-data
|
||||
, generic-deriving
|
||||
, http-types
|
||||
, lucid
|
||||
, lucid-htmx
|
||||
, mtl
|
||||
, network-uri
|
||||
, optparse-applicative
|
||||
, pandoc
|
||||
, random
|
||||
, scotty >= 0.21
|
||||
, skylighting
|
||||
, skylighting-core
|
||||
, skylighting-lucid
|
||||
, stm
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
, typed-process
|
||||
, unordered-containers
|
||||
, vector
|
||||
, wai
|
||||
, wai-extra
|
||||
, wai-middleware-static
|
||||
, wai-middleware-static-embedded
|
||||
|
||||
hs-source-dirs:
|
||||
app
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
Loading…
Reference in New Issue