vervis/src/Vervis/Darcs.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.Darcs
    ( readSourceView
    )
where

import Prelude

import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode)
import Data.Traversable (for)
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Darcs
import Storage.Hashed.Tree
import System.FilePath ((</>))

import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.Foldable as F (find)

import Darcs.Local
import Vervis.Foundation (Widget)
import Vervis.Readme
import Vervis.SourceTree

dirToAnchoredPath :: [EntryName] -> AnchoredPath
dirToAnchoredPath = AnchoredPath . map (Name . encodeUtf8)

matchType :: ItemType -> EntryType
matchType TreeType = TypeTree
matchType BlobType = TypeBlob

nameToText :: Name -> Text
nameToText (Name b) = decodeUtf8With strictDecode b

itemToEntry :: Name -> TreeItem IO -> DirEntry
itemToEntry name item = DirEntry (matchType $ itemType item) (nameToText name)

findReadme :: [(Name, TreeItem IO)] -> IO (Maybe (Text, BL.ByteString))
findReadme pairs =
    case F.find (isReadme . nameToText . fst) pairs of
        Nothing           -> return Nothing
        Just (name, item) ->
            case item of
                File (Blob load _hash) -> do
                    content <- load
                    return $ Just (nameToText name, content)
                _ -> return Nothing

itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView BL.ByteString)
itemToSourceView name (File (Blob load _hash)) = do
    content <- load
    return $ SourceFile $ FileView name content
itemToSourceView name (SubTree tree) = do
    let items = listImmediate tree
    mreadme <- findReadme items
    return $ SourceDir DirectoryView
        { dvName    = Just name
        , dvEntries = map (uncurry itemToEntry) items
        , dvReadme  = mreadme
        }
itemToSourceView _name (Stub _load _hash) = error "supposed to be expanded"

readSourceView
    :: FilePath
    -- ^ Repository path
    -> [EntryName]
    -- ^ Path in the source tree pointing to a file or directory
    -> IO (Maybe (SourceView Widget))
readSourceView path dir = do
    let darcsDir = path </> "_darcs"
    (msize, hash) <- readPristineRoot darcsDir
    let pristineDir = darcsDir </> "pristine.hashed"
    stubbedTree <- readDarcsHashed pristineDir (msize, hash)
    msv <- if null dir
        then do
            let items = listImmediate stubbedTree
            mreadme <- findReadme items
            return $ Just $ SourceDir DirectoryView
                { dvName    = Nothing
                , dvEntries = map (uncurry itemToEntry) items
                , dvReadme  = mreadme
                }
        else do
            let anch = dirToAnchoredPath dir
            expandedTree <- expandPath stubbedTree anch
            let mitem = find expandedTree anch
            for mitem $ itemToSourceView (last dir)
    return $ renderSources dir <$> msv