wip

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

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
+  get "/repo/:lww/blob/:co/:hash/:blob" do
-repoDataPath lw = asks _dataDir <&> (</> (show $ pretty lw)) >>= canonicalizePath
+    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)

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
 

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 }

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 <> "..")
+        treeLocator lww co locator none
-        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))
 
     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
+              let blobUri = path ["repo", repo, "blob", co_, this_, hash_ ]
-                toHtml $ show $ pretty h
+              a_ [ href_ "#"
+                 , hxGet_ blobUri
+                 , hxTarget_ "#repo-tab-data"
+                 ] (toHtml hash_)
 
             Tree -> do
               a_ [ href_ "#"
                  , hxGet_ uri
                  , hxTarget_ "#repo-tab-data"
-                 -- , hxPushUrl_ "true"
+                 ] (toHtml hash_)
-                 ] (toHtml $ show $ pretty h)
 
             _ -> 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