vervis/src/Vervis/Git.hs

{- 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/>.
 -}

module Vervis.Git
    ( readSourceView
    )
where

import Prelude

import Data.Foldable (find)
import Data.Git
import Data.Git.Harder
import Data.Git.Storage (getObject_)
import Data.Git.Storage.Object (Object (..))
import Data.Set (Set)
import Data.String (fromString)
import Data.Text (Text, unpack, pack)
import Data.Text.Encoding (encodeUtf8)

import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Set as S (member, mapMonotonic)

import Data.Git.Local
import Vervis.Foundation (Widget)
import Vervis.Readme
import Vervis.SourceTree

matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
matchReadme (_, _, name, EntObjBlob) = isReadme name
matchReadme _                        = False

-- | Find a README file in a directory. Return the filename and the file
-- content.
findReadme :: Git -> TreeRows -> IO (Maybe (Text, BL.ByteString))
findReadme git rows =
    case find matchReadme rows of
        Nothing                         -> return Nothing
        Just (_perm, oid, name, _etype) -> do
            obj <- getObject_ git (unObjId oid) True
            return $ case obj of
                ObjBlob b -> Just (name, blobGetContent b)
                _         -> Nothing

matchType :: EntObjType -> EntryType
matchType EntObjBlob = TypeBlob
matchType EntObjTree = TypeTree

rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry
rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name

loadSourceView
    :: Git
    -> Text
    -> [Text]
    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
loadSourceView git refT dir = do
    branches <- branchList git
    tags <- tagList git
    let refS = unpack refT
        refN = RefName refS
    msv <- if refN `S.member` branches || refN `S.member` tags
        then do
            tipOid <- resolveName git refS
            mtree <- resolveTreeish git $ unObjId tipOid
            case mtree of
                Nothing   -> return Nothing
                Just tree -> do
                    let dir' = map (entName . encodeUtf8) dir
                    view <- viewPath git tree dir'
                    Just <$> case view of
                        RootView rows -> do
                            mreadme <- findReadme git rows
                            let ents = map rowToEntry rows
                            return $ SourceDir $
                                DirectoryView Nothing ents mreadme
                        TreeView name _ rows -> do
                            mreadme <- findReadme git rows
                            let ents = map rowToEntry rows
                            return $ SourceDir $
                                DirectoryView (Just name) ents mreadme
                        BlobView name _ body ->
                            return $ SourceFile $ FileView name body
        else return Nothing
    return (branches, tags, msv)

readSourceView
    :: FilePath
    -- ^ Repository path
    -> Text
    -- ^ Name of branch or tag
    -> [Text]
    -- ^ Path in the source tree pointing to a file or directory
    -> IO (Set Text, Set Text, Maybe (SourceView Widget))
    -- ^ Branches, tags, view of the selected item
readSourceView path ref dir = do
    (bs, ts, msv) <-
        withRepo (fromString path) $ \ git -> loadSourceView git ref dir
    let toTexts = S.mapMonotonic $ pack . refNameRaw
    return (toTexts bs, toTexts ts, renderSources dir <$> msv)