Initial implementation of Darcs patch reader

src/Vervis/Darcs.hs

@@ -31,23 +31,29 @@ import Darcs.Util.Path
 import Darcs.Util.Tree
 import Darcs.Util.Tree.Hashed
 import Data.Bool (bool)
-import Data.Maybe (listToMaybe, mapMaybe)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With, decodeUtf8)
 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.Hash.Types
 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 Text.Email.Validate (emailAddress)
 
+import qualified Data.Attoparsec.Text as A
 import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Data.ByteString.Base16 as B16 (encode)
+import qualified Data.ByteString.Base16 as B16 (encode, decode)
 import qualified Data.Foldable as F (find)
-import qualified Data.Text as T (takeWhile, stripEnd)
+import qualified Data.Text as T (unpack, takeWhile, stripEnd)
+import qualified Data.Vector as V (empty)
+import qualified Development.Darcs.Internal.Patch.Parser as P
 
 import Darcs.Local.Repository
 import Data.Either.Local (maybeRight)
@@ -221,40 +227,73 @@ lastChange path now = fmap maybeRight $ runExceptT $ do
             FriendlyConvert $
             now `diffUTCTime` piTime pi
 
--- TODO
+-- | Read patch content, both metadata and the actual diff, from a given Darcs
+-- repository. Preconditions:
+--
+-- * The repository is assumed to exist. If it doesn't, an exception is thrown.
+-- * The repository is assumed to be in a consistent state, all the expected
+--   inventory files and patch files and so on are assumed to exist and have
+--   the expected format. If not, an exception is thrown.
+-- * The hash may or may not be found in the repo. If there's no patch in the
+--   repo with the given hash, 'Nothing' is returned.
 readPatch :: FilePath -> Text -> IO (Maybe Patch)
-readPatch path hash = error "Not implemented"
+readPatch path hash = do
-    -- I'm not sure what's the fastest way to find a patch file given its info
+    let pih = PatchInfoHash $ fst $ B16.decode $ encodeUtf8 hash
-    -- hash, maybe Darcs keeps some cache or something. But assuming there are
+    li <- handle =<< readLatestInventory path latestInventoryAllP
-    -- no tricks like that, here's an idea how to grab the patch:
+    mp <- loop pih (liPatches li) (fst <$> liPrevTag li)
-    --
+    for mp $ \ (pi, pch) -> do
-    -- (1) Start going over the whole inventory, whose order is from latest to
+        (_pir, hunks) <- handle =<< readCompressedPatch path pch P.patch
-    --     oldest, looking for a patch with the given hash.
+        let (an, ae) =
-    -- (2) Once found, determine the patch filename from its size and content
+                either error id $
-    --     hash
+                A.parseOnly (author <* A.endOfInput) $ piAuthor pi
-    -- (3) Run the patch parser on that file, through a zlib decompressor
+        return Patch
-    --     though (check how I did that for the inventories parser)
+            { patchAuthorName  = an
-    --
+            , patchAuthorEmail = ae
-    -- TODO idea: Use hints to speed up finding the patch! In the repo history
+            , patchTime        = piTime pi
-    -- log page, embed hints into the hyperlinks to the patches, and in the
+            , patchTitle       = piTitle pi
-    -- patch page handler, use the hint to figure out the patch location.
+            , patchDescription = fromMaybe "" $ piDescription pi
-    -- Actually, since the inventory file contains patch content hashes, I can
+            , patchDiff        = map mkedit hunks
-    -- use that as a hint and skip the whole step of looking for the patch!
+            }
-    --
+  where
-    -- TODO maybe start by finding the patch hash in patch_ids and use the
+    handle = either (const $ fail "readPatch failed") pure
-    -- position as a hint to its location in the inventories
+    lookup' pih ps = case F.find (\ (_pi, pih', _pch) -> pih' == pih) ps of
-    --
+        Nothing              -> Nothing
-    -- TODO maybe I can figure out from darcs source code how a given patch
+        Just (pi, _pih, pch) -> Just (pi, pch)
-    -- hash is found? Just in case there's a faster way
+    loop pih ps mih = case lookup' pih ps of
-    --
+        Just p  -> return $ Just p
-    -- TODO find out what's the index and patch_index files under _darcs and
+        Nothing -> case mih of
-    -- maybe other files there, possibly there's a way to patch the info hash
+            Nothing -> return Nothing
-    -- with the content hash.
+            Just ih -> do
-    --
+                i <- handle =<< readCompressedInventory path ih earlyInventoryAllP
-    -- UPDATE: I read about index and patch_index, looks like they won't help.
+                case i of
-    -- But possibly the global cache system will? However interesting note:
+                    Left ei  -> loop pih (eiPatches ei) Nothing
-    -- Vervis on my laptop has a patch_index, but on the server it doesn't.
+                    Right mi -> loop pih (miPatches mi) (Just $ miPrevious mi)
-    -- Probably because `darcs log` never runs on the server since I parse
+    email = maybe (fail "invalid email") pure . emailAddress . encodeUtf8
-    -- patches manually. If I end up using the patch index for something, it
+    author = (,)
-    -- may be a good idea to trigger its generation, so that it's available
+        <$> A.takeWhile1 (const True)
-    -- when people browser repo pages.
+        <*  " <"
+        <*> (A.takeWhile1 (/= '>') >>= email)
+        <*  A.skip (== '>')
+    mkhunk h = case P.hunkRemove h of
+        [] -> Hunk
+            { hunkAddFirst   = map decodeUtf8 $ P.hunkAdd h
+            , hunkRemoveAdd  = []
+            , hunkRemoveLast = []
+            }
+        r:rs -> case P.hunkAdd h of
+            [] -> Hunk
+                { hunkAddFirst   = []
+                , hunkRemoveAdd  = []
+                , hunkRemoveLast = map decodeUtf8 $ r : rs
+                }
+            a:as -> Hunk
+                { hunkAddFirst   = []
+                , hunkRemoveAdd  = [(decodeUtf8 <$> r :| rs, decodeUtf8 <$> a :| as)]
+                , hunkRemoveLast = []
+                }
+    mkedit hunk =
+        EditTextFile
+            (T.unpack $ decodeUtf8 $ P.hunkFile hunk)
+            V.empty
+            ((False, P.hunkLine hunk, mkhunk hunk) :| [])
+            0 0