From 86fcde758b33618ad9441919126c55ce49b78ca9 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 3 Oct 2024 06:15:03 +0300 Subject: [PATCH] hbs2-git-dashboard updated; status - wip --- LICENSE | 31 + docs/todo/fixme-new-web.txt | 30 + docs/todo/hbs2-git-dashboard.txt | 34 + docs/todo/hbs2-peer.txt | 39 + fixme-new/app/FixmeMain.hs | 65 - fixme-new/lib/Fixme/Config.hs | 14 +- fixme-new/lib/Fixme/GK.hs | 2 +- fixme-new/lib/Fixme/Run.hs | 22 +- fixme-new/lib/Fixme/Run/Internal.hs | 12 +- fixme-new/lib/Fixme/State.hs | 157 ++- fixme-new/lib/Fixme/Types.hs | 36 +- flake.lock | 8 +- flake.nix | 24 +- hbs2-core/hbs2-core.cabal | 2 +- hbs2-git-dashboard/app/GitDashBoard.hs | 756 ++++++++++++ .../HBS2/Git/Web/Assets.hs | 24 +- .../assets/css/custom.css | 33 +- .../assets/css/pico.min.css | 0 .../HBS2/Git/DashBoard/Fixme.hs | 142 +++ .../HBS2/Git/DashBoard/Manifest.hs | 55 + .../HBS2/Git/DashBoard/Prelude.hs | 3 + .../HBS2/Git/DashBoard/State.hs | 474 ++++++-- .../HBS2/Git/DashBoard/State/Commits.hs | 0 .../HBS2/Git/DashBoard/State/Index.hs | 2 +- .../Git/DashBoard/State/Index/Channels.hs | 2 +- .../HBS2/Git/DashBoard/State/Index/Peer.hs | 63 +- .../HBS2/Git/DashBoard/Types.hs | 161 +++ .../HBS2/Git/Web/Html/Fixme.hs | 97 ++ .../HBS2/Git/Web/Html/Issue.hs | 150 +++ .../HBS2/Git/Web/Html/Markdown.hs | 24 + .../HBS2/Git/Web/Html/Parts/Blob.hs | 79 ++ .../HBS2/Git/Web/Html/Parts/Issues/Sidebar.hs | 106 ++ .../HBS2/Git/Web/Html/Parts/TopInfoBlock.hs | 153 +++ .../HBS2/Git/Web/Html/Repo.hs | 596 +++++++++ .../HBS2/Git/Web/Html/Root.hs | 159 +++ .../HBS2/Git/Web/Html/Types.hs | 307 +++++ hbs2-git-dashboard/hbs2-git-dashboard.cabal | 220 ++++ hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 408 ------- .../src/HBS2/Git/DashBoard/Types.hs | 107 -- .../src/HBS2/Git/Web/Html/Root.hs | 1075 ----------------- hbs2-git/hbs2-git.cabal | 61 +- hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs | 4 +- 42 files changed, 3829 insertions(+), 1908 deletions(-) create mode 100644 LICENSE create mode 100644 docs/todo/fixme-new-web.txt create mode 100644 docs/todo/hbs2-git-dashboard.txt create mode 100644 docs/todo/hbs2-peer.txt create mode 100644 hbs2-git-dashboard/app/GitDashBoard.hs rename {hbs2-git => hbs2-git-dashboard}/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs (96%) rename {hbs2-git => hbs2-git-dashboard}/hbs2-git-dashboard-assets/assets/css/custom.css (95%) rename {hbs2-git => hbs2-git-dashboard}/hbs2-git-dashboard-assets/assets/css/pico.min.css (100%) create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Manifest.hs rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/Prelude.hs (94%) rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/State.hs (65%) rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/State/Commits.hs (100%) rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/State/Index.hs (84%) rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/State/Index/Channels.hs (96%) rename {hbs2-git/hbs2-git-dashboard/src => hbs2-git-dashboard/hbs2-git-dashboard-core}/HBS2/Git/DashBoard/State/Index/Peer.hs (59%) create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Markdown.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Issues/Sidebar.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/TopInfoBlock.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Types.hs create mode 100644 hbs2-git-dashboard/hbs2-git-dashboard.cabal delete mode 100644 hbs2-git/hbs2-git-dashboard/GitDashBoard.hs delete mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs delete mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..5126b98a --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/docs/todo/fixme-new-web.txt b/docs/todo/fixme-new-web.txt new file mode 100644 index 00000000..1b812653 --- /dev/null +++ b/docs/todo/fixme-new-web.txt @@ -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 в индексе. + diff --git a/docs/todo/hbs2-git-dashboard.txt b/docs/todo/hbs2-git-dashboard.txt new file mode 100644 index 00000000..2064c405 --- /dev/null +++ b/docs/todo/hbs2-git-dashboard.txt @@ -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. + + + diff --git a/docs/todo/hbs2-peer.txt b/docs/todo/hbs2-peer.txt new file mode 100644 index 00000000..72d56135 --- /dev/null +++ b/docs/todo/hbs2-peer.txt @@ -0,0 +1,39 @@ +TODO: ASAP-bloom-filter-of-blocks + + Каждый пир поддерживает фильтр Блума для блоков и раздаёт этот фильтр по + протоколу. + + Протокол подразумевает как отдачу всего фильтра целиком ( тут подходит + держать его в LWWRef) + + Так и просто запросы к нему. + + Запрос должен пролезать в UDP, таким образом, выглядит так, что это + список чисел с номерами бит, т.е в худшем случае (8 байт на число) + один запрос это проверка 128 блоков за раз. Поскольку CBOR у нас + кодирует числа с переменной длиной, можно ожидать, что в среднем + будет получше. + + Это ускорит, возможно, на порядок поиск блоков, который тем хуже, + чем больше в системе пиров. + + Открытые вопросы: + + - Параметры фильтра Блума? Зашитые в систему, или зависящие от + пира (и тогда мы пересчитываем их) + + - Надо ли качать фильтры целиком (кажется, что нет, но можно + запоминать/обновлять для каждого пира, и время от времени + чистить) + + - Если параметры фильтра могут меняться для пира, как + согласовывать хэш функции? Если их зашивать и менять только + коэффициенты, то не слишком ли плохие будут хэш функции? + + - Какие атаки может вызвать? + + - Как эффективно хранить? + + + + diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs index cdcce401..a99f1abc 100644 --- a/fixme-new/app/FixmeMain.hs +++ b/fixme-new/app/FixmeMain.hs @@ -1,73 +1,8 @@ module Main where -import Fixme --- import Fixme.Run import Fixme.Run -import System.Environment - --- TODO: fixme-new --- $author: Dmitry Zuikov --- $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 --- --- Тестовый тикет с параметрами - diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index bbae5f67..82205acb 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -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) diff --git a/fixme-new/lib/Fixme/GK.hs b/fixme-new/lib/Fixme/GK.hs index 58baf1f9..aa7e05aa 100644 --- a/fixme-new/lib/Fixme/GK.hs +++ b/fixme-new/lib/Fixme/GK.hs @@ -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" diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 7ca139d8..a195ec49 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -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 diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 684fa0d4..49239352 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -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 -> diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 737ce8b4..3b7d20a3 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -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 diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 6c507343..a8dc5c81 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -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)))) diff --git a/flake.lock b/flake.lock index 777ca7b7..e324acc9 100644 --- a/flake.lock +++ b/flake.lock @@ -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" }, diff --git a/flake.nix b/flake.nix index df5dd018..f2255341 100644 --- a/flake.nix +++ b/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; { diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 680caf41..fd8ee74e 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -178,7 +178,7 @@ library , resourcet , safe , safe-exceptions - , saltine ^>=0.2.0.1 + , saltine >=0.2.0.1 , serialise , sockaddr , split diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs new file mode 100644 index 00000000..1ffaf284 --- /dev/null +++ b/hbs2-git-dashboard/app/GitDashBoard.hs @@ -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 + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs b/hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs similarity index 96% rename from hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs index d1b51804..6fa86812 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs @@ -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| |] + + +svgIconText IconFixme = [qc| + + + + + + +|] + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css similarity index 95% rename from hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css rename to hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css index 049d23c4..b7d9278a 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css @@ -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; } diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/pico.min.css b/hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/pico.min.css similarity index 100% rename from hbs2-git/hbs2-git-dashboard-assets/assets/css/pico.min.css rename to hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/pico.min.css diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs new file mode 100644 index 00000000..e8c02fa9 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Fixme.hs @@ -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 + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Manifest.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Manifest.hs new file mode 100644 index 00000000..45fb8fd5 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Manifest.hs @@ -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) + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Prelude.hs similarity index 94% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Prelude.hs index f845d206..80d4cca5 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Prelude.hs @@ -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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs similarity index 65% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index b72b30a7..3d24d6f4 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs @@ -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 + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Commits.hs similarity index 100% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Commits.hs diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index.hs similarity index 84% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index.hs index 183c30cd..757c3236 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index.hs @@ -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 diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Channels.hs similarity index 96% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Channels.hs index ba7fd839..5766bcf9 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Channels.hs @@ -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" diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs similarity index 59% rename from hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs rename to hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs index c30d8eb6..d9644e48 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -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) + + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs new file mode 100644 index 00000000..ab4ed417 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/Types.hs @@ -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" + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs new file mode 100644 index 00000000..c503afca --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Fixme.hs @@ -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 + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs new file mode 100644 index 00000000..bff792e0 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Issue.hs @@ -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 + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Markdown.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Markdown.hs new file mode 100644 index 00000000..f3bf7e49 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Markdown.hs @@ -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 diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs new file mode 100644 index 00000000..cd74ac3b --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Blob.hs @@ -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 + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Issues/Sidebar.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Issues/Sidebar.hs new file mode 100644 index 00000000..69671bbe --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/Issues/Sidebar.hs @@ -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 () + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/TopInfoBlock.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/TopInfoBlock.hs new file mode 100644 index 00000000..dde9e5a6 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Parts/TopInfoBlock.hs @@ -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{..} + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs new file mode 100644 index 00000000..af38636e --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Repo.hs @@ -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 + + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs new file mode 100644 index 00000000..8c00e411 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Root.hs @@ -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" + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Types.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Types.hs new file mode 100644 index 00000000..00b40dcd --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/Web/Html/Types.hs @@ -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" + + diff --git a/hbs2-git-dashboard/hbs2-git-dashboard.cabal b/hbs2-git-dashboard/hbs2-git-dashboard.cabal new file mode 100644 index 00000000..212f4492 --- /dev/null +++ b/hbs2-git-dashboard/hbs2-git-dashboard.cabal @@ -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 + + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs deleted file mode 100644 index d2851eb0..00000000 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ /dev/null @@ -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" ) - - diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs deleted file mode 100644 index fb6d2117..00000000 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs deleted file mode 100644 index c0cbe5c0..00000000 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ /dev/null @@ -1,1075 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language PatternSynonyms #-} -{-# Language ViewPatterns #-} -{-# Language MultiWayIf #-} -module HBS2.Git.Web.Html.Root where - -import HBS2.Git.DashBoard.Prelude -import HBS2.Git.DashBoard.Types -import HBS2.Git.DashBoard.State -import HBS2.Git.DashBoard.State.Commits - -import HBS2.OrDie - -import HBS2.Git.Data.Tx.Git -import HBS2.Git.Data.RepoHead -import HBS2.Git.Web.Assets - --- import Data.Text.Fuzzy.Tokenize as Fuzz - -import Data.ByteString.Lazy qualified as LBS -import Data.Text qualified as Text -import Data.Text.Encoding 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 Control.Applicative -import Text.Pandoc hiding (getPOSIXTime) -import System.FilePath -import Data.Word -import Data.Either -import Data.List qualified as List -import Data.List (sortOn) - -import Web.Scotty.Trans as Scotty - -import Data.Kind - -import Streaming.Prelude qualified as S - -import Network.HTTP.Types.Status - -rootPath :: [String] -> [String] -rootPath = ("/":) - -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) - | ForksTab - 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 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 - -isActiveTab :: RepoPageTabs -> RepoPageTabs -> Bool -isActiveTab a b = case (a,b) of - (CommitsTab{},CommitsTab{}) -> True - (ManifestTab{},ManifestTab{}) -> True - (TreeTab{},TreeTab{}) -> True - _ -> False - -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" - -instance FromStringMaybe RepoPageTabs where - fromStringMay = \case - "commits" -> pure (CommitsTab Nothing) - "manifest" -> pure ManifestTab - "tree" -> pure (TreeTab Nothing) - "forks" -> pure ForksTab - _ -> 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 - pred_ = case s of - CommitsTab (Just p) -> Text.pack $ "?ref=" <> show (pretty p) - TreeTab (Just p) -> Text.pack $ "?tree=" <> show (pretty p) - _ -> 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 (RepoForksHtmx String) where - routePattern (RepoForksHtmx r) = - path ["/", "htmx", "forks", toArg r] & toPattern - -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' -|] - -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 - -instance ToHtml RepoBrief where - toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) - toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) - -data WithTime a = WithTime Integer a - -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" - - -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-peer 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" - -parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text) -parsedManifest RepoListItem{..} = do - - sto <- asks _sto - mhead <- readRepoHeadFromTx sto (coerce rlRepoTx) - - let rawManifest = (_repoManifest . snd =<< mhead) - & fromMaybe (coerce rlRepoBrief) - & Text.lines - - 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) - - -thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () -thisRepoManifest it@RepoListItem{..} = do - (_, manifest) <- lift $ parsedManifest it - toHtmlRaw (renderMarkdown' manifest) - -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 - - 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 - -doRenderBlob fallback 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 - - toHtmlRaw (renderMarkdown' txt) - - _ -> do - - txt <- lift (readBlob lww blobHash) - <&> LBS.toStrict - <&> Text.decodeUtf8 - - 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 - -raiseStatus :: forall m . MonadIO m => Status -> Text -> m () -raiseStatus s t = throwIO (StatusError s t) - -itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s) - -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)) - - -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 - -repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) - => RepoPageTabs - -> LWWRefKey 'HBS2Basic - -> [(Text,Text)] - -> HtmlT m () -repoPage tab lww params = rootPage do - - it@RepoListItem{..} <- lift (selectRepoList ( mempty - & set repoListByLww (Just lww) - & set repoListLimit (Just 1)) - <&> listToMaybe - ) >>= orThrow (itemNotFound lww) - - sto <- asks _sto - mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) - - let mbHead = snd <$> mhead - - (meta, manifest) <- lift $ 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 - - debug $ red "META" <+> pretty meta - - main_ [class_ "container-fluid"] do - div_ [class_ "wrapper"] do - aside_ [class_ "sidebar"] do - - div_ [class_ "info-block" ] do - toHtml (ShortRef lww) - - -- div_ [class_ "info-block" ] do - -- a_ [ href_ "/"] do - -- span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft - -- "back to projects" - - 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" - - when (rlRepoForks > 0) do - li_ $ small_ do - a_ [class_ "secondary" - , href_ "#" - , hxGet_ (toURL (RepoForksHtmx lww)) - , hxTarget_ "#repo-tab-data" - ] do - span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork - toHtml $ show rlRepoForks - " forks" - - li_ $ small_ do - a_ [class_ "secondary" - , href_ (toURL (RepoPage (CommitsTab Nothing) lww)) - ] do - span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit - toHtml $ show rlRepoCommits - " commits" - - for_ pinned $ \(_,ref) -> do - case ref of - PinnedRefBlob s n hash -> small_ do - li_ $ a_ [class_ "secondary" - , href_ "#" - , hxGet_ (toURL (RepoSomeBlob lww s hash)) - , hxTarget_ "#repo-tab-data" - ] do - span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned - toHtml (Text.take 12 n) - " " - toHtml $ ShortRef hash - - for_ mbHead $ \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 rlRepoName - - 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 - thisRepoManifest it - - CommitsTab{} -> do - let predicate = Right (fromQueryParams params) - repoCommits lww predicate - - ForksTab -> do - repoForks lww - - div_ [id_ "repo-tab-data-embedded"] mempty diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 5a68f0f7..f954e81e 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index f9914c68..cd7fe769 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.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