{- This file is part of Vervis. - - Written in 2016, 2018 by fr33domlover . - - ♡ 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 - . -} module Vervis.Darcs ( readSourceView , readWikiView , readChangesView , lastChange , readPatch ) 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.Patch 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 $ encodePatchInfoHash h , leMessage = piTitle pi , leTime = ( piTime pi , intervalToEventTime $ FriendlyConvert $ now `diffUTCTime` piTime pi ) } return (total, map 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, _ih, _ch) : _ -> intervalToEventTime $ FriendlyConvert $ now `diffUTCTime` piTime pi -- TODO readPatch :: FilePath -> Text -> IO (Maybe Patch) readPatch path hash = error "Not implemented" -- I'm not sure what's the fastest way to find a patch file given its info -- hash, maybe Darcs keeps some cache or something. But assuming there are -- no tricks like that, here's an idea how to grab the patch: -- -- (1) Start going over the whole inventory, whose order is from latest to -- oldest, looking for a patch with the given hash. -- (2) Once found, determine the patch filename from its size and content -- hash -- (3) Run the patch parser on that file, through a zlib decompressor -- though (check how I did that for the inventories parser) -- -- TODO idea: Use hints to speed up finding the patch! In the repo history -- log page, embed hints into the hyperlinks to the patches, and in the -- patch page handler, use the hint to figure out the patch location. -- Actually, since the inventory file contains patch content hashes, I can -- use that as a hint and skip the whole step of looking for the patch! -- -- TODO maybe start by finding the patch hash in patch_ids and use the -- position as a hint to its location in the inventories -- -- TODO maybe I can figure out from darcs source code how a given patch -- hash is found? Just in case there's a faster way -- -- TODO find out what's the index and patch_index files under _darcs and -- maybe other files there, possibly there's a way to patch the info hash -- with the content hash. -- -- UPDATE: I read about index and patch_index, looks like they won't help. -- But possibly the global cache system will? However interesting note: -- Vervis on my laptop has a patch_index, but on the server it doesn't. -- Probably because `darcs log` never runs on the server since I parse -- patches manually. If I end up using the patch index for something, it -- may be a good idea to trigger its generation, so that it's available -- when people browser repo pages.