diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css index 9b7a8329..9bc5b1d9 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -326,3 +326,67 @@ td.tree-locator span { margin-right: .5rem; } +pre > code.sourceCode { white-space: pre; position: relative; } +pre > code.sourceCode > span { line-height: 1.25; } +pre > code.sourceCode > span:empty { height: 1.2em; } +.sourceCode { overflow: visible; } +code.sourceCode > span { color: inherit; text-decoration: inherit; } +div.sourceCode { margin: 1em 0; } +pre.sourceCode { margin: 0; } +@media screen { +div.sourceCode { overflow: auto; } +} +@media print { +pre > code.sourceCode { white-space: pre-wrap; } +pre > code.sourceCode > span { display: inline-block; text-indent: -5em; padding-left: 5em; } +} +pre.numberSource code + { counter-reset: source-line 0; } +pre.numberSource code > span + { position: relative; left: -4em; counter-increment: source-line; } +pre.numberSource code > span > a:first-child::before + { content: counter(source-line); + position: relative; left: -1em; text-align: right; vertical-align: baseline; + border: none; display: inline-block; + -webkit-touch-callout: none; -webkit-user-select: none; + -khtml-user-select: none; -moz-user-select: none; + -ms-user-select: none; user-select: none; + padding: 0 4px; width: 4em; + color: #aaaaaa; + } +pre.numberSource { margin-left: 3em; border-left: 1px solid #aaaaaa; padding-left: 4px; } +div.sourceCode + { background-color: #f8f8f8; } +@media screen { +pre > code.sourceCode > span > a:first-child::before { text-decoration: underline; } +} +code span.al { color: #ef2929; } /* Alert */ +code span.an { color: #8f5902; font-weight: bold; font-style: italic; } /* Annotation */ +code span.at { color: #204a87; } /* Attribute */ +code span.bn { color: #0000cf; } /* BaseN */ +code span.cf { color: #204a87; font-weight: bold; } /* ControlFlow */ +code span.ch { color: #4e9a06; } /* Char */ +code span.cn { color: #8f5902; } /* Constant */ +code span.co { color: #8f5902; font-style: italic; } /* Comment */ +code span.cv { color: #8f5902; font-weight: bold; font-style: italic; } /* CommentVar */ +code span.do { color: #8f5902; font-weight: bold; font-style: italic; } /* Documentation */ +code span.dt { color: #204a87; } /* DataType */ +code span.dv { color: #0000cf; } /* DecVal */ +code span.er { color: #a40000; font-weight: bold; } /* Error */ +code span.ex { } /* Extension */ +code span.fl { color: #0000cf; } /* Float */ +code span.fu { color: #204a87; font-weight: bold; } /* Function */ +code span.im { } /* Import */ +code span.in { color: #8f5902; font-weight: bold; font-style: italic; } /* Information */ +code span.kw { color: #204a87; font-weight: bold; } /* Keyword */ +code span.op { color: #ce5c00; font-weight: bold; } /* Operator */ +code span.ot { color: #8f5902; } /* Other */ +code span.pp { color: #8f5902; font-style: italic; } /* Preprocessor */ +code span.sc { color: #ce5c00; font-weight: bold; } /* SpecialChar */ +code span.ss { color: #4e9a06; } /* SpecialString */ +code span.st { color: #4e9a06; } /* String */ +code span.va { color: #000000; } /* Variable */ +code span.vs { color: #4e9a06; } /* VerbatimString */ +code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */ + + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 02cfe522..65f33dff 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -238,8 +238,25 @@ runDashboardWeb wo = do debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty 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 + get "/repo/:lww/blob/: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) + + back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash) + + blobInfo <- lift (selectBlobInfo (BlobHash blobHash)) + >>= orFall (status status404) + + lift $ html =<< renderTextT (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo) + gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) 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 0f5b5f57..a72b9a0a 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 @@ -23,9 +23,8 @@ import DBPipe.SQLite hiding (insert) import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G - -import Control.Applicative import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy (ByteString) import Lucid.Base import Data.Text qualified as Text import Data.Word @@ -526,7 +525,7 @@ createRepoBlobIndexTable = do newtype BlobSyn = BlobSyn (Maybe Text) - deriving newtype (FromField,ToField,Pretty) + deriving newtype (FromField,ToField,Pretty,Eq,Ord) newtype BlobName = BlobName FilePath deriving newtype (FromField,ToField,Pretty) @@ -535,7 +534,21 @@ newtype BlobHash = BlobHash GitHash deriving newtype (FromField,ToField,Pretty) newtype BlobSize = BlobSize Integer - deriving newtype (FromField,ToField,Pretty) + deriving newtype (FromField,ToField,Pretty,Num,Enum,Eq,Ord) + + +data BlobInfo = + BlobInfo + { blobHash :: BlobHash + , blobName :: BlobName + , blobSize :: BlobSize + , blobSyn :: BlobSyn + } + deriving stock (Generic) + +instance FromRow BlobInfo + +type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)] insertBlob :: DashBoardPerks m => (BlobHash, BlobName, BlobSize, BlobSyn) @@ -551,10 +564,21 @@ insertBlob (h,n,size,syn) = do |] (h,n,size,syn) +selectBlobInfo :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => BlobHash + -> m (Maybe BlobInfo) +selectBlobInfo what = withState do + select [qc| + select hash,name,size,syntax + from blob + where hash = ? + |] (Only what) + <&> listToMaybe + selectTreeLocator :: (DashBoardPerks m, MonadReader DashBoardEnv m) => TreeCommit -> TreeTree - -> m [(TreeParent, TreeTree, TreeLevel, TreePath)] + -> m TreeLocator selectTreeLocator kommit tree = withState do @@ -581,6 +605,19 @@ ORDER BY level pattern TreeHash :: GitHash -> LBS8.ByteString pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _)) +readBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> BlobHash + -> m ByteString + +readBlob repo hash = do + + dir <- repoDataPath repo + + gitRunCommand [qc|git --git-dir {dir} cat-file blob {pretty hash}|] + <&> fromRight mempty + + buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m () buildCommitTreeIndex dir = do diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs index 1345ea33..7064512e 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs @@ -15,6 +15,8 @@ import HBS2.Net.Messaging.Unix import DBPipe.SQLite +import HBS2.System.Dir + import System.FilePath data HttpPortOpt @@ -53,6 +55,9 @@ data DashBoardEnv = 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 } 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 59d37746..fb3785ec 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 @@ -9,19 +9,25 @@ import HBS2.Git.DashBoard.State import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.RepoHead +import Data.ByteString.Lazy qualified as LBS import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Lucid.Base import Lucid.Html5 hiding (for_) import Lucid.Htmx +import Skylighting qualified as Sky +import Skylighting.Tokenizer +import Skylighting.Format.HTML.Lucid as Lucid + +import Control.Applicative import Text.Pandoc hiding (getPOSIXTime) import System.FilePath import Data.Word import Data.Either +import Data.List qualified as List import Data.List (sortOn) -import Skylighting.Core qualified as Sky -import Skylighting qualified as Sky import Streaming.Prelude qualified as S @@ -232,6 +238,42 @@ showRefsHtmxAttribs repo = , hxTarget_ "#repo-tab-data" ] + +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_ (path ["repo", repo, "tree", co_, co_]) + , hxTarget_ "#repo-tab-data" + , href_ "#" + ] + + span_ [] $ a_ (showRefsHtmxAttribs repo <> [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 = path [ "repo", show $ pretty lww, "tree", co_, show (pretty this) ] + span_ [] do + a_ [ href_ "#" + , hxGet_ uri + , hxTarget_ "#repo-tab-data" + ] (toHtml (show $ pretty name)) + next + repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> GitHash -- ^ this @@ -247,6 +289,7 @@ repoTree lww co root tree back' = do let syntaxMap = Sky.defaultSyntaxMap let co_ = show $ pretty co + let this_ = show $ pretty $ root let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree where @@ -256,29 +299,12 @@ repoTree lww co root tree back' = do locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root) - let prefixSlash x = if fromIntegral x > 1 then span_ "/" else "" - let showRoot = - [ hxGet_ (path ["repo", repo, "tree", co_, co_]) - , hxTarget_ "#repo-tab-data" - , href_ "#" - ] table_ [] do tr_ do td_ [class_ "tree-locator", colspan_ "3"] do - span_ [] $ a_ (showRefsHtmxAttribs repo <> [href_ "#" ]) $ toHtml (take 10 repo <> "..") - span_ [] "/" - span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..") - span_ [] "/" - for_ locator $ \(_,this,level,name) -> do - prefixSlash level - let uri = path [ "repo", show $ pretty lww, "tree", co_, show (pretty this) ] - span_ [] do - a_ [ href_ "#" - , hxGet_ uri - , hxTarget_ "#repo-tab-data" - ] (toHtml (show $ pretty name)) + treeLocator lww co locator none tr_ mempty do @@ -322,19 +348,104 @@ repoTree lww co root tree back' = do td_ [class_ "mono"] do case tp of Blob -> do - span_ do - toHtml $ show $ pretty h + let blobUri = path ["repo", repo, "blob", co_, this_, hash_ ] + a_ [ href_ "#" + , hxGet_ blobUri + , hxTarget_ "#repo-tab-data" + ] (toHtml hash_) Tree -> do a_ [ href_ "#" , hxGet_ uri , hxTarget_ "#repo-tab-data" - -- , hxPushUrl_ "true" - ] (toHtml $ show $ pretty h) + ] (toHtml hash_) _ -> mempty +{- HLINT ignore "Functor law" -} + +repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> TreeCommit + -> TreeTree + -> BlobInfo + -> HtmlT m () + +repoBlob lww co tree BlobInfo{..} = do + locator <- lift $ selectTreeLocator co tree + let co_ = show $ pretty co + let tree_ = show $ pretty 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_ [] do + tr_ do + th_ $ strong_ "hash" + td_ [colspan_ "8"] 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 + + th_ $ none + td_ $ none + + th_ $ none + td_ $ none + + + let fallback _ = mempty + + + fromMaybe mempty <$> runMaybeT do + + guard (blobSize < 10485760) + + let fn = blobName & coerce + let syntaxMap = Sky.defaultSyntaxMap + + syn <- ( Sky.syntaxesByFilename syntaxMap fn + & headMay + ) <|> Sky.syntaxByName syntaxMap "default" + & toMPlus + + lift do + + txt <- lift (readBlob lww blobHash) + <&> LBS.toStrict + <&> Text.decodeUtf8 + + case blobSyn of + BlobSyn (Just "markdown") -> do + + toHtmlRaw (renderMarkdown' txt) + + _ -> do + + txt <- lift (readBlob lww blobHash) + <&> LBS.toStrict + <&> Text.decodeUtf8 + + let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap } + + case tokenize config syn txt of + Left _ -> fallback txt + Right tokens -> do + let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color } + let code = renderText (Lucid.formatHtmlBlock fo tokens) + toHtmlRaw code + + repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () repoPage it@RepoListItem{..} = rootPage do