mirror of https://github.com/voidlizard/hbs2
hbs2-git-dashboard updated; status - wip
This commit is contained in:
Dmitry Zuikov
parent
d7e8e909b5
commit
86fcde758b
|
|
@ -0,0 +1,31 @@
|
|||
Copyright (c) 2023, 2024
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
TODO: fixme-refchan-to-manifest
|
||||
добавить настройку рефчана для fixme в манифест проекта
|
||||
|
||||
TODO: fixme-refchan-allow
|
||||
добавить настройку для разрешения fixme для проекта.
|
||||
только если разрешено --- пир подписывается на этот рефчан
|
||||
и тянет из него issues
|
||||
|
||||
TODO: fixme-init
|
||||
инициализация fixme в каталоге репозитория.
|
||||
проконтроллировать, что нормально работает с bare
|
||||
репо
|
||||
|
||||
TODO: fixme-refchan-import
|
||||
встроить обновление стейта fixme в
|
||||
конвейры hbs2-git-dashboard
|
||||
(видимо, отдельным конвейром)
|
||||
|
||||
|
||||
FIXME: poll-fixme-refchans
|
||||
сейчас новые рефчаны с fixme будут подтянуты
|
||||
только при перезапуске. надо встроить явный
|
||||
poll
|
||||
|
||||
|
||||
FIXME: commit-and-blob-catch-inconsistency
|
||||
похоже, возникают ситуации, когда fixme-new захватывает
|
||||
blob и commit некорректно (из разных коммитов?), и
|
||||
hbs2-git-dashboard, бывает, не может найти blob в индексе.
|
||||
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
FIXME: poll-fixme-refchans
|
||||
поллить рефчаны fixme и обновлять
|
||||
в случае изменений.
|
||||
|
||||
Сейчас не обновляются
|
||||
|
||||
FIXME: commit-cache-inconsistency
|
||||
|
||||
Встретилась ситуация, когда commit помечен, как processed, но не все блобы
|
||||
из него попали в кэш.
|
||||
|
||||
Похожие ситуации возникают и в hbs2-git.
|
||||
|
||||
Похоже, надо как-то инвертировать подход: когда искомые данные
|
||||
встречаются в кэше --- отдаём из него, а когда нет --- ищем
|
||||
в источнике (рефчане, дереве, репозитории).
|
||||
|
||||
Значит, в этих источниках должен быть некий индекс.
|
||||
|
||||
В git он есть.
|
||||
|
||||
В hbs2-git он вроде бы тоже есть.
|
||||
|
||||
Возможно, это будет незначительно медленнее при выдаче,
|
||||
но сильно быстрее при индексации и система будет, типа,
|
||||
самовосстанавливающаяся.
|
||||
|
||||
Возможно, это приведёт к тому, что все схемы выродятся
|
||||
в таблицу "object", для ускорения доступа к которой
|
||||
будут создаваться индексные таблицы (aka materialized view)
|
||||
на её же основе только средствами sqlite.
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
TODO: ASAP-bloom-filter-of-blocks
|
||||
|
||||
Каждый пир поддерживает фильтр Блума для блоков и раздаёт этот фильтр по
|
||||
протоколу.
|
||||
|
||||
Протокол подразумевает как отдачу всего фильтра целиком ( тут подходит
|
||||
держать его в LWWRef)
|
||||
|
||||
Так и просто запросы к нему.
|
||||
|
||||
Запрос должен пролезать в UDP, таким образом, выглядит так, что это
|
||||
список чисел с номерами бит, т.е в худшем случае (8 байт на число)
|
||||
один запрос это проверка 128 блоков за раз. Поскольку CBOR у нас
|
||||
кодирует числа с переменной длиной, можно ожидать, что в среднем
|
||||
будет получше.
|
||||
|
||||
Это ускорит, возможно, на порядок поиск блоков, который тем хуже,
|
||||
чем больше в системе пиров.
|
||||
|
||||
Открытые вопросы:
|
||||
|
||||
- Параметры фильтра Блума? Зашитые в систему, или зависящие от
|
||||
пира (и тогда мы пересчитываем их)
|
||||
|
||||
- Надо ли качать фильтры целиком (кажется, что нет, но можно
|
||||
запоминать/обновлять для каждого пира, и время от времени
|
||||
чистить)
|
||||
|
||||
- Если параметры фильтра могут меняться для пира, как
|
||||
согласовывать хэш функции? Если их зашивать и менять только
|
||||
коэффициенты, то не слишком ли плохие будут хэш функции?
|
||||
|
||||
- Какие атаки может вызвать?
|
||||
|
||||
- Как эффективно хранить?
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,73 +1,8 @@
|
|||
module Main where
|
||||
|
||||
import Fixme
|
||||
-- import Fixme.Run
|
||||
import Fixme.Run
|
||||
import System.Environment
|
||||
|
||||
-- TODO: fixme-new
|
||||
-- $author: Dmitry Zuikov <dzuikov@gmail.com>
|
||||
-- $milestone: undefined
|
||||
-- $priority: ASAP
|
||||
-- после майских:
|
||||
-- 1. fixme переезжает в дерево hbs2, конкретно в hbs2-git
|
||||
|
||||
-- 2. fixme преобразуется в утилиту для генерации отчётов по репозиторию git
|
||||
--
|
||||
-- 3. fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme
|
||||
--
|
||||
-- 4. fixme начинает генерировать PR-ы в формате git (у гита есть простенькие пулл-реквесты!)
|
||||
-- и умеет постить их куда там их следует постить
|
||||
--
|
||||
-- 5. fixme получает ограничитель глубины сканирования и фильтр бранчей,
|
||||
-- что бы не окочуриваться на больших проектах
|
||||
--
|
||||
-- 6. fixme генерирует настройки по умолчанию, включая .gitignore
|
||||
--
|
||||
-- 7. fixme позволяет явно задавать лог изменений статуса, беря его как из
|
||||
-- .fixme/log так и откуда скажут
|
||||
--
|
||||
-- 8. fixme интегрируется в hbs2-git-dashboard
|
||||
--
|
||||
-- 9. fixme временно получает название fixme2 или nfixme или hfixme (не решил пока),
|
||||
-- потом возвращается к старому названию
|
||||
--
|
||||
-- 10. fixme умеет постить записи в своём формате в hbs2 или же умеет любые источники дампить в своём формате так,
|
||||
-- что бы hbs2-git мог запостить их в соответствующий рефчан
|
||||
--
|
||||
-- 11. fixme оформляет либу для экстракции фактов из git, которую будет использовать и hbs2-git-dashboard
|
||||
--
|
||||
-- 12. hbs2-git-dashboard понимает и уважает каталог настроек .fixme , а стейт берёт прямо оттуда
|
||||
|
||||
-- открытые вопросы:
|
||||
|
||||
-- hbs2-git использует fixme или fixme использует hbs2
|
||||
|
||||
-- переводить fixme на fuzzy-parse или нет (скорее, да)
|
||||
|
||||
-- переводить ли suckless-conf на fuzzy-parse сейчас (или хрен пока с ним)
|
||||
|
||||
-- встроить ли jq внутрь или лучше дать доступ к sql запросам по json
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
-- TODO: discover-config
|
||||
--
|
||||
-- TODO: local-config-has-same-name-with-binary
|
||||
--
|
||||
-- TODO: per-user-config-has-same-name-with-binary
|
||||
--
|
||||
-- TODO: per-user-config-added-after-per-project-config
|
||||
|
||||
-- TODO: scan-all-sources
|
||||
-- for-source-from-con
|
||||
|
||||
runFixmeCLI runCLI
|
||||
|
||||
-- FIXME: test-fixme
|
||||
-- $workflow: wip
|
||||
-- $assigned: voidlizard
|
||||
--
|
||||
-- Тестовый тикет с параметрами
|
||||
|
||||
|
|
|
|||
|
|
@ -8,18 +8,18 @@ import System.Environment
|
|||
import System.Directory (getXdgDirectory, XdgDirectory(..))
|
||||
|
||||
binName :: FixmePerks m => m FilePath
|
||||
binName = liftIO getProgName
|
||||
binName = pure "fixme-new" -- liftIO getProgName
|
||||
|
||||
localConfigDir :: FixmePerks m => m FilePath
|
||||
localConfigDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
|
||||
localConfigDir = do
|
||||
p <- pwd
|
||||
p <- asks fixmeEnvWorkDir >>= readTVarIO
|
||||
b <- binName
|
||||
pure (p </> ("." <> b))
|
||||
|
||||
fixmeWorkDir :: FixmePerks m => m FilePath
|
||||
fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
|
||||
fixmeWorkDir :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
|
||||
fixmeWorkDir = asks fixmeEnvWorkDir >>= readTVarIO
|
||||
|
||||
localConfig:: FixmePerks m => m FilePath
|
||||
localConfig:: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
|
||||
localConfig = localConfigDir <&> (</> "config")
|
||||
|
||||
userConfigs :: FixmePerks m => m [FilePath]
|
||||
|
|
@ -36,6 +36,6 @@ userConfigs= do
|
|||
localDBName :: FilePath
|
||||
localDBName = "state.db"
|
||||
|
||||
localDBPath :: FixmePerks m => m FilePath
|
||||
localDBPath :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
|
||||
localDBPath = localConfigDir <&> (</> localDBName)
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ data GroupKeyOpError =
|
|||
instance Exception GroupKeyOpError
|
||||
|
||||
|
||||
groupKeyFile :: forall m . FixmePerks m => m FilePath
|
||||
groupKeyFile :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
|
||||
groupKeyFile = do
|
||||
dir <- localConfigDir
|
||||
pure $ dir </> "gk0"
|
||||
|
|
|
|||
|
|
@ -113,12 +113,11 @@ runWithRPC FixmeEnv{..} m = do
|
|||
|
||||
runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a
|
||||
runFixmeCLI m = do
|
||||
dbPath <- localDBPath
|
||||
git <- findGitDir
|
||||
env <- FixmeEnv
|
||||
<$> newMVar ()
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO dbPath
|
||||
<*> (pwd >>= newTVarIO)
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO git
|
||||
<*> newTVarIO mempty
|
||||
|
|
@ -146,7 +145,6 @@ runFixmeCLI m = do
|
|||
-- не все действия требуют БД,
|
||||
-- хорошо бы, что бы она не создавалась,
|
||||
-- если не требуется
|
||||
mkdir (takeDirectory dbPath)
|
||||
recover env do
|
||||
runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
|
||||
`finally` flushLoggers
|
||||
|
|
@ -233,7 +231,7 @@ runTop forms = do
|
|||
|
||||
entry $ bindMatch "fixme-files" $ nil_ \case
|
||||
StringLikeList xs -> do
|
||||
w <- fixmeWorkDir
|
||||
w <- lift fixmeWorkDir
|
||||
t <- lift $ asks fixmeEnvFileMask
|
||||
atomically (modifyTVar t (<> fmap (w </>) xs))
|
||||
|
||||
|
|
@ -241,7 +239,7 @@ runTop forms = do
|
|||
|
||||
entry $ bindMatch "fixme-exclude" $ nil_ \case
|
||||
StringLikeList xs -> do
|
||||
w <- fixmeWorkDir
|
||||
w <- lift fixmeWorkDir
|
||||
t <- lift $ asks fixmeEnvFileExclude
|
||||
atomically (modifyTVar t (<> fmap (w </>) xs))
|
||||
|
||||
|
|
@ -385,6 +383,15 @@ runTop forms = do
|
|||
entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do
|
||||
cleanupDatabase
|
||||
|
||||
|
||||
entry $ bindMatch "fixme:state:count-by-attribute" $ nil_ $ \case
|
||||
[StringLike s] -> lift do
|
||||
rs <- countByAttribute (fromString s)
|
||||
for_ rs $ \(n,v) -> do
|
||||
liftIO $ print $ pretty n <+> pretty v
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "fixme:git:import" $ nil_ $ const $ lift do
|
||||
import_
|
||||
|
||||
|
|
@ -451,7 +458,7 @@ runTop forms = do
|
|||
[StringLike path] -> do
|
||||
|
||||
ppath <- if List.isPrefixOf "." path then do
|
||||
dir <- localConfigDir
|
||||
dir <- lift localConfigDir
|
||||
let rest = tail $ splitDirectories path
|
||||
pure $ joinPath (dir:rest)
|
||||
else do
|
||||
|
|
@ -544,10 +551,11 @@ runTop forms = do
|
|||
<&> fromMaybe "hbs2-peer not connected"
|
||||
liftIO $ putStrLn poked
|
||||
|
||||
conf <- readConfig
|
||||
|
||||
argz <- liftIO getArgs
|
||||
|
||||
conf <- readConfig
|
||||
|
||||
let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz
|
||||
& HM.unions
|
||||
|
||||
|
|
|
|||
|
|
@ -199,6 +199,10 @@ printEnv = do
|
|||
attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
|
||||
vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
|
||||
|
||||
dir <- asks fixmeEnvWorkDir >>= readTVarIO
|
||||
|
||||
liftIO $ print $ "; workdir" <+> pretty dir
|
||||
|
||||
for_ tags $ \m -> do
|
||||
liftIO $ print $ "fixme-prefix" <+> pretty m
|
||||
|
||||
|
|
@ -229,8 +233,8 @@ printEnv = do
|
|||
for_ g $ \git -> do
|
||||
liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
|
||||
|
||||
dbPath <- asks fixmeEnvDbPath >>= readTVarIO
|
||||
liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
|
||||
dbPath <- localDBPath
|
||||
liftIO $ print $ "; fixme-state-path" <+> dquotes (pretty dbPath)
|
||||
|
||||
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
|
||||
|
||||
|
|
@ -294,13 +298,13 @@ scanFiles = do
|
|||
pure True
|
||||
|
||||
|
||||
report :: (FixmePerks m, HasPredicate q) => Maybe FilePath -> q -> FixmeM m ()
|
||||
report :: (FixmePerks m, HasPredicate q, HasItemOrder q) => Maybe FilePath -> q -> FixmeM m ()
|
||||
report t q = do
|
||||
|
||||
tpl <- asks fixmeEnvTemplates >>= readTVarIO
|
||||
<&> HM.lookup (maybe "default" fromString t)
|
||||
|
||||
fxs <- listFixme q
|
||||
fxs <- listFixme (WithLimit Nothing q)
|
||||
|
||||
case tpl of
|
||||
Nothing ->
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@ module Fixme.State
|
|||
, withState
|
||||
, cleanupDatabase
|
||||
, listFixme
|
||||
, countFixme
|
||||
, countByAttribute
|
||||
, insertFixme
|
||||
, insertFixmeExported
|
||||
, modifyFixme
|
||||
|
|
@ -20,7 +22,15 @@ module Fixme.State
|
|||
, FixmeExported(..)
|
||||
, HasPredicate(..)
|
||||
, SelectPredicate(..)
|
||||
, HasLimit(..)
|
||||
, HasItemOrder(..)
|
||||
, ItemOrder(..)
|
||||
, Reversed(..)
|
||||
, LocalNonce(..)
|
||||
, WithLimit(..)
|
||||
, QueryOffset(..)
|
||||
, QueryLimit(..)
|
||||
, QueryLimitClause(..)
|
||||
) where
|
||||
|
||||
import Fixme.Prelude hiding (key)
|
||||
|
|
@ -29,8 +39,6 @@ import Fixme.Config
|
|||
|
||||
import HBS2.Base58
|
||||
import HBS2.System.Dir
|
||||
import Data.Config.Suckless hiding (key)
|
||||
import Data.Config.Suckless.Syntax
|
||||
import DBPipe.SQLite hiding (field)
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
|
|
@ -38,23 +46,16 @@ import Data.HashSet qualified as HS
|
|||
import Data.Aeson as Aeson
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Text.InterpolatedString.Perl6 (q,qc)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as Text
|
||||
import Data.Maybe
|
||||
import Data.List qualified as List
|
||||
import Data.Either
|
||||
import Data.List (sortBy,sortOn)
|
||||
import Data.Ord
|
||||
import Lens.Micro.Platform
|
||||
import Data.Generics.Product.Fields (field)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Coerce
|
||||
import Data.Fixed
|
||||
import Data.Word (Word64)
|
||||
import System.Directory (getModificationTime)
|
||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
||||
import System.TimeIt
|
||||
|
||||
-- TODO: runPipe-omitted
|
||||
-- runPipe нигде не запускается, значит, все изменения
|
||||
|
|
@ -103,19 +104,24 @@ instance FromField HashRef where
|
|||
fromField = fmap (fromString @HashRef) . fromField @String
|
||||
|
||||
evolve :: FixmePerks m => FixmeM m ()
|
||||
evolve = withState do
|
||||
evolve = do
|
||||
dbPath <- localDBPath
|
||||
debug $ "evolve" <+> pretty dbPath
|
||||
mkdir (takeDirectory dbPath)
|
||||
withState do
|
||||
createTables
|
||||
|
||||
withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a
|
||||
withState what = do
|
||||
lock <- asks fixmeLock
|
||||
|
||||
db <- withMVar lock $ \_ -> do
|
||||
t <- asks fixmeEnvDb
|
||||
mdb <- readTVarIO t
|
||||
case mdb of
|
||||
Just d -> pure (Right d)
|
||||
Nothing -> do
|
||||
path <- asks fixmeEnvDbPath >>= readTVarIO
|
||||
path <- localDBPath
|
||||
newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
|
||||
case newDb of
|
||||
Left e -> pure (Left e)
|
||||
|
|
@ -151,6 +157,59 @@ createTables = do
|
|||
|]
|
||||
|
||||
|
||||
class HasPredicate a where
|
||||
predicate :: a -> SelectPredicate
|
||||
|
||||
class HasLimit a where
|
||||
limit :: a -> Maybe QueryLimitClause
|
||||
|
||||
data ItemOrder = Direct | Reverse
|
||||
|
||||
class HasItemOrder a where
|
||||
itemOrder :: a -> ItemOrder
|
||||
itemOrder = const Direct
|
||||
|
||||
newtype Reversed a = Reversed a
|
||||
|
||||
instance HasItemOrder (Reversed a) where
|
||||
itemOrder = const Reverse
|
||||
|
||||
-- TODO: move-to-db-pipe?
|
||||
newtype QueryOffset = QueryOffset Word64
|
||||
deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
|
||||
|
||||
-- TODO: move-to-db-pipe?
|
||||
newtype QueryLimit = QueryLimit Word64
|
||||
deriving newtype (Show,Eq,Ord,Num,Enum,Integral,Real,ToField,FromField,Pretty)
|
||||
|
||||
type QueryLimitClause = (QueryOffset, QueryLimit)
|
||||
|
||||
instance HasLimit () where
|
||||
limit _ = Nothing
|
||||
|
||||
data WithLimit q = WithLimit (Maybe QueryLimitClause) q
|
||||
|
||||
instance HasItemOrder q => HasItemOrder (WithLimit q) where
|
||||
itemOrder (WithLimit _ q) = itemOrder q
|
||||
|
||||
instance HasItemOrder [Syntax c] where
|
||||
itemOrder = const Direct
|
||||
|
||||
instance HasItemOrder () where
|
||||
itemOrder = const Direct
|
||||
|
||||
instance HasPredicate q => HasPredicate (WithLimit q) where
|
||||
predicate (WithLimit _ query) = predicate query
|
||||
|
||||
instance HasLimit (WithLimit a) where
|
||||
limit (WithLimit l _) = l
|
||||
|
||||
instance HasPredicate q => HasPredicate (Reversed q) where
|
||||
predicate (Reversed q) = predicate q
|
||||
|
||||
instance HasLimit q => HasLimit (Reversed q) where
|
||||
limit (Reversed q) = limit q
|
||||
|
||||
data SelectPredicate =
|
||||
All
|
||||
| FixmeHashExactly Text
|
||||
|
|
@ -161,8 +220,6 @@ data SelectPredicate =
|
|||
| Ignored
|
||||
deriving stock (Data,Generic,Show)
|
||||
|
||||
class HasPredicate a where
|
||||
predicate :: a -> SelectPredicate
|
||||
|
||||
instance HasPredicate () where
|
||||
predicate = const All
|
||||
|
|
@ -170,7 +227,6 @@ instance HasPredicate () where
|
|||
instance HasPredicate SelectPredicate where
|
||||
predicate = id
|
||||
|
||||
|
||||
instance IsContext c => HasPredicate [Syntax c] where
|
||||
predicate s = goPred $ unlist $ go s
|
||||
where
|
||||
|
|
@ -314,7 +370,57 @@ selectFixmeKey s = do
|
|||
sqliteToAeson :: FromJSON a => Text -> Maybe a
|
||||
sqliteToAeson = Aeson.decode . LBS.fromStrict . Text.encodeUtf8
|
||||
|
||||
listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q)
|
||||
|
||||
countFixme :: (FixmePerks m, MonadReader FixmeEnv m) => m Int
|
||||
countFixme = do
|
||||
|
||||
let present = [qc|coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
|
||||
|
||||
let sql = [qc|
|
||||
with s1 as (
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
|
||||
from object o
|
||||
group by o.o
|
||||
)
|
||||
select count(s1.blob) from s1
|
||||
where
|
||||
{present}
|
||||
|]
|
||||
|
||||
debug $ pretty sql
|
||||
|
||||
withState $ select_ @_ @(Only Int) sql
|
||||
<&> maybe 0 fromOnly . headMay
|
||||
|
||||
|
||||
countByAttribute :: ( FixmePerks m
|
||||
, MonadReader FixmeEnv m
|
||||
)
|
||||
=> FixmeAttrName
|
||||
-> m [(FixmeAttrVal, Int)]
|
||||
countByAttribute name = do
|
||||
let sql = [qc|
|
||||
|
||||
|
||||
select v, count(1) from object o
|
||||
where not exists
|
||||
( select null from object o1
|
||||
where o1.o = o.o
|
||||
and o1.k = 'deleted' and o1.v == 'true'
|
||||
)
|
||||
and o.k = ?
|
||||
group by v
|
||||
|
||||
|]
|
||||
|
||||
withState $ select sql (Only name)
|
||||
|
||||
listFixme :: ( FixmePerks m
|
||||
, MonadReader FixmeEnv m
|
||||
, HasPredicate q
|
||||
, HasLimit q
|
||||
, HasItemOrder q
|
||||
)
|
||||
=> q
|
||||
-> m [Fixme]
|
||||
listFixme expr = do
|
||||
|
|
@ -323,9 +429,17 @@ listFixme expr = do
|
|||
|
||||
let present = [qc|and coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
|
||||
|
||||
let (limitClause, lbound) = case limit expr of
|
||||
Just (o,l) -> ([qc|limit ? offset ?|] :: String, [Bound l, Bound o])
|
||||
Nothing -> (mempty, [])
|
||||
|
||||
let o = case itemOrder expr of
|
||||
Direct -> "asc" :: String
|
||||
Reverse -> "desc"
|
||||
|
||||
let sql = [qc|
|
||||
with s1 as (
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob
|
||||
from object o
|
||||
group by o.o
|
||||
)
|
||||
|
|
@ -334,13 +448,14 @@ listFixme expr = do
|
|||
{w}
|
||||
{present}
|
||||
order by
|
||||
json_extract(s1.blob, '$.commit-time') asc nulls last,
|
||||
json_extract(s1.blob, '$.w') asc nulls last
|
||||
json_extract(s1.blob, '$.commit-time') {o} nulls last,
|
||||
json_extract(s1.blob, '$.w') {o} nulls last
|
||||
{limitClause}
|
||||
|]
|
||||
|
||||
debug $ pretty sql
|
||||
|
||||
withState $ select @(Only Text) sql bound
|
||||
withState $ select @(Only Text) sql (bound <> lbound)
|
||||
<&> fmap (sqliteToAeson . fromOnly)
|
||||
<&> catMaybes
|
||||
|
||||
|
|
@ -348,7 +463,7 @@ getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme
|
|||
getFixme key = do
|
||||
|
||||
let sql = [qc|
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.fixme-timestamp', cast(max(o.w) as text)) as text) as blob
|
||||
from object o
|
||||
where o.o = ?
|
||||
group by o.o
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@ import DBPipe.SQLite hiding (field)
|
|||
import HBS2.Git.Local
|
||||
|
||||
import HBS2.OrDie
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Storage as Exported
|
||||
import HBS2.Peer.CLI.Detect
|
||||
import HBS2.Peer.RPC.Client as Exported hiding (encode,decode)
|
||||
|
|
@ -124,12 +125,12 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
|
|||
deriving stock (Data,Generic)
|
||||
|
||||
newtype FixmeTimestamp = FixmeTimestamp Word64
|
||||
deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
|
||||
deriving newtype (Eq,Ord,Show,Enum,Num,Integral,Real,ToField,FromField,ToJSON)
|
||||
deriving stock (Data,Generic)
|
||||
|
||||
|
||||
newtype FixmeKey = FixmeKey Text
|
||||
deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid)
|
||||
deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid,IsString)
|
||||
deriving stock (Data,Generic)
|
||||
|
||||
newtype FixmeOffset = FixmeOffset Word32
|
||||
|
|
@ -137,6 +138,9 @@ newtype FixmeOffset = FixmeOffset Word32
|
|||
deriving newtype (Integral,Real,Enum)
|
||||
deriving stock (Data,Generic)
|
||||
|
||||
instance FromStringMaybe FixmeKey where
|
||||
fromStringMay s = pure (fromString s)
|
||||
|
||||
|
||||
data Fixme =
|
||||
Fixme
|
||||
|
|
@ -218,6 +222,7 @@ instance FromJSON Fixme where
|
|||
(FixmeAttrName (Aeson.toText k),) <$>
|
||||
case v of
|
||||
String x -> pure (FixmeAttrVal x)
|
||||
Number x -> pure (FixmeAttrVal (Text.pack $ show x))
|
||||
_ -> Nothing
|
||||
|
||||
newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
|
||||
|
|
@ -344,7 +349,7 @@ data FixmeEnv =
|
|||
FixmeEnv
|
||||
{ fixmeLock :: MVar ()
|
||||
, fixmeEnvOpts :: TVar FixmeOpts
|
||||
, fixmeEnvDbPath :: TVar FilePath
|
||||
, fixmeEnvWorkDir :: TVar FilePath
|
||||
, fixmeEnvDb :: TVar (Maybe DBPipeEnv)
|
||||
, fixmeEnvGitDir :: TVar (Maybe FilePath)
|
||||
, fixmeEnvFileMask :: TVar [FilePattern]
|
||||
|
|
@ -368,7 +373,7 @@ data FixmeEnv =
|
|||
, fixmeEnvReader :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic))
|
||||
, fixmeEnvFlags :: TVar (HashSet FixmeFlags)
|
||||
}
|
||||
|
||||
deriving stock (Generic)
|
||||
|
||||
fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text]
|
||||
|
||||
|
|
@ -411,11 +416,11 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
|
|||
|
||||
|
||||
fixmeEnvBare :: forall m . FixmePerks m => m FixmeEnv
|
||||
fixmeEnvBare =
|
||||
fixmeEnvBare = do
|
||||
FixmeEnv
|
||||
<$> newMVar ()
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO ":memory:"
|
||||
<*> (pwd >>= newTVarIO)
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO mempty
|
||||
|
|
@ -463,7 +468,7 @@ instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX
|
|||
getClientAPI = getApiOrThrow peerStorageAPI
|
||||
|
||||
|
||||
instance (FixmePerks m, MonadReader FixmeEnv m) => HasStorage m where
|
||||
instance (FixmePerks m) => HasStorage (FixmeM m) where
|
||||
getStorage = do
|
||||
api <- getClientAPI @StorageAPI @UNIX
|
||||
pure $ AnyStorage (StorageClient api)
|
||||
|
|
@ -714,7 +719,19 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
|
|||
(_,_) -> b
|
||||
|
||||
fixmeDerivedFields :: Fixme -> Fixme
|
||||
fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
|
||||
fixmeDerivedFields fx = do
|
||||
-- TODO: refactor-this-out
|
||||
-- чревато ошибками, надо как-то переписать
|
||||
-- по-человечески.
|
||||
fxEnd
|
||||
<> fx
|
||||
<> fxKey
|
||||
<> fxCo
|
||||
<> tag
|
||||
<> fxLno
|
||||
<> fxTs
|
||||
-- always last
|
||||
<> fxMisc
|
||||
where
|
||||
email = HM.lookup "commiter-email" (fixmeAttr fx)
|
||||
& maybe mempty (\x -> " <" <> x <> ">")
|
||||
|
|
@ -740,6 +757,9 @@ fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
|
|||
fxCo =
|
||||
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
|
||||
|
||||
fxTs =
|
||||
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "fixme-timestamp" (fromString (show c)) }) (fixmeTs fx)
|
||||
|
||||
fxMisc =
|
||||
fx & over (field @"fixmeAttr")
|
||||
(HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx))))
|
||||
|
|
|
|||
|
|
@ -26,11 +26,11 @@
|
|||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1727252661,
|
||||
"narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=",
|
||||
"lastModified": 1727503203,
|
||||
"narHash": "sha256-/HVVyxa55pDLzMiRgCWB4YKVsW2v9wFHTlSpLnyuhkU=",
|
||||
"ref": "refs/heads/master",
|
||||
"rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c",
|
||||
"revCount": 9,
|
||||
"rev": "7f28fdcb2ba9ccd426facffebf100e98522d7eac",
|
||||
"revCount": 11,
|
||||
"type": "git",
|
||||
"url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
|
||||
},
|
||||
|
|
|
|||
24
flake.nix
24
flake.nix
|
|
@ -49,6 +49,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
"hbs2-core"
|
||||
"hbs2-storage-simple"
|
||||
"hbs2-git"
|
||||
"hbs2-git-dashboard"
|
||||
"hbs2-qblf"
|
||||
"hbs2-keyman"
|
||||
"hbs2-keyman-direct-lib"
|
||||
|
|
@ -71,18 +72,19 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
inherit packageNames;
|
||||
|
||||
packageDirs = {
|
||||
"hbs2" = "./hbs2";
|
||||
"hbs2-tests" = "./hbs2-tests";
|
||||
"hbs2-core" = "./hbs2-core";
|
||||
"hbs2-storage-simple" = "./hbs2-storage-simple";
|
||||
"hbs2-peer" = "./hbs2-peer";
|
||||
"hbs2-keyman" = "./hbs2-keyman/hbs2-keyman";
|
||||
"hbs2" = "./hbs2";
|
||||
"hbs2-tests" = "./hbs2-tests";
|
||||
"hbs2-core" = "./hbs2-core";
|
||||
"hbs2-storage-simple" = "./hbs2-storage-simple";
|
||||
"hbs2-peer" = "./hbs2-peer";
|
||||
"hbs2-keyman" = "./hbs2-keyman/hbs2-keyman";
|
||||
"hbs2-keyman-direct-lib" = "./hbs2-keyman/hbs2-keyman-direct-lib";
|
||||
"hbs2-git" = "./hbs2-git";
|
||||
"hbs2-fixer" = "./hbs2-fixer";
|
||||
"hbs2-cli" = "./hbs2-cli";
|
||||
"hbs2-sync" = "./hbs2-sync";
|
||||
"fixme-new" = "./fixme-new";
|
||||
"hbs2-git" = "./hbs2-git";
|
||||
"hbs2-git-dashboard" = "./hbs2-git-dashboard";
|
||||
"hbs2-fixer" = "./hbs2-fixer";
|
||||
"hbs2-cli" = "./hbs2-cli";
|
||||
"hbs2-sync" = "./hbs2-sync";
|
||||
"fixme-new" = "./fixme-new";
|
||||
};
|
||||
|
||||
hpPreOverrides = {pkgs, ...}: final: prev: ((with pkgs; {
|
||||
|
|
|
|||
|
|
@ -178,7 +178,7 @@ library
|
|||
, resourcet
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, saltine ^>=0.2.0.1
|
||||
, saltine >=0.2.0.1
|
||||
, serialise
|
||||
, sockaddr
|
||||
, split
|
||||
|
|
|
|||
|
|
@ -0,0 +1,756 @@
|
|||
{-# 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
|
||||
|
||||
void $ ContT $ withAsync do
|
||||
fix \next -> do
|
||||
dbe' <- readTVarIO (_db env)
|
||||
case dbe' of
|
||||
Just dbe -> do
|
||||
notice $ green "Aquired database!"
|
||||
runPipe dbe
|
||||
|
||||
Nothing -> do
|
||||
pause @'Seconds 5
|
||||
next
|
||||
|
||||
void $ 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")
|
||||
|
||||
redirect (LT.fromStrict $ toURL (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 <- lift (Scotty.header "Referer")
|
||||
>>= orFall (redirect $ LT.fromStrict $ toURL (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
|
||||
pno <- getHttpPortNumber
|
||||
wo <- WebOptions <$> getDevAssets
|
||||
|
||||
env <- ask
|
||||
|
||||
notice "evolving db"
|
||||
withState evolveDB
|
||||
|
||||
notice "running config"
|
||||
conf <- readConfig
|
||||
|
||||
run theDict conf
|
||||
|
||||
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]
|
||||
|
||||
|
||||
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
||||
updateIndexPeriodially = do
|
||||
|
||||
|
||||
api <- asks _refLogAPI
|
||||
|
||||
env <- ask
|
||||
|
||||
changes <- newTQueueIO
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
p1 <- ContT $ withAsync $ forever do
|
||||
rs <- atomically $ peekTQueue changes >> flushTQueue changes
|
||||
addJob (withDashBoardEnv env updateIndex)
|
||||
pause @'Seconds 1
|
||||
|
||||
p2 <- pollRepos changes
|
||||
|
||||
p3 <- pollFixmies
|
||||
|
||||
void $ waitAnyCatchCancel [p1,p2,p3]
|
||||
|
||||
where
|
||||
|
||||
pollFixmies = do
|
||||
|
||||
env <- ask
|
||||
|
||||
api <- asks _refChanAPI
|
||||
|
||||
cached <- newTVarIO ( mempty :: HashMap MyRefChan HashRef )
|
||||
|
||||
let chans = selectRepoFixme
|
||||
<&> fmap (,60)
|
||||
|
||||
ContT $ withAsync $ do
|
||||
polling (Polling 1 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
|
||||
|
||||
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
|
||||
-- откуда нам вообще знать, что там всё получилось?
|
||||
atomically $ modifyTVar cached (HM.insert r new)
|
||||
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 1 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
|
||||
|
||||
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
|
||||
|
||||
lift $ buildCommitTreeIndex (coerce lww)
|
||||
|
||||
|
||||
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
|
||||
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
|
||||
pure ()
|
||||
|
||||
_ -> 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
|
||||
|
||||
|
||||
|
|
@ -8,7 +8,7 @@ import Text.InterpolatedString.Perl6 (qc)
|
|||
import Lucid.Base
|
||||
|
||||
version :: Int
|
||||
version = 3
|
||||
version = 8
|
||||
|
||||
assetsDir :: [(FilePath, ByteString)]
|
||||
assetsDir = $(embedDir "hbs2-git-dashboard-assets/assets")
|
||||
|
|
@ -35,6 +35,7 @@ data IconType
|
|||
| IconArrowUturnLeft
|
||||
| IconLicense
|
||||
| IconPinned
|
||||
| IconFixme
|
||||
|
||||
svgIcon :: Monad m => IconType -> HtmlT m ()
|
||||
svgIcon = toHtmlRaw . svgIconText
|
||||
|
|
@ -177,3 +178,24 @@ svgIconText IconPinned = [qc|<svg xmlns="http://www.w3.org/2000/svg" class="icon
|
|||
<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>|]
|
||||
|
||||
|
||||
|
|
@ -25,16 +25,21 @@
|
|||
|
||||
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;
|
||||
|
|
@ -84,6 +89,9 @@ article {
|
|||
color: var(--pico-secondary-hover);
|
||||
}
|
||||
|
||||
.copyable-text {
|
||||
}
|
||||
|
||||
.copy-button .icon {
|
||||
width: 1.125rem;
|
||||
height: 1.125rem;
|
||||
|
|
@ -202,6 +210,27 @@ td.commit-hash {
|
|||
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; }
|
||||
|
|
@ -0,0 +1,142 @@
|
|||
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
|
||||
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
{-# 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,3 +1,4 @@
|
|||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module HBS2.Git.DashBoard.Prelude
|
||||
( module HBS2.Git.DashBoard.Prelude
|
||||
, module HBS2.Prelude.Plated
|
||||
|
|
@ -18,6 +19,7 @@ module HBS2.Git.DashBoard.Prelude
|
|||
, module UnliftIO
|
||||
, module Codec.Serialise
|
||||
, GitRef(..), GitHash(..), GitObjectType(..)
|
||||
, pattern SignPubKeyLike
|
||||
, qc, q
|
||||
) where
|
||||
|
||||
|
|
@ -31,6 +33,7 @@ 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
|
||||
|
|
@ -19,12 +19,14 @@ import HBS2.Git.Data.RepoHead
|
|||
import HBS2.Git.Data.Tx.Git
|
||||
import HBS2.Git.Local
|
||||
import HBS2.Git.Local.CLI
|
||||
import HBS2.System.Dir
|
||||
|
||||
import DBPipe.SQLite hiding (insert)
|
||||
import DBPipe.SQLite qualified as S
|
||||
import DBPipe.SQLite.Generic as G
|
||||
|
||||
|
||||
import Data.Aeson as Aeson
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Lucid.Base
|
||||
|
|
@ -35,6 +37,7 @@ import Data.List qualified as List
|
|||
import Data.Map qualified as Map
|
||||
import Data.Map (Map)
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
|
||||
import Skylighting.Core qualified as Sky
|
||||
import Skylighting qualified as Sky
|
||||
|
|
@ -54,8 +57,6 @@ instance Semigroup RepoListPred where
|
|||
instance Monoid RepoListPred where
|
||||
mempty = RepoListPred Nothing Nothing
|
||||
|
||||
type MyRefChan = RefChanId L4Proto
|
||||
type MyRefLogKey = RefLogKey 'HBS2Basic
|
||||
|
||||
evolveDB :: DashBoardPerks m => DBPipeM m ()
|
||||
evolveDB = do
|
||||
|
|
@ -108,6 +109,16 @@ evolveDB = do
|
|||
createRepoCommitTable
|
||||
createForksTable
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists object
|
||||
( o text not null
|
||||
, w integer not null
|
||||
, k text not null
|
||||
, v text not null
|
||||
, nonce text null
|
||||
, primary key (o,k)
|
||||
)
|
||||
|]
|
||||
|
||||
instance ToField GitHash where
|
||||
toField x = toField $ show $ pretty x
|
||||
|
|
@ -143,9 +154,11 @@ newtype RepoHeadTx = RepoHeadTx HashRef
|
|||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
|
||||
instance Serialise RepoHeadTx
|
||||
|
||||
newtype RepoName = RepoName Text
|
||||
deriving stock (Eq,Show,Generic)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString,Pretty)
|
||||
|
||||
newtype RepoBrief = RepoBrief Text
|
||||
deriving stock (Generic)
|
||||
|
|
@ -161,8 +174,11 @@ newtype RepoCommitsNum = RepoCommitsNum Int
|
|||
deriving newtype (ToField,FromField,Show,Pretty)
|
||||
|
||||
newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
deriving stock (Generic,Ord,Eq)
|
||||
deriving newtype (ToField,FromField,Pretty,Hashable)
|
||||
|
||||
instance Show RepoLww where
|
||||
show (RepoLww x) = show $ parens $ "RepoLww" <+> pretty x
|
||||
|
||||
newtype RepoLwwSeq = RepoLwwSeq Integer
|
||||
deriving stock (Generic)
|
||||
|
|
@ -170,11 +186,15 @@ newtype RepoLwwSeq = RepoLwwSeq Integer
|
|||
|
||||
newtype RepoChannel = RepoChannel MyRefChan
|
||||
|
||||
newtype RefChanField = RefChanField MyRefChan
|
||||
deriving stock (Generic)
|
||||
|
||||
newtype RepoHeadRef = RepoHeadRef HashRef
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField)
|
||||
|
||||
instance Serialise RepoHeadRef
|
||||
|
||||
|
||||
newtype RepoHeadSeq = RepoHeadSeq Word64
|
||||
deriving stock (Generic)
|
||||
|
|
@ -182,15 +202,26 @@ newtype RepoHeadSeq = RepoHeadSeq Word64
|
|||
|
||||
newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
deriving newtype (ToField,FromField,Pretty,Serialise)
|
||||
|
||||
newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (ToField,FromField)
|
||||
|
||||
newtype Base58Field a = Base58Field { fromBase58Field :: a }
|
||||
deriving stock (Eq,Ord,Generic)
|
||||
|
||||
|
||||
instance ToField RepoChannel where
|
||||
toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x)
|
||||
|
||||
instance ToField RefChanField where
|
||||
toField (RefChanField x) = toField $ show $ pretty (AsBase58 x)
|
||||
|
||||
instance FromField RefChanField where
|
||||
fromField w = fromField @String w
|
||||
>>= maybe (fail "invalid key") (pure . RefChanField) . fromStringMay
|
||||
|
||||
data TxProcessedTable
|
||||
data RepoTable
|
||||
data RepoChannelTable
|
||||
|
|
@ -272,10 +303,11 @@ asRefChan = \case
|
|||
LitStrVal s -> fromStringMay @MyRefChan (Text.unpack s)
|
||||
_ -> Nothing
|
||||
|
||||
getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan]
|
||||
getIndexEntries :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [MyRefChan]
|
||||
getIndexEntries = do
|
||||
conf <- getConf
|
||||
pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
||||
pure mempty
|
||||
-- conf <- getConf
|
||||
-- pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
|
||||
|
||||
|
||||
data NiceTS = NiceTS
|
||||
|
|
@ -438,6 +470,15 @@ createRepoHeadTable = do
|
|||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists repoheadfixme
|
||||
( lww text not null
|
||||
, lwwseq integer not null
|
||||
, refchan text not null
|
||||
, primary key (lww, lwwseq)
|
||||
)
|
||||
|]
|
||||
|
||||
data RepoHeadTable
|
||||
|
||||
instance HasTableName RepoHeadTable where
|
||||
|
|
@ -482,6 +523,29 @@ insertRepoHead lww lwwseq rlog tx rf rh = do
|
|||
|
||||
pure ()
|
||||
|
||||
|
||||
insertRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> RepoLwwSeq
|
||||
-> MyRefChan
|
||||
-> DBPipeM m ()
|
||||
insertRepoFixme lww lwwseq r = do
|
||||
S.insert [qc|
|
||||
insert into repoheadfixme (lww, lwwseq, refchan) values(?,?,?)
|
||||
on conflict (lww, lwwseq) do update set refchan = excluded.refchan
|
||||
|]
|
||||
(lww, lwwseq, RefChanField r)
|
||||
|
||||
selectRepoFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> m [(RepoLww, MyRefChan)]
|
||||
|
||||
selectRepoFixme = do
|
||||
let sql = [qc|
|
||||
select lww, refchan from (select lww, refchan, max(lwwseq) from repoheadfixme group by lww)
|
||||
|]
|
||||
withState $ select_ @_ @(RepoLww, RefChanField) sql
|
||||
<&> fmap (over _2 coerce)
|
||||
|
||||
-- FIXME: what-if-two-repo-shares-one-reflog?
|
||||
selectLwwByRefLog :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoRefLog -> m (Maybe RepoLww)
|
||||
selectLwwByRefLog rlog = withState do
|
||||
|
|
@ -531,7 +595,7 @@ createRepoCommitTable = do
|
|||
|]
|
||||
|
||||
|
||||
isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool
|
||||
isProcessed :: (MonadIO m) => HashRef -> DBPipeM m Bool
|
||||
isProcessed href = do
|
||||
select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href)
|
||||
<&> not . List.null
|
||||
|
|
@ -694,6 +758,144 @@ readBlob repo hash = do
|
|||
<&> fromRight mempty
|
||||
|
||||
|
||||
updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
|
||||
updateForks lww = withState do
|
||||
|
||||
S.insert [qc|
|
||||
insert into fork (a,b)
|
||||
select distinct r0.lww
|
||||
, r1.lww
|
||||
from repocommit r0 join repocommit r1 on r0.kommit = r1.kommit and r0.lww <> r1.lww
|
||||
where r0.lww = ?
|
||||
on conflict (a,b) do nothing
|
||||
|] (Only lww)
|
||||
|
||||
pure ()
|
||||
|
||||
checkCommitProcessed :: (MonadIO m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic -> GitHash -> m Bool
|
||||
checkCommitProcessed lww co = withState do
|
||||
select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
|
||||
<&> listToMaybe @(Only Int) <&> isJust
|
||||
|
||||
listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey HBS2Basic -> m [GitHash]
|
||||
listCommits lww = do
|
||||
dir <- repoDataPath lww
|
||||
gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
|
||||
<&> fromRight mempty
|
||||
<&> mapMaybe (headMay . LBS8.words) . LBS8.lines
|
||||
<&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
|
||||
|
||||
|
||||
getTreeRecursive :: (MonadUnliftIO m,MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey HBS2Basic
|
||||
-> GitHash
|
||||
-> m (Map [FilePath] GitHash,[(FilePath, (GitHash, Integer, Maybe Text))])
|
||||
getTreeRecursive lww co = do
|
||||
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
dir <- repoDataPath lww
|
||||
items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
|
||||
<&> fromRight mempty
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe \case
|
||||
[_,"tree",h,_,n] ->
|
||||
(reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
|
||||
|
||||
[_,"blob",h,size,n] -> do
|
||||
let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
|
||||
<&> List.singleton
|
||||
|
||||
let ha = fromStringMay @GitHash (LBS8.unpack h)
|
||||
let sz = readMay @Integer (LBS8.unpack size)
|
||||
|
||||
let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
|
||||
& headMay
|
||||
<&> Text.toLower . Sky.sName
|
||||
|
||||
(,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
|
||||
let blobs = [ (k,v) | ([k],Left v) <- items ]
|
||||
pure (trees, blobs)
|
||||
|
||||
getRootTree :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey HBS2Basic -> GitHash -> m (Maybe GitHash)
|
||||
getRootTree lww co = do
|
||||
dir <- repoDataPath lww
|
||||
let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|]
|
||||
|
||||
gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> LBS8.lines
|
||||
<&> \case
|
||||
(TreeHash ha : _) -> Just ha
|
||||
_ -> Nothing
|
||||
|
||||
updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
|
||||
=> LWWRefKey HBS2Basic -> GitHash -> m ()
|
||||
updateRepoData lww co = do
|
||||
|
||||
env <- ask
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
root <- lift (getRootTree lww co) >>= toMPlus
|
||||
(trees, blobs) <- lift $ getTreeRecursive lww co
|
||||
|
||||
-- lift $ addJob $ liftIO $ withDashBoardEnv env do
|
||||
|
||||
lift $ withState $ transactional do
|
||||
|
||||
insert @RepoCommitTable $
|
||||
onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
|
||||
|
||||
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
||||
insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
|
||||
|
||||
for_ (Map.toList trees) $ \(t,h0) -> do
|
||||
|
||||
case t of
|
||||
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
||||
_ -> pure ()
|
||||
|
||||
let child = tailSafe t
|
||||
debug $ red "TREE-REL:" <+> pretty t
|
||||
let parent = Map.lookup child trees
|
||||
|
||||
for_ parent $ \p -> do
|
||||
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
||||
insertTree ( TreeCommit co
|
||||
, TreeParent p
|
||||
, TreeTree h0
|
||||
, TreeLevel (length t)
|
||||
, TreePath (headDef "" t)
|
||||
)
|
||||
|
||||
updateForks lww
|
||||
|
||||
buildSingleCommitTreeIndex :: ( MonadUnliftIO m
|
||||
, DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> m ()
|
||||
buildSingleCommitTreeIndex lww co = do
|
||||
|
||||
env <- ask
|
||||
ignoreCaches <- getIgnoreCaches
|
||||
|
||||
void $ runMaybeT do
|
||||
done <- checkCommitProcessed lww co
|
||||
let skip = done && not ignoreCaches
|
||||
guard (not skip)
|
||||
lift $ updateRepoData lww co
|
||||
|
||||
buildCommitTreeIndex :: ( MonadUnliftIO m
|
||||
, DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
|
|
@ -702,116 +904,16 @@ buildCommitTreeIndex :: ( MonadUnliftIO m
|
|||
-> m ()
|
||||
buildCommitTreeIndex lww = do
|
||||
|
||||
commits <- listCommits
|
||||
commits <- listCommits lww
|
||||
env <- ask
|
||||
|
||||
ignoreCaches <- getIgnoreCaches
|
||||
|
||||
for_ commits $ \co -> void $ runMaybeT do
|
||||
checkCommitProcessed co >>= guard . not
|
||||
updateRepoData env co
|
||||
|
||||
updateForks
|
||||
|
||||
where
|
||||
|
||||
syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
updateForks = withState do
|
||||
|
||||
S.insert [qc|
|
||||
insert into fork (a,b)
|
||||
select distinct r0.lww
|
||||
, r1.lww
|
||||
from repocommit r0 join repocommit r1 on r0.kommit = r1.kommit and r0.lww <> r1.lww
|
||||
where r0.lww = ?
|
||||
on conflict (a,b) do nothing
|
||||
|] (Only lww)
|
||||
|
||||
pure ()
|
||||
|
||||
updateRepoData env co = do
|
||||
|
||||
root <- getRootTree co >>= toMPlus
|
||||
(trees, blobs) <- getTreeRecursive co
|
||||
|
||||
lift $ addJob $ liftIO $ withDashBoardEnv env do
|
||||
|
||||
withState $ transactional do
|
||||
|
||||
insert @RepoCommitTable $
|
||||
onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
|
||||
|
||||
for_ blobs $ \(fn, (hash, size, syn)) -> do
|
||||
insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
|
||||
|
||||
for_ (Map.toList trees) $ \(t,h0) -> do
|
||||
|
||||
case t of
|
||||
[x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
|
||||
_ -> pure ()
|
||||
|
||||
let child = tailSafe t
|
||||
debug $ red "TREE-REL:" <+> pretty t
|
||||
let parent = Map.lookup child trees
|
||||
|
||||
for_ parent $ \p -> do
|
||||
debug $ red "FOUND SHIT:" <+> pretty (h0,p)
|
||||
insertTree ( TreeCommit co
|
||||
, TreeParent p
|
||||
, TreeTree h0
|
||||
, TreeLevel (length t)
|
||||
, TreePath (headDef "" t)
|
||||
)
|
||||
|
||||
|
||||
getTreeRecursive co = lift do
|
||||
dir <- repoDataPath lww
|
||||
items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
|
||||
<&> fromRight mempty
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe \case
|
||||
[_,"tree",h,_,n] ->
|
||||
(reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
|
||||
|
||||
[_,"blob",h,size,n] -> do
|
||||
let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
|
||||
<&> List.singleton
|
||||
|
||||
let ha = fromStringMay @GitHash (LBS8.unpack h)
|
||||
let sz = readMay @Integer (LBS8.unpack size)
|
||||
|
||||
let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
|
||||
& headMay
|
||||
<&> Text.toLower . Sky.sName
|
||||
|
||||
(,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
|
||||
let blobs = [ (k,v) | ([k],Left v) <- items ]
|
||||
pure (trees, blobs)
|
||||
|
||||
getRootTree co = lift do
|
||||
dir <- repoDataPath lww
|
||||
let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|]
|
||||
|
||||
gitRunCommand cmd
|
||||
<&> fromRight mempty
|
||||
<&> LBS8.lines
|
||||
<&> \case
|
||||
(TreeHash ha : _) -> Just ha
|
||||
_ -> Nothing
|
||||
|
||||
checkCommitProcessed co = lift $ withState do
|
||||
select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
|
||||
<&> listToMaybe @(Only Int) <&> isJust
|
||||
|
||||
listCommits = do
|
||||
dir <- repoDataPath lww
|
||||
gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
|
||||
<&> fromRight mempty
|
||||
<&> mapMaybe (headMay . LBS8.words) . LBS8.lines
|
||||
<&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
|
||||
done <- checkCommitProcessed lww co
|
||||
let skip = done && not ignoreCaches
|
||||
guard (not skip)
|
||||
lift $ addJob $ withDashBoardEnv env (updateRepoData lww co)
|
||||
|
||||
-- FIXME: check-names-with-spaces
|
||||
|
||||
|
|
@ -872,3 +974,141 @@ gitShowRefs what = do
|
|||
pure $ view repoHeadRefs hd
|
||||
|
||||
|
||||
insertOWKV :: (DashBoardPerks m, ToJSON a)
|
||||
=> Text
|
||||
-> Maybe Integer
|
||||
-> Text
|
||||
-> a
|
||||
-> DBPipeM m ()
|
||||
insertOWKV o w k v = do
|
||||
|
||||
let sql = [qc|
|
||||
|
||||
insert into object (o, w, k, v)
|
||||
values (?, ?, ?, cast (? as text))
|
||||
on conflict (o, k)
|
||||
do update set
|
||||
v = case
|
||||
when excluded.w > object.w then excluded.v
|
||||
else object.v
|
||||
end,
|
||||
w = case
|
||||
when excluded.w > object.w then excluded.w
|
||||
else object.w
|
||||
end
|
||||
|]
|
||||
|
||||
t <- maybe1 w (round <$> liftIO getPOSIXTime) pure
|
||||
|
||||
S.insert sql (o,t,k,Aeson.encode v)
|
||||
|
||||
|
||||
insertOption :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
, Pretty a
|
||||
, Serialise a)
|
||||
=> Text
|
||||
-> a
|
||||
-> m ()
|
||||
insertOption key value = do
|
||||
w <- liftIO getPOSIXTime <&> fromIntegral . round
|
||||
let o = hashObject @HbSync (serialise ("option", key)) & pretty & show
|
||||
let v = show $ pretty v
|
||||
withState $ transactional do
|
||||
insertOWKV (fromString o) (Just w) "$type" "option"
|
||||
insertOWKV (fromString o) (Just w) "name" key
|
||||
insertOWKV (fromString o) (Just w) "value" (fromString v)
|
||||
|
||||
|
||||
insertFixmeAllowed :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> RepoRefLog
|
||||
-> m ()
|
||||
insertFixmeAllowed reflog = do
|
||||
let o = hashObject @HbSync (serialise ("fixme-allowed", reflog)) & pretty & show
|
||||
let v = show $ pretty reflog
|
||||
withState $ transactional do
|
||||
insertOWKV (fromString o) mzero "$type" "fixme-allowed"
|
||||
insertOWKV (fromString o) mzero "value" v
|
||||
|
||||
deleteFixmeAllowed :: ( DashBoardPerks m
|
||||
, MonadReader DashBoardEnv m
|
||||
)
|
||||
=> m ()
|
||||
deleteFixmeAllowed = do
|
||||
|
||||
let sql = [qc|
|
||||
with
|
||||
s1 as (
|
||||
select o from object where k = '$type' and json_extract(v, '$') = 'fixme-allowed'
|
||||
)
|
||||
delete from object where o in (select o from s1)
|
||||
|]
|
||||
|
||||
withState $ S.insert_ sql
|
||||
|
||||
checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoLww
|
||||
-> m Bool
|
||||
|
||||
checkFixmeAllowed r = do
|
||||
|
||||
let sql = [qc|
|
||||
with
|
||||
s1 as (
|
||||
select o from object where k = '$type' and json_extract(v, '$') = 'fixme-allowed'
|
||||
)
|
||||
select 1
|
||||
from s1 join object o on s1.o = o.o
|
||||
where o.k = 'value' and json_extract(o.v, '$') = ?
|
||||
limit 1;
|
||||
|]
|
||||
|
||||
w <- withState $ select @(Only Int) sql (Only r)
|
||||
|
||||
pure $ not $ List.null w
|
||||
|
||||
selectRepoFixmeRefChan :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoLww
|
||||
-> m (Maybe MyRefChan)
|
||||
selectRepoFixmeRefChan r = do
|
||||
let sql = [qc|
|
||||
select refchan from (
|
||||
select lww
|
||||
, refchan
|
||||
, max(lwwseq)
|
||||
from repoheadfixme
|
||||
where lww = ?
|
||||
group by lww, refchan
|
||||
limit 1)
|
||||
|]
|
||||
|
||||
withState (select @(Only RefChanField) sql (Only r))
|
||||
<&> (fmap coerce . headMay)
|
||||
|
||||
rpcSocketKey :: String
|
||||
rpcSocketKey =
|
||||
hashObject @HbSync (serialise "rpc-socket-name") & pretty & show
|
||||
|
||||
rpcSocketFile :: MonadUnliftIO m => m FilePath
|
||||
rpcSocketFile = do
|
||||
dir <- liftIO $ getXdgDirectory XdgState hbs2_git_dashboard
|
||||
pure $ dir </> rpcSocketKey
|
||||
|
||||
setRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m ()
|
||||
setRPCSocket soname = do
|
||||
soFile <- rpcSocketFile
|
||||
touch soFile
|
||||
liftIO $ writeFile soFile soname
|
||||
|
||||
delRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
delRPCSocket = do
|
||||
rpcSocketFile >>= rm
|
||||
|
||||
getRPCSocket :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m (Maybe FilePath)
|
||||
getRPCSocket = do
|
||||
soFile <- rpcSocketFile
|
||||
liftIO $ try @_ @IOError (readFile soFile)
|
||||
<&> either (const Nothing) Just
|
||||
|
||||
|
|
@ -10,7 +10,7 @@ import HBS2.Git.DashBoard.Types
|
|||
import HBS2.Git.DashBoard.State.Index.Channels
|
||||
import HBS2.Git.DashBoard.State.Index.Peer
|
||||
|
||||
updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndex = do
|
||||
debug "updateIndex"
|
||||
updateIndexFromPeer
|
||||
|
|
@ -9,7 +9,7 @@ import DBPipe.SQLite.Generic as G
|
|||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
updateIndexFromChannels :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromChannels :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
|
||||
updateIndexFromChannels = do
|
||||
debug "updateIndexChannels"
|
||||
|
||||
|
|
@ -3,16 +3,45 @@ 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 System.Process.Typed
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
seconds = TimeoutSec
|
||||
|
||||
updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
||||
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"
|
||||
|
||||
|
|
@ -36,6 +65,7 @@ updateIndexFromPeer = do
|
|||
|
||||
lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk)
|
||||
|
||||
|
||||
for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do
|
||||
|
||||
mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk)
|
||||
|
|
@ -50,9 +80,11 @@ updateIndexFromPeer = do
|
|||
|
||||
Right hxs -> do
|
||||
for_ hxs $ \htx -> void $ runMaybeT do
|
||||
-- done <- liftIO $ withDB db (isTxProcessed (HashVal htx))
|
||||
-- done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx)))
|
||||
-- guard (not done && not done1)
|
||||
|
||||
done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
|
||||
|
||||
guard (not done)
|
||||
|
||||
getBlock sto (fromHashRef htx) >>= toMPlus
|
||||
<&> deserialiseOrFail @(RefLogUpdate L4Proto)
|
||||
>>= toMPlus
|
||||
|
|
@ -64,10 +96,29 @@ updateIndexFromPeer = 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
|
||||
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead)
|
||||
(man, _) <- parseManifest rhead
|
||||
let fme = headMay [ x | FixmeRefChanP x <- man ]
|
||||
lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead, fme)
|
||||
|
||||
withState $ transactional do
|
||||
for_ headz $ \(l, tx, rh, rhead) -> 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
|
||||
|
||||
-- buildCommitTreeIndex (coerce lw)
|
||||
|
||||
fxe <- selectRepoFixme
|
||||
|
||||
for_ fxe $ \(r,f) -> do
|
||||
allowed <- checkFixmeAllowed r
|
||||
when allowed do
|
||||
env <-ask
|
||||
addJob (withDashBoardEnv env $ updateFixmeFor r f)
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
{-# 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
|
||||
|
||||
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)
|
||||
, _dashBoardIndexIgnoreCaches :: TVar Bool
|
||||
}
|
||||
|
||||
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 False
|
||||
|
||||
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
|
||||
|
||||
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 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"
|
||||
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
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
|
||||
|
||||
|
||||
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 = 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_ (toURL (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_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))
|
||||
, hxTrigger_ "revealed"
|
||||
, hxSwap_ "afterend"
|
||||
] do
|
||||
td_ [colspan_ "3"] mempty
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
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_)
|
||||
|
||||
|
||||
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
|
||||
th_ $ strong_ (toHtml $ show $ pretty n)
|
||||
td_ (toHtml $ show $ pretty t)
|
||||
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
issuePage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoLww
|
||||
-> FixmeKey
|
||||
-> HtmlT m ()
|
||||
|
||||
issuePage repo@(RepoLww lww) f = 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_ [style_ "margin-bottom: 2em;"] do
|
||||
|
||||
div_ do
|
||||
small_ do
|
||||
a_ [ href_ (toURL (RepoPage IssuesTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft
|
||||
span_ [] "back to issues"
|
||||
|
||||
section_ do
|
||||
table_ do
|
||||
tr_ do
|
||||
td_ [colspan_ "2"] do
|
||||
let fkKey = coerce @_ @Text $ fixmeKey fxm
|
||||
strong_ [style_ "margin-right: 1ch;"] $ toHtml (coerce @_ @Text $ fixmeTag fxm)
|
||||
span_ [ style_ "margin-right: 1ch;"
|
||||
-- FIXME: make-underlined-on-hover
|
||||
-- $assigned fastpok
|
||||
, class_ "copyable-text"
|
||||
, onClickCopyText $ Text.take 10 fkKey
|
||||
] $ toHtml (H $ fixmeKey fxm)
|
||||
" "
|
||||
span_ [] $ toHtml (coerce @_ @Text $ fixmeTitle fxm)
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
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
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
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' = 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_ (toURL (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_ (toURL (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_ (toURL (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_ (toURL (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_ (toURL (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 ()
|
||||
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
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{..} = do
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
let url = toURL (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_ (toURL (RepoPage ManifestTab lww))] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLicense
|
||||
"Manifest"
|
||||
|
||||
for_ fixme $ \_ -> do
|
||||
li_ $ small_ do
|
||||
a_ [ class_ "secondary"
|
||||
, href_ (toURL (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_ (toURL (RepoPage ForksTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
toHtml $ show forksNum
|
||||
" forks"
|
||||
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toURL (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_ (toURL (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{..}
|
||||
|
||||
|
|
@ -0,0 +1,596 @@
|
|||
{-# 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' = 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_ (toURL (RepoFixmeHtmx mempty (RepoLww lww)))
|
||||
] mempty
|
||||
|
||||
div_ [id_ "repo-tab-data-embedded"] mempty
|
||||
|
||||
|
||||
repoPage tab lww params = 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_ (toURL (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_ (toURL (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_ (toURL (RepoCommits lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "commits"
|
||||
|
||||
menuTab (TreeTab Nothing)
|
||||
[ href_ "#"
|
||||
, hxGet_ (toURL (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 = 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 = toURL (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 :: 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_ (toURL (RepoTree lww co co))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, href_ "#"
|
||||
]
|
||||
|
||||
span_ [] $ a_ [ hxGet_ (toURL (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 = toURL (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 = 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 = toURL (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 = toURL $ 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 = toURL $ 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 = 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_ (toURL (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_ (toURL (RepoCommitSummaryQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "summary"
|
||||
|
||||
li_ $ a_ [ href_ "#"
|
||||
, hxGet_ (toURL (RepoCommitPatchQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "patch"
|
||||
|
||||
li_ $ a_ [ href_ (toURL (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 = 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_ (toURL (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' = 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_ (toURL (RepoCommitDefault lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, hxPushUrl_ (toURL 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_ (toURL 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{..} = 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
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,159 @@
|
|||
{-# 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 :: Monad m => HtmlT m ()
|
||||
myCss = do
|
||||
link_ [rel_ "stylesheet", href_ (path ["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!'
|
||||
|]
|
||||
|
||||
|
||||
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 :: 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_ (toURL RepoListPage)] $ strong_ "hbs2-git dashboard"
|
||||
|
||||
content
|
||||
|
||||
|
||||
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
||||
dashboardRootPage = 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 = toURL (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_ "text-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"
|
||||
|
||||
|
|
@ -0,0 +1,307 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
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
|
||||
|
||||
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 (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"
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,220 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-git-dashboard
|
||||
version: 0.24.1.2
|
||||
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
|
||||
, 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
|
||||
|
||||
|
||||
|
|
@ -1,408 +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.System.Dir
|
||||
import HBS2.OrDie
|
||||
import HBS2.Polling
|
||||
|
||||
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.Web.Html.Root
|
||||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
||||
import Lucid (renderTextT,HtmlT(..),toHtml)
|
||||
import Options.Applicative as O
|
||||
import Data.Either
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Lazy qualified as LT
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
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
|
||||
|
||||
|
||||
configParser :: DashBoardPerks m => Parser (m ())
|
||||
configParser = do
|
||||
opts <- RunDashBoardOpts <$> optional (strOption
|
||||
( long "config"
|
||||
<> short 'c'
|
||||
<> metavar "FILEPATH"
|
||||
<> help "Path to the configuration file"
|
||||
<> completer (bashCompleter "file")
|
||||
))
|
||||
|
||||
cmd <- subparser
|
||||
( command "web" (O.info pRunWeb (progDesc "Run the web interface"))
|
||||
<> command "index" (O.info pRunIndex (progDesc "update index"))
|
||||
)
|
||||
|
||||
pure $ cmd opts
|
||||
|
||||
|
||||
pRunWeb :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
|
||||
pRunWeb = pure $ \x -> runDashBoardM x runScotty
|
||||
|
||||
pRunIndex :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ())
|
||||
pRunIndex = pure $ \x -> runDashBoardM x do
|
||||
updateIndex
|
||||
|
||||
{- HLINT ignore "Eta reduce" -}
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
getRPC :: Monad m => HasConf m => m (Maybe FilePath)
|
||||
getRPC = pure Nothing
|
||||
|
||||
|
||||
runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a
|
||||
runDashBoardM cli m = do
|
||||
|
||||
|
||||
let hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||
xdgConf <- liftIO $ getXdgDirectory XdgConfig hbs2_git_dashboard
|
||||
xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
|
||||
|
||||
let cliConfPath = cli & configPath
|
||||
|
||||
let confPath = fromMaybe xdgConf cliConfPath
|
||||
let confFile = confPath </> "config"
|
||||
|
||||
let dbFile = xdgData </> "state.db"
|
||||
|
||||
when (isNothing cliConfPath) do
|
||||
touch confFile
|
||||
|
||||
conf <- runExceptT (liftIO $ readFile confFile)
|
||||
<&> fromRight mempty
|
||||
<&> parseTop
|
||||
<&> fromRight mempty
|
||||
|
||||
liftIO $ print (pretty conf)
|
||||
|
||||
-- FIXME: unix-socket-from-config
|
||||
soname <- detectRPC `orDie` "hbs2-peer rpc not found"
|
||||
|
||||
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
|
||||
conf
|
||||
dbFile
|
||||
peerAPI
|
||||
refLogAPI
|
||||
refChanAPI
|
||||
lwwAPI
|
||||
sto
|
||||
|
||||
void $ ContT $ withAsync do
|
||||
q <- withDashBoardEnv env $ asks _pipeline
|
||||
forever do
|
||||
liftIO (atomically $ readTQueue q) & liftIO . join
|
||||
|
||||
lift $ withDashBoardEnv env (withState evolveDB >> 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 wo = do
|
||||
middleware logStdout
|
||||
|
||||
let assets = _assetsOverride wo
|
||||
|
||||
case assets 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")
|
||||
|
||||
redirect (LT.fromStrict $ toURL (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)
|
||||
|
||||
item <- lift (selectRepoList ( mempty
|
||||
& set repoListByLww (Just lww)
|
||||
& set repoListLimit (Just 1))
|
||||
)
|
||||
<&> listToMaybe
|
||||
>>= orFall (status status404)
|
||||
|
||||
lift $ html =<< renderTextT (thisRepoManifest item)
|
||||
|
||||
|
||||
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 (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 <- lift (Scotty.header "Referer")
|
||||
>>= orFall (redirect $ LT.fromStrict $ toURL (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
|
||||
pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090
|
||||
wo <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions
|
||||
|
||||
env <- ask
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
void $ ContT $ withAsync updateIndexPeriodially
|
||||
|
||||
scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
|
||||
|
||||
updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
|
||||
updateIndexPeriodially = do
|
||||
|
||||
cached <- newTVarIO ( mempty :: HashMap MyRefLogKey HashRef )
|
||||
|
||||
changes <- newTQueueIO
|
||||
|
||||
api <- asks _refLogAPI
|
||||
|
||||
env <- ask
|
||||
|
||||
let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 30)
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
void $ ContT $ withAsync $ forever do
|
||||
rs <- atomically $ peekTQueue changes >> flushTQueue changes
|
||||
addJob (withDashBoardEnv env updateIndex)
|
||||
pause @'Seconds 30
|
||||
|
||||
lift do
|
||||
polling (Polling 1 10) 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
|
||||
|
||||
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
|
||||
|
||||
lift $ buildCommitTreeIndex (coerce lww)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
execParser opts & join
|
||||
where
|
||||
opts = O.info (configParser <**> helper)
|
||||
( fullDesc
|
||||
<> progDesc "hbs2-git-dashboard"
|
||||
<> O.header "hbs2-git-dashboard" )
|
||||
|
||||
|
||||
|
|
@ -1,107 +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
|
||||
|
||||
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
|
||||
, _dashBoardConf :: TVar [Syntax C]
|
||||
, _db :: DBPipeEnv
|
||||
, _dataDir :: FilePath
|
||||
, _pipeline :: TQueue (IO ())
|
||||
}
|
||||
|
||||
makeLenses 'DashBoardEnv
|
||||
|
||||
repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath
|
||||
repoDataPath lw = asks _dataDir <&> (</> (show $ pretty lw)) >>= 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
|
||||
)
|
||||
|
||||
instance (MonadIO m, Monad m, MonadReader DashBoardEnv m) => HasConf m where
|
||||
getConf = do
|
||||
asks _dashBoardConf >>= readTVarIO
|
||||
|
||||
newDashBoardEnv :: MonadIO m
|
||||
=> [Syntax C]
|
||||
-> FilePath
|
||||
-> ServiceCaller PeerAPI UNIX
|
||||
-> ServiceCaller RefLogAPI UNIX
|
||||
-> ServiceCaller RefChanAPI UNIX
|
||||
-> ServiceCaller LWWRefAPI UNIX
|
||||
-> AnyStorage
|
||||
-> m DashBoardEnv
|
||||
newDashBoardEnv cfg dbFile peer rlog rchan lww sto = do
|
||||
let ddir = takeDirectory dbFile
|
||||
DashBoardEnv peer rlog rchan lww sto
|
||||
<$> newTVarIO cfg
|
||||
<*> newDBPipeEnv dbPipeOptsDef dbFile
|
||||
<*> pure ddir
|
||||
<*> newTQueueIO
|
||||
|
||||
withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
|
||||
withDashBoardEnv env m = runReaderT (fromDashBoardM m) env
|
||||
|
||||
withState :: (MonadIO m, MonadReader DashBoardEnv m) => DBPipeM m a -> m a
|
||||
withState f = do
|
||||
asks _db >>= flip withDB f
|
||||
|
||||
|
||||
addJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => IO () -> m ()
|
||||
addJob f = do
|
||||
q <- asks _pipeline
|
||||
atomically $ writeTQueue q f
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -59,6 +59,7 @@ common shared-properties
|
|||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
, aeson
|
||||
, attoparsec
|
||||
, atomic-write
|
||||
, bytestring
|
||||
|
|
@ -126,66 +127,6 @@ library
|
|||
hs-source-dirs: hbs2-git-client-lib
|
||||
|
||||
|
||||
library hbs2-git-dashboard-assets
|
||||
import: shared-properties
|
||||
|
||||
build-depends:
|
||||
base, file-embed, lucid, text
|
||||
|
||||
exposed-modules:
|
||||
HBS2.Git.Web.Assets
|
||||
|
||||
hs-source-dirs: hbs2-git-dashboard-assets
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
executable hbs2-git-dashboard
|
||||
import: shared-properties
|
||||
main-is: GitDashBoard.hs
|
||||
|
||||
other-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.Web.Html.Root
|
||||
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git-dashboard-assets, hbs2-peer, hbs2-git, suckless-conf
|
||||
, fuzzy-parse
|
||||
, binary
|
||||
, generic-deriving
|
||||
, generic-data
|
||||
, deriving-compat
|
||||
, vector
|
||||
, optparse-applicative
|
||||
, http-types
|
||||
, file-embed
|
||||
, network-uri
|
||||
, wai
|
||||
, wai-extra
|
||||
, wai-middleware-static
|
||||
, wai-middleware-static-embedded
|
||||
, lucid
|
||||
, lucid-htmx
|
||||
, pandoc
|
||||
, skylighting
|
||||
, skylighting-core
|
||||
, skylighting-lucid
|
||||
, scotty >= 0.21
|
||||
|
||||
hs-source-dirs:
|
||||
hbs2-git-dashboard
|
||||
hbs2-git-dashboard/src
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
executable hbs2-git-subscribe
|
||||
import: shared-properties
|
||||
main-is: Main.hs
|
||||
|
|
|
|||
|
|
@ -52,11 +52,13 @@ newtype LWWRefKey s =
|
|||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
instance RefMetaData (LWWRefKey s)
|
||||
|
||||
deriving stock instance IsRefPubKey s => Eq (LWWRefKey s)
|
||||
|
||||
instance IsRefPubKey s => Ord (LWWRefKey s) where
|
||||
compare a b = compare (serialise a) (serialise b)
|
||||
|
||||
instance IsRefPubKey e => Serialise (LWWRefKey e)
|
||||
|
||||
instance IsRefPubKey s => Hashable (LWWRefKey s) where
|
||||
|
|
|
|||
Loading…
Reference in New Issue