hbs2-git-dashboard updated; status - wip

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.
+

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 в индексе.
+

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.
+
+
+

docs/todo/hbs2-peer.txt

@@ -0,0 +1,39 @@
+TODO: ASAP-bloom-filter-of-blocks
+
+  Каждый пир поддерживает фильтр Блума для блоков и раздаёт этот фильтр по
+  протоколу.
+
+  Протокол подразумевает как отдачу всего фильтра целиком ( тут подходит
+  держать его в LWWRef)
+
+  Так и просто запросы к нему.
+
+  Запрос должен пролезать в UDP, таким образом, выглядит так, что это
+  список чисел с номерами бит, т.е в худшем случае (8 байт на число)
+  один запрос это проверка 128 блоков за раз. Поскольку CBOR у нас
+  кодирует числа с переменной длиной, можно ожидать, что в среднем
+  будет получше.
+
+  Это ускорит, возможно, на порядок поиск блоков, который тем хуже,
+  чем больше в системе пиров.
+
+  Открытые вопросы:
+
+  - Параметры фильтра Блума? Зашитые в систему, или зависящие от
+    пира (и тогда мы пересчитываем их)
+
+  - Надо ли качать фильтры целиком (кажется, что нет, но можно
+    запоминать/обновлять для каждого пира, и время от времени
+    чистить)
+
+  - Если параметры фильтра могут меняться для пира, как
+    согласовывать хэш функции? Если их зашивать и менять только
+    коэффициенты, то не слишком ли плохие будут хэш функции?
+
+  - Какие атаки может вызвать?
+
+  - Как эффективно хранить?
+
+
+
+

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 <dzuikov@gmail.com>
---   $milestone: undefined
---   $priority: ASAP
---  после майских:
---  1.  fixme переезжает в дерево hbs2, конкретно в hbs2-git
-
---  2.  fixme преобразуется в утилиту для генерации отчётов по репозиторию git
---
---  3.  fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme
---
---  4.  fixme начинает генерировать PR-ы в формате git (у гита есть простенькие пулл-реквесты!)
---      и умеет постить их куда там их следует постить
---
---  5.  fixme получает ограничитель глубины сканирования и фильтр бранчей,
---      что бы не окочуриваться на больших проектах
---
---  6.  fixme генерирует настройки по умолчанию, включая .gitignore
---
---  7.  fixme позволяет явно задавать лог изменений статуса, беря его как из
---      .fixme/log так и откуда скажут
---
---  8.  fixme интегрируется в hbs2-git-dashboard
---
---  9.  fixme временно получает название fixme2 или nfixme или hfixme (не решил пока),
---      потом возвращается к старому названию
---
---  10. fixme умеет постить записи в своём формате в hbs2 или же умеет любые источники дампить в своём формате так,
---        что бы hbs2-git мог запостить их в соответствующий рефчан
---
---  11. fixme оформляет либу для экстракции фактов из git, которую будет использовать и hbs2-git-dashboard
---
---  12. hbs2-git-dashboard понимает и уважает каталог настроек .fixme , а стейт берёт прямо оттуда
-
---  открытые вопросы:
-
---  hbs2-git использует fixme или fixme использует hbs2
-
---  переводить fixme на fuzzy-parse или нет (скорее, да)
-
---  переводить ли suckless-conf на fuzzy-parse сейчас (или хрен пока с ним)
-
---  встроить ли jq внутрь или лучше дать доступ к sql запросам по json
 
 main :: IO ()
 main = do
-
-  -- TODO: discover-config
-  --
-  -- TODO: local-config-has-same-name-with-binary
-  --
-  -- TODO: per-user-config-has-same-name-with-binary
-  --
-  -- TODO: per-user-config-added-after-per-project-config
-
-  -- TODO: scan-all-sources
-  --   for-source-from-con
-
   runFixmeCLI runCLI
 
--- FIXME: test-fixme
---   $workflow: wip
---   $assigned: voidlizard
---
---   Тестовый тикет с параметрами
-

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 :: (FixmePerks m, MonadReader FixmeEnv m) => m FilePath
-fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
+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)
 

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"

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
 

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
+  dbPath <- localDBPath
-  liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
+  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 ->

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, '$.commit-time') {o} nulls last,
-        json_extract(s1.blob, '$.w') asc 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

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))))

flake.lock

@@ -26,11 +26,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1727252661,
+        "lastModified": 1727503203,
-        "narHash": "sha256-8vmgF0Atw+m7a+2Wmlnwjjyw8nSYv0QMT+zN9R3DljQ=",
+        "narHash": "sha256-/HVVyxa55pDLzMiRgCWB4YKVsW2v9wFHTlSpLnyuhkU=",
         "ref": "refs/heads/master",
-        "rev": "8b614540a7f30f0227cb18ef2ad4c8d84db4a75c",
+        "rev": "7f28fdcb2ba9ccd426facffebf100e98522d7eac",
-        "revCount": 9,
+        "revCount": 11,
         "type": "git",
         "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
       },

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"
@@ -79,6 +80,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-keyman"            = "./hbs2-keyman/hbs2-keyman";
      "hbs2-keyman-direct-lib" = "./hbs2-keyman/hbs2-keyman-direct-lib";
      "hbs2-git"               = "./hbs2-git";
+     "hbs2-git-dashboard"     = "./hbs2-git-dashboard";
      "hbs2-fixer"             = "./hbs2-fixer";
      "hbs2-cli"               = "./hbs2-cli";
      "hbs2-sync"              = "./hbs2-sync";

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

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
+
+

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|<svg xmlns="http://www.w3.org/2000/svg" class="icon
   <path d="M12 16l0 5" />
   <path d="M8 4l8 0" />
 </svg>|]
+
+
+svgIconText IconFixme = [qc|
+<svg  xmlns="http://www.w3.org/2000/svg"
+      width="24"
+      height="24"
+      viewBox="0 0 24 24"
+      fill="none"
+      stroke="currentColor"
+      stroke-width="2"
+      stroke-linecap="round"
+      stroke-linejoin="round"
+      class="icon icon-tabler icons-tabler-outline icon-tabler-stack-3">
+      <path stroke="none" d="M0 0h24v24H0z" fill="none"/>
+      <path d="M12 2l-8 4l8 4l8 -4l-8 -4" />
+      <path d="M4 10l8 4l8 -4" />
+      <path d="M4 18l8 4l8 -4" />
+      <path d="M4 14l8 4l8 -4" />
+</svg>|]
+
+

hbs2-git-dashboard/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -35,6 +35,11 @@ header>nav {
   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; }

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
+

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)
+
+

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

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 stock (Generic,Ord,Eq)
-                  deriving newtype (ToField,FromField,Pretty)
+                  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 mempty
-  pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ]
+  -- 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,28 +758,8 @@ readBlob repo hash = do
     <&> fromRight mempty
 
 
-buildCommitTreeIndex :: ( MonadUnliftIO m
+updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
-                        , DashBoardPerks m
+updateForks lww = withState do
-                        , MonadReader DashBoardEnv m
-                        )
-                     => LWWRefKey 'HBS2Basic
-                     -> m ()
-buildCommitTreeIndex lww = do
-
-  commits <- listCommits
-  env <- ask
-
-  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)
@@ -728,42 +772,30 @@ buildCommitTreeIndex lww = do
 
   pure ()
 
-    updateRepoData env co  = do
+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
 
-      root <- getRootTree co >>= toMPlus
+listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
-      (trees, blobs) <- getTreeRecursive co
+            => LWWRefKey HBS2Basic -> m [GitHash]
-
+listCommits lww = do
-      lift $ addJob $ liftIO $ withDashBoardEnv env do
+  dir <- repoDataPath lww
-
+  gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
-        withState $ transactional do
+            <&> fromRight mempty
-
+            <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
-          insert @RepoCommitTable $
+            <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
-            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
+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
@@ -791,7 +823,9 @@ buildCommitTreeIndex lww = do
   let blobs = [ (k,v) | ([k],Left v) <- items ]
   pure (trees, blobs)
 
-    getRootTree co = lift do
+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}|]
 
@@ -802,16 +836,84 @@ buildCommitTreeIndex lww = do
            (TreeHash ha : _) -> Just ha
            _                 -> Nothing
 
-    checkCommitProcessed co = lift $ withState do
+updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
-      select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
+               => LWWRefKey HBS2Basic -> GitHash -> m ()
-        <&> listToMaybe @(Only Int) <&> isJust
+updateRepoData lww co  = do
 
-    listCommits = do
+  env <- ask
-      dir <- repoDataPath lww
+
-      gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
+  void $ runMaybeT do
-                <&> fromRight mempty
+
-                <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
+    root <- lift (getRootTree lww co) >>= toMPlus
-                <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
+    (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
+                        )
+                     => LWWRefKey 'HBS2Basic
+                     -> m ()
+buildCommitTreeIndex lww = do
+
+  commits <- listCommits lww
+  env <- ask
+
+  ignoreCaches <- getIgnoreCaches
+
+  for_ commits $ \co -> void $ runMaybeT do
+    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
+

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

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"
 

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)))
+                      done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
-                      -- guard (not done && not done1)
+
+                      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)
+
+
+

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"
+

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
+
+

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
+
+

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

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
+
+

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 ()
+

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{..}
+

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
+
+
+

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"
+

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"
+
+

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
+
+

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -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" )
-
-

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs

@@ -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
-

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

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