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-core"
|
||||||
"hbs2-storage-simple"
|
"hbs2-storage-simple"
|
||||||
"hbs2-git"
|
"hbs2-git"
|
||||||
"hbs2-git-dashboard"
|
|
||||||
"hbs2-git3"
|
"hbs2-git3"
|
||||||
"hbs2-qblf"
|
|
||||||
"hbs2-fixer"
|
|
||||||
"hbs2-cli"
|
"hbs2-cli"
|
||||||
"hbs2-sync"
|
"hbs2-sync"
|
||||||
"fixme-new"
|
"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