Render README below repo tree view when present

This commit is contained in:
fr33domlover 2016-04-13 16:17:34 +00:00
parent b42d9db432
commit 85319ddfdc
5 changed files with 109 additions and 23 deletions

View file

@ -69,6 +69,7 @@ import Vervis.Foundation
import Vervis.Git (timeAgo') import Vervis.Git (timeAgo')
import Vervis.Path import Vervis.Path
import Vervis.Model import Vervis.Model
import Vervis.Readme
import Vervis.Render import Vervis.Render
import Vervis.Settings import Vervis.Settings
import Vervis.Style import Vervis.Style
@ -157,7 +158,14 @@ getRepoSource repository user repo ref dir = do
_ -> error "expected tree or blob" _ -> error "expected tree or blob"
view <- case target of view <- case target of
Left b -> Left <$> return b Left b -> Left <$> return b
Right t -> Right <$> viewTree git t Right t -> do
v <- viewTree git t
mreadme <- findReadme git t
let r = case mreadme of
Nothing -> Nothing
Just (t, b) ->
Just (t, renderReadme t b)
return $ Right (v, r)
return $ Just (branches, tags, view) return $ Just (branches, tags, view)
else return Nothing else return Nothing
case minfo of case minfo of
@ -170,7 +178,7 @@ getRepoSource repository user repo ref dir = do
display <- case view of display <- case view of
Left b -> return $ Left $ Left b -> return $ Left $
renderSource (unpack $ last dir) (blobGetContent b) renderSource (unpack $ last dir) (blobGetContent b)
Right v -> return $ Right $ map mkrow v Right (v, mr) -> return $ Right (map mkrow v, mr)
let parent = if null dir then [] else init dir let parent = if null dir then [] else init dir
dirs = zip parent (tail $ inits parent) dirs = zip parent (tail $ inits parent)
title = case (dir, display) of title = case (dir, display) of

55
src/Vervis/Readme.hs Normal file
View file

@ -0,0 +1,55 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | Tools for rendering README files in repository tree view.
module Vervis.Readme
( findReadme
, renderReadme
)
where
import Prelude
import Data.Byteable (toBytes)
import Data.ByteString.Lazy (ByteString)
import Data.Git.Storage (Git, getObject_)
import Data.Git.Storage.Object (Object (..))
import Data.Git.Types (Blob (..), Tree (..))
import Data.Text (Text, toCaseFold, isPrefixOf, unpack)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode)
import Vervis.Foundation (Widget)
import Vervis.Render (renderSource)
-- | Find a README file in a directory. Return the filename and the file
-- content.
findReadme :: Git -> Tree -> IO (Maybe (Text, ByteString))
findReadme git tree = go $ treeGetEnts tree
where
go [] = return Nothing
go ((_perm, name, ref) : es) =
let nameT = decodeUtf8With strictDecode $ toBytes name
in if toCaseFold "readme" `isPrefixOf` toCaseFold nameT
then do
obj <- getObject_ git ref True
case obj of
ObjBlob b -> return $ Just (nameT, blobGetContent b)
_ -> go es
else go es
-- | Render README content into a widget for inclusion in a page.
renderReadme :: Text -> ByteString -> Widget
renderReadme name content = renderSource (unpack name) content

View file

@ -15,40 +15,59 @@
-- | Tools for rendering repository file contents and other source files. -- | Tools for rendering repository file contents and other source files.
module Vervis.Render module Vervis.Render
( renderSource ( renderPlain
, renderHighlight
, renderSource
) )
where where
import Prelude import Prelude
import Control.Monad.Logger (logWarn) import Control.Monad.Logger (logDebug, logWarn)
import Data.ByteString.Lazy (ByteString, toStrict) import Data.ByteString.Lazy (ByteString, toStrict)
import Data.Monoid ((<>))
import Data.Text (pack) import Data.Text (pack)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Lazy.Encoding (decodeUtf8With)
import Formatting hiding (format)
import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName)) import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName))
import Text.Highlighter.Formatters.Html (format) import Text.Highlighter.Formatters.Html (format)
import Yesod.Core.Widget (whamlet, toWidget) import Yesod.Core.Widget (whamlet, toWidget)
import Vervis.Foundation (Widget) import Vervis.Foundation (Widget)
renderSource :: FilePath -> ByteString -> Widget renderPlain :: ByteString -> Widget
renderSource name content = renderPlain content =
let raw =
[whamlet| [whamlet|
<pre> <pre>
<code>#{decodeUtf8With lenientDecode content} <code>#{decodeUtf8With lenientDecode content}
|] |]
in case lexerFromFilename name of
Nothing -> raw renderHighlight
:: FilePath -> ByteString -> Either (Maybe Lexer) (Lexer, Widget)
renderHighlight name content =
case lexerFromFilename name of
Nothing -> Left Nothing
Just lexer -> Just lexer ->
case runLexer lexer $ toStrict content of case runLexer lexer $ toStrict content of
Left err -> do Left err -> Left $ Just lexer
$logWarn $ mconcat Right tokens -> Right (lexer, toWidget $ format True tokens)
[ "Failed to highlight "
, pack name renderSource :: FilePath -> ByteString -> Widget
, " with lexer " renderSource name content =
, pack $ lName lexer let plain = renderPlain content
] in case renderHighlight name content of
raw Left Nothing -> do
Right tokens -> toWidget $ format True tokens $logDebug $ "No lexer found for " <> pack name
plain
Left (Just lexer) -> do
$logWarn $ sformat
( "Failed to highlight " % string % " with lexer "
% string
)
name (lName lexer)
plain
Right (lexer, widget) -> do
$logDebug $ sformat
("Lexed " % string % " with " % string) name (lName lexer)
widget

View file

@ -41,7 +41,7 @@ $forall (piece, piecePath) <- dirs
$case display $case display
$of Left source $of Left source
^{source} ^{source}
$of Right rows $of Right (rows, mreadme)
<table> <table>
<tr> <tr>
<th>Type <th>Type
@ -52,3 +52,6 @@ $case display
<td> <td>
<a href=@{RepoSourceR user repo ref (dir ++ [name])}> <a href=@{RepoSourceR user repo ref (dir ++ [name])}>
#{name} #{name}
$maybe (readmeName, readmeWidget) <- mreadme
<h2>#{readmeName}
^{readmeWidget}

View file

@ -104,6 +104,7 @@ library
, fgl , fgl
, file-embed , file-embed
, filepath , filepath
, formatting
, hashable , hashable
, highlighter2 , highlighter2
, hit , hit