diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob-filled.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob-filled.svg new file mode 100644 index 00000000..ee6095d6 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/blob-filled.svg @@ -0,0 +1,8 @@ + + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/gear.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/gear.svg new file mode 100644 index 00000000..8c2174da --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/gear.svg @@ -0,0 +1,8 @@ + + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/haskell.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/haskell.svg new file mode 100644 index 00000000..c6a33c2f --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/haskell.svg @@ -0,0 +1,3 @@ + +Haskell + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/javascript.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/javascript.svg new file mode 100644 index 00000000..7b4c84f0 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/javascript.svg @@ -0,0 +1,8 @@ + +JavaScript + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/markdown.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/markdown.svg new file mode 100644 index 00000000..fdeedea8 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/markdown.svg @@ -0,0 +1,7 @@ + +Markdown + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/nixos.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/nixos.svg new file mode 100644 index 00000000..2fd29281 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/nixos.svg @@ -0,0 +1,8 @@ + + NixOS + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/python.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/python.svg new file mode 100644 index 00000000..3399c587 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/python.svg @@ -0,0 +1,4 @@ + +Python + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/sql.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/sql.svg new file mode 100644 index 00000000..63f4ae77 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/sql.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/terminal.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/terminal.svg new file mode 100644 index 00000000..85865a80 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/terminal.svg @@ -0,0 +1,9 @@ + + + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg index cd87bb8e..b23bfa0f 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/tree-up.svg @@ -1,4 +1,15 @@ - + - + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/yaml.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/yaml.svg new file mode 100644 index 00000000..8807a356 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/yaml.svg @@ -0,0 +1,7 @@ + +YAML + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index d87badc6..09b33cc3 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -232,10 +232,9 @@ runDashboardWeb wo = do hash <- hash' & orFall (status status404) co <- co' & orFall (status status404) tree <- lift $ gitShowTree lww hash - back <- lift $ selectParentTree co hash + back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash) debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back - lift $ html =<< renderTextT (repoTree lww co hash tree back) - + lift $ html =<< renderTextT (repoTree lww co hash tree (coerce <$> back)) repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath repoDataPath lw = asks _dataDir <&> ( (show $ pretty lw)) >>= canonicalizePath diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index a6d37924..ffad1f7b 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -443,9 +443,11 @@ createRepoTreeIndexTable = do ddl [qc| create table if not exists tree ( parent text not null - , child text not null + , tree text not null , kommit text not null - , primary key (parent,child,kommit) + , level int not null + , path text not null + , primary key (parent,tree,kommit) ) |] @@ -463,23 +465,42 @@ insertProcessed href = do on conflict(hash) do nothing |] (Only href) -insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> GitHash -> DBPipeM m () -insertTree commit parent child = do + +newtype TreeCommit = TreeCommit GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype TreeParent = TreeParent GitHash + deriving newtype (FromField,ToField,Pretty) + + +newtype TreeTree = TreeTree GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype TreeLevel = TreeLevel Int + deriving newtype (FromField,ToField,Pretty,Num,Enum) + +newtype TreePath = TreePath FilePath + deriving newtype (FromField,ToField,Pretty) + +insertTree :: (DashBoardPerks m) + => (TreeCommit,TreeParent,TreeTree,TreeLevel,TreePath) + -> DBPipeM m () +insertTree (commit,parent,tree,level,path) = do S.insert [qc| - insert into tree (parent,child,kommit) - values (?,?,?) - on conflict (parent,child,kommit) do nothing - |] (parent,child,commit) + insert into tree (parent,tree,kommit,level,path) + values (?,?,?,?,?) + on conflict (parent,tree,kommit) + do update set level = excluded.level + , path = excluded.path + |] (parent,tree,commit,level,path) -selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => GitHash -> GitHash -> m (Maybe GitHash) +selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => TreeCommit + -> TreeTree + -> m (Maybe TreeParent) selectParentTree co me = withState do - w <- select [qc|select coalesce(parent,kommit) from tree where child = ? and kommit = ?|] (me,co) - <&> listToMaybe . fmap fromOnly - - if co == me then - pure Nothing - else do - pure $ w <|> Just co + select [qc|select parent from tree where tree = ? and kommit = ?|] (me,co) + <&> listToMaybe . fmap fromOnly {- HLINT ignore "Functor law" -} @@ -530,7 +551,7 @@ buildCommitTreeIndex dir = do for_ (Map.toList trees) $ \(t,h0) -> do case t of - [_] -> insertTree co root h0 + [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) _ -> pure () let child = tailSafe t @@ -539,7 +560,13 @@ buildCommitTreeIndex dir = do for_ parent $ \p -> do debug $ red "FOUND SHIT:" <+> pretty (h0,p) - insertTree co p h0 + insertTree ( TreeCommit co + , TreeParent p + , TreeTree h0 + , TreeLevel (length t) + , TreePath (headDef "" t) + ) + -- insertTree co p h0 insertProcessed hkey diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs index fe59f6b7..e09167ae 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs @@ -23,6 +23,8 @@ import Safe import Data.List (sortOn) import Data.Ord (comparing, Down(..)) +import Skylighting.Core qualified as Sky +import Skylighting qualified as Sky import Streaming.Prelude qualified as S @@ -223,6 +225,8 @@ repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) repoTree lww co root tree back' = do + let syntaxMap = Sky.defaultSyntaxMap + let co_ = show $ pretty co let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree @@ -249,9 +253,26 @@ repoTree lww co root tree back' = do let uri = path [ "repo", show $ pretty lww, "tree", co_, hash_ ] tr_ mempty do td_ $ case tp of - Blob -> img_ [src_ "/icon/blob.svg"] - Tree -> img_ [src_ "/icon/tree.svg"] - _ -> mempty + Commit -> mempty + Tree -> img_ [src_ "/icon/tree.svg"] + Blob -> do + let syn = Sky.syntaxesByFilename syntaxMap (Text.unpack name) + & headMay + <&> Text.toLower . Sky.sName + + let icon = case syn of + Just "haskell" -> [src_ "/icon/haskell.svg"] + Just "markdown" -> [src_ "/icon/markdown.svg"] + Just "nix" -> [src_ "/icon/nixos.svg"] + Just "bash" -> [src_ "/icon/terminal.svg"] + Just "python" -> [src_ "/icon/python.svg"] + Just "javascript" -> [src_ "/icon/javascript.svg"] + Just "sql" -> [src_ "/icon/sql.svg"] + Just s | s `elem` ["cabal","makefile","toml","ini","yaml"] + -> [src_ "/icon/gear.svg"] + _ -> [src_ "/icon/blob-filled.svg"] + + img_ ([alt_ (fromMaybe "blob" syn)] <> icon) td_ [class_ itemClass] (toHtml $ show $ pretty name) td_ [class_ "mono"] do diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index d5495f92..8b04e8f9 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -171,6 +171,9 @@ executable hbs2-git-dashboard , lucid , lucid-htmx , pandoc + , skylighting + , skylighting-core + , skylighting-lucid , scotty >= 0.22 hs-source-dirs: