Generate commit diff data for git repos

src/Data/List/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,11 +15,15 @@
 
 module Data.List.Local
     ( -- groupByFst
+      groupJusts
+    , groupEithers
     )
 where
 
 import Prelude
 
+import Data.List.NonEmpty (NonEmpty (..), (<|))
+
 -- | Takes a list of pairs and groups them by consecutive ranges with equal
 -- first element. Returns a list of pairs, where each pair corresponds to one
 -- such range.
@@ -28,3 +32,25 @@ groupByFst []          = []
 groupByFst ((x, y):ps) =
     let (same, rest) = span ((== x) . fst) ps
     in  (x, y : map snd same) : groupByFst rest
+
+-- | Group together sublists of Just items, and drop the Nothing items.
+--
+-- >>> groupJusts [Nothing, Nothing, Just 1, Just 4, Nothing, Just 2]
+-- [[1, 4], [2]]
+groupJusts :: [Maybe a] -> [NonEmpty a]
+groupJusts maybes = prepend $ foldr go (Nothing, []) maybes
+    where
+    prepend (Nothing, l) = l
+    prepend (Just x , l) = x : l
+    go Nothing  (Nothing, ls) = (Nothing       , ls)
+    go Nothing  (Just l , ls) = (Nothing       , l : ls)
+    go (Just x) (Nothing, ls) = (Just $ x :| [], ls)
+    go (Just x) (Just l , ls) = (Just $ x <| l , ls)
+
+groupEithers :: [Either a b] -> ([b], [(NonEmpty a, NonEmpty b)], [a])
+groupEithers = foldr go ([], [], [])
+    where
+    go (Left x) ([]  , []         , as) = ([], []                     , x : as)
+    go (Left x) ([]  , (xs, ys):ps, as) = ([], (x <| xs, ys) : ps     , as)
+    go (Left x) (b:bs, ps         , as) = ([], (x :| [], b :| bs) : ps, as)
+    go (Right y) (bs, ps, as)           = (y : bs, ps, as)

src/Vervis/Git.hs

@@ -23,8 +23,12 @@ where
 
 import Prelude
 
+import Control.Arrow ((&&&), (***))
+import Data.Algorithm.Patience (diff, Item (..))
+import Data.Byteable (toBytes)
 import Data.Foldable (find)
 import Data.Git
+import Data.Git.Diff
 import Data.Git.Graph
 import Data.Git.Harder
 import Data.Git.Ref (fromHex, toHex)
@@ -34,6 +38,7 @@ import Data.Git.Storage.Object (Object (..))
 import Data.Git.Types (GitTime (..))
 import Data.Graph.Inductive.Graph (noNodes)
 import Data.Graph.Inductive.Query.Topsort
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Set (Set)
 import Data.String (fromString)
 import Data.Text (Text)
@@ -41,12 +46,15 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Time.Clock ()
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Data.Traversable (for)
+import Data.Word (Word32)
 import System.Hourglass (timeCurrent)
 import Text.Email.Validate (emailAddress)
 import Time.Types (Elapsed (..), Seconds (..))
 
-import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString as B (intercalate)
+import qualified Data.ByteString.Lazy as BL (ByteString, toStrict, length)
 import qualified Data.DList as D (DList, empty, snoc, toList)
+import qualified Data.List.NonEmpty as N (toList)
 import qualified Data.Set as S (member, mapMonotonic)
 import qualified Data.Text as T (pack, unpack, break, strip)
 import qualified Data.Text.Encoding as TE (decodeUtf8With)
@@ -55,6 +63,7 @@ import qualified Data.Text.Encoding.Error as TE (lenientDecode)
 import Data.ByteString.Char8.Local (takeLine)
 import Data.EventTime.Local
 import Data.Git.Local
+import Data.List.Local
 import Vervis.Changes
 import Vervis.Foundation (Widget)
 import Vervis.Patch
@@ -201,17 +210,66 @@ patch edits c = Patch
         in  (T.strip l, T.strip r)
     (title, desc) = split $ decodeUtf8 $ commitMessage c
 
