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
    , readChangesView
    )
where

import Prelude

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
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.ByteString.Base16 as B16 (encode)
import qualified Data.Foldable as F (find)
import qualified Data.Text as T (takeWhile, stripEnd)

import Darcs.Local.Hash.Codec
import Darcs.Local.Inventory.Parser
import Darcs.Local.Inventory.Read
import Darcs.Local.Inventory.Types
import Darcs.Local.Patch.Types
import Darcs.Local.Repository
import Data.Either.Local (maybeRight)
import Data.EventTime.Local
import Data.Text.UTF8.Local (decodeStrict)
import Data.Time.Clock.Local ()
import Vervis.Changes
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

readChangesView
    :: FilePath
    -- ^ Repository path
    -> Int
    -- ^ Offset, i.e. latest patches to skip
    -> Int
    -- ^ Limit, i.e. how many latest patches to take after the offset
    -> IO (Maybe (Int, [LogEntry]))
    -- ^ Total number of changes, and view of the chosen subset
readChangesView path off lim = fmap maybeRight $ runExceptT $ do
    total <- ExceptT $ readLatestInventory path latestInventorySizeP
    let off' = total - off - lim
    ps <- ExceptT $ readLatestInventory path $ latestInventoryPageP off' lim
    now <- lift getCurrentTime
    let toLE pi h = LogEntry
            { leAuthor  =
                T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi
            , leHash    = decodeStrict $ encodePatchHash h
            , leMessage = piTitle pi
            , leTime    =
                intervalToEventTime $
                FriendlyConvert $
                now `diffUTCTime` piTime pi
            }
    return (total, map (uncurry toLE) $ reverse $ snd ps)