Render README below repo tree view when present

src/Vervis/Handler/Repo.hs

@@ -69,6 +69,7 @@ import Vervis.Foundation
 import Vervis.Git (timeAgo')
 import Vervis.Path
 import Vervis.Model
+import Vervis.Readme
 import Vervis.Render
 import Vervis.Settings
 import Vervis.Style
@@ -157,7 +158,14 @@ getRepoSource repository user repo ref dir = do
                                     _         -> error "expected tree or blob"
                         view <- case target of
                             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)
             else return Nothing
     case minfo of
@@ -170,7 +178,7 @@ getRepoSource repository user repo ref dir = do
             display <- case view of
                     Left b -> return $ Left $
                         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
                 dirs = zip parent (tail $ inits parent)
                 title = case (dir, display) of

src/Vervis/Readme.hs

@@ -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

src/Vervis/Render.hs

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

templates/repo/source.hamlet

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

vervis.cabal

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