+ep2fp :: EntPath -> FilePath
+ep2fp = T.unpack . decodeUtf8 . B.intercalate "/" . map toBytes
+
+unModePerm :: ModePerm -> Word32
+unModePerm (ModePerm w) = w
+
+mkdiff :: [Text] -> [Text] -> [(Int, Hunk)]
+mkdiff old new =
+    let eitherOldNew (Old a)    = Just $ Left a
+        eitherOldNew (New a)    = Just $ Right a
+        eitherOldNew (Both _ _) = Nothing
+        stripLineNumber = fmap snd
+        mkhunk' (adds, pairs, rems) = Hunk
+            { hunkAddFirst   = stripLineNumber adds
+            , hunkRemoveAdd  = map (stripLineNumber *** stripLineNumber) pairs
+            , hunkRemoveLast = stripLineNumber rems
+            }
+        line ((n, _):_, _                 , _)        = n
+        line ([]      , ((n, _) :| _, _):_, _)        = n
+        line ([]      , []                , (n, _):_) = n
+        line ([]      , []                , [])       = error "empty hunk"
+        mkhunk = line &&& mkhunk'
+    in  map (mkhunk . groupEithers . N.toList) $
+        groupJusts $
+        map eitherOldNew $
+        diff (zip [1..] old) (zip [1..] new)
+
+accumEdits :: BlobStateDiff -> [Edit] -> [Edit]
+accumEdits (OnlyOld bs) es =
+    case bsContent bs of
+        FileContent lines -> RemoveTextFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (map (decodeUtf8 . BL.toStrict) lines) : es
+        BinaryContent b   -> RemoveBinaryFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (BL.length b) : es
+accumEdits (OnlyNew bs) es =
+    case bsContent bs of
+        FileContent lines -> AddTextFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (map (decodeUtf8 . BL.toStrict) lines) : es
+        BinaryContent b   -> AddBinaryFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (BL.length b) : es
+accumEdits (OldAndNew old new) es =
+    if bsFilename old == bsFilename new
+        then if bsRef old == bsRef new
+                then if bsMode old == bsMode new
+                        then es
+                        else ChmodFile (ep2fp $ bsFilename new) (unModePerm $ bsMode old) (unModePerm $ bsMode new) : es
+                else case (bsContent old, bsContent new) of
+                        (FileContent ols, FileContent nls) ->
+                            case mkdiff (map (decodeUtf8 . BL.toStrict) ols) (map (decodeUtf8 . BL.toStrict) nls) of
+                                [] -> error "file ref changed, diff is empty?"
+                                h:hs -> EditTextFile (ep2fp $ bsFilename new) (h :| hs) (unModePerm $ bsMode old) (unModePerm $ bsMode new) : es
+                        (BinaryContent b, FileContent nls) -> BinaryToText (ep2fp $ bsFilename new) (BL.length b) (unModePerm $ bsMode old) (map (decodeUtf8 . BL.toStrict) nls) (unModePerm $ bsMode new) : es
+                        (FileContent ols, BinaryContent b) -> TextToBinary (ep2fp $ bsFilename new) (map (decodeUtf8 . BL.toStrict) ols) (unModePerm $ bsMode old) (BL.length b) (unModePerm $ bsMode new) : es
+                        (BinaryContent from, BinaryContent to) -> EditBinaryFile (ep2fp $ bsFilename new) (BL.length from) (unModePerm $ bsMode old) (BL.length to) (unModePerm $ bsMode new) : es
+        else error "getDiffWith gave OldAndNew with different file paths"
+
 readPatch :: FilePath -> Text -> IO (Patch, [Text])
 readPatch path hash = withRepo (fromString path) $ \ git -> do
     let ref = fromHex $ encodeUtf8 hash
     c <- getCommit git ref
     medits <- case commitParents c of
-        []  -> -- use the tree to generate list of AddFile diff parts
-                return $ Right []
-        [p] -> -- use getDiff to grab list of changes in the patch
-                return $ Right []
-        ps  -> -- multiple parents! idk rn how to deal with this correctly
-                fmap Left $ for ps $ \ p ->
+        []  -> error "Use the tree to generate list of AddFile diff parts?"
+        [p] -> Right <$> getDiffWith accumEdits [] p ref git
+        ps  -> fmap Left $ for ps $ \ p ->
                     decodeUtf8 . takeLine . commitMessage <$> getCommit git p
     return $ case medits of
         Left parents -> (patch []    c, parents)

src/Vervis/Patch.hs

@@ -13,7 +13,7 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
--- | Representation of commit in a repo for viewing.
+-- | Representation of a commit in a repo for viewing.
 --
 -- Each version control system has its own specific details of how repository
 -- changes are represented and encoded and stored internally. This module is
@@ -28,17 +28,16 @@ where
 import Prelude
 
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
 import Text.Email.Validate (EmailAddress)
 
 data Hunk = Hunk
-    { hunkContextBefore :: [Text]
-    , hunkLineNumber    :: Int
-    , hunkOldLines      :: [Text]
-    , hunkNewLines      :: [Text]
-    , hunkContextAfter  :: [Text]
+    { hunkAddFirst   :: [Text]
+    , hunkRemoveAdd  :: [(NonEmpty Text, NonEmpty Text)]
+    , hunkRemoveLast :: [Text]
     }
 
 data Edit
@@ -48,7 +47,7 @@ data Edit
     | RemoveBinaryFile FilePath Word32 Int64
     | MoveFile FilePath Word32 FilePath Word32
     | ChmodFile FilePath Word32 Word32
-    | EditTextFile FilePath [Hunk] Word32 Word32
+    | EditTextFile FilePath (NonEmpty (Int, Hunk)) Word32 Word32
     | EditBinaryFile FilePath Int64 Word32 Int64 Word32
     | TextToBinary FilePath [Text] Word32 Int64 Word32
     | BinaryToText FilePath Int64 Word32 [Text] Word32

vervis.cabal

@@ -278,6 +278,7 @@ library
                      , pandoc-types
                        -- for PathPiece instance for CI, Web.PathPieces.Local
                      , path-pieces
+                     , patience
                      , persistent
                      , persistent-email-address
                      , persistent-migration