vervis/src/Vervis/Darcs.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018 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
    , readWikiView
    , readChangesView
    , lastChange
    )
where

import Prelude hiding (lookup)

import Control.Applicative ((<|>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Darcs.Util.Path
import Darcs.Util.Tree
import Darcs.Util.Tree.Hashed
import Data.Bool (bool)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode)
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Data.Traversable (for)
import Development.Darcs.Internal.Hash.Codec
import Development.Darcs.Internal.Inventory.Parser
import Development.Darcs.Internal.Inventory.Read
import Development.Darcs.Internal.Inventory.Types
import Development.Darcs.Internal.Patch.Types
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.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
import Vervis.Wiki (WikiView (..))

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

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

nameToText :: Name -> Text
nameToText = decodeUtf8With strictDecode . encodeWhiteName

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"

readStubbedTree :: FilePath -> IO (Tree IO)
readStubbedTree path = do
    let darcsDir = path </> "_darcs"
    (msize, hash) <- readPristineRoot darcsDir
    let pristineDir = darcsDir </> "pristine.hashed"
    readDarcsHashed pristineDir (msize, hash)

readSourceView
    :: FilePath
    -- ^ Repository path
    -> [EntryName]
    -- ^ Path in the source tree pointing to a file or directory
    -> IO (Maybe (SourceView Widget))
readSourceView path dir = do
    stubbedTree <- readStubbedTree path
    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

readWikiView
    :: (EntryName -> EntryName -> Maybe Text)
    -- ^ Page name predicate. Returns 'Nothing' for a file which isn't a page.
    -- For a page file, returns 'Just' the page name, which is the filename
    -- with some parts possibly removed or added. For example, you may wish to
    -- remove any extensions, replace underscores with spaces and so on.
    -> (EntryName -> Bool)
    -- ^ Main page predicate. This is used to pick a top-level page to display
    -- as the wiki root page.
    -> FilePath
    -- ^ Repository path.
    -> [EntryName]
    -- ^ Path in the source tree pointing to a file. The last component doesn't
    -- have to be the full name of the file though, but it much match the page
    -- predicate for the actual file to be found.
    -> IO (Maybe WikiView)
readWikiView isPage isMain path dir = do
    stubbedTree <- readStubbedTree path
    let (parent, ispage, mfile) =
            if null dir
                then
                    ( []
                    , bool Nothing (Just Nothing) . isMain
                    , Nothing
                    )
                else
                    ( init dir
                    , maybe Nothing (Just . Just) . isPage lst
                    , Just $ decodeWhiteName $ encodeUtf8 lst
                    )
                    where
                    lst = last dir
        anch = dirToAnchoredPath parent
        matchBlob f (n, (File (Blob load _))) = f (nameToText n) load
        matchBlob _ _                         = Nothing
        matchBlob' f (File (Blob load _)) = Just $ f load
        matchBlob' _ _                    = Nothing
        page name load = (,) load . Just <$> ispage name
        matchP = listToMaybe . mapMaybe (matchBlob page) . listImmediate
        matchF t = mfile >>= lookup t >>= matchBlob' (flip (,) Nothing)
    expandedTree <- expandPath stubbedTree anch
    let mpage = case find expandedTree anch of
            Nothing             -> Nothing
            Just (File _)       -> Nothing
            Just (Stub _ _)     -> error "supposed to be expanded"
            Just (SubTree tree) -> matchP tree <|> matchF tree
        mkview Nothing b   = WikiViewRaw b
        mkview (Just mt) b = WikiViewPage mt b
    for mpage $ \ (load, mmtitle) -> mkview mmtitle <$> load

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    =
                ( piTime pi
                , intervalToEventTime $
                  FriendlyConvert $
                  now `diffUTCTime` piTime pi
                )
            }
    return (total, map (uncurry toLE) $ reverse $ snd ps)

lastChange :: FilePath -> UTCTime -> IO (Maybe EventTime)
lastChange path now = fmap maybeRight $ runExceptT $ do
    total <- ExceptT $ readLatestInventory path latestInventorySizeP
    let lim = 1
        off = total - lim
    (_, l) <- ExceptT $ readLatestInventory path $ latestInventoryPageP off lim
    return $ case reverse l of
        []            -> Never
        (pi, _ph) : _ ->
            intervalToEventTime $
            FriendlyConvert $
            now `diffUTCTime` piTime pi