mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
5c873b4b2e
commit
2958b5f2ac
|
|
@ -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 */
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue