Upgrade to LTS 18 (last LTS with GHC 8)

The major changes:

- No more hit and hit-* packages
- No more diagram and SVG font stuff
- Dependency on darcs is not yet removed
- No more persistent-graph i.e. recursive SQL queries
- Some hit-network stuff still in use, now part of Vervis itself
- Git operations use the git command-line program, a convenient API is provided
  in Data.Git.Local
- No more patch parsing and no diff view, patches are treated as a piece of
  text and displayed as-is (although I could add syntax-highlighting as a nice
  touch for the HTML view)

config/settings-default.yaml

@@ -55,6 +55,7 @@ per-actor-keys:         false
 # should-log-all: false
 # mutable-static: false
 
+# This setting isn't used anymore (because no more need for SVG fonts)
 # load-font-from-lib-data: false
 
 ###############################################################################

src/Control/Concurrent/Actor.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -115,9 +115,6 @@ newtype ActFor s a = ActFor
         )
 
 instance MonadUnliftIO (ActFor s) where
-    askUnliftIO =
-        ActFor $ withUnliftIO $ \ u ->
-            return $ UnliftIO $ unliftIO u . unActFor
     withRunInIO inner =
         ActFor $ withRunInIO $ \ run -> inner (run . unActFor)
 

src/Data/Binary/Get/Local.hs

@@ -0,0 +1,119 @@
+{- This file is part of hit-network.
+ -
+ - 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 Data.Binary.Get.Local
+    ( getHexDigit
+    , getHex16
+    , getDecimal
+    , requireWord8
+    , requireNull
+    , requireSpace
+    , requireNewline
+    , requireByteString
+    )
+where
+
+import Control.Monad (void)
+import Data.Binary.Get
+import Data.Bits
+import Data.ByteString (ByteString)
+import Data.Maybe (fromMaybe)
+import Data.Word (Word8)
+
+import qualified Data.ByteString as B
+
+-- | Read an ASCII character representing a hexadecimal digit, and convert to
+-- the integral value of the digit (i.e. a number between 0 and 15).
+getHexDigit :: Get Word8
+getHexDigit =
+    let fromHex w
+            | 48 <= w && w <= 57  = return $ w - 48 -- 0-9
+            | 65 <= w && w <= 70  = return $ w - 55 -- A-F
+            | 97 <= w && w <= 102 = return $ w - 87 -- a-f
+            | otherwise           = fail "Not an ASCII hex digit"
+    in  getWord8 >>= fromHex
+
+-- | Efficienty convert 'Word8' to 'Int'.
+toInt :: Word8 -> Int
+toInt w =
+    fromMaybe (error "Huh? Converting Word8 to Int failed!") $
+    toIntegralSized w
+
+-- | Read 4 ASCII hex digits and parse them as a hex string into the integer it
+-- represents. Since each hex digit is 4 bits, 4 such digits form a 16-bit
+-- integer (but this function reads 4 bytes which are 32 bits).
+--
+-- The resulting 16-bit integer is returned as an 'Int' because it is used
+-- below with a function which takes an 'Int' parameter.
+getHex16 :: Get Int
+getHex16 = do
+    let sl n = flip unsafeShiftL n . toInt
+    hh <- sl 12 <$> getHexDigit
+    h  <- sl  8 <$> getHexDigit
+    l  <- sl  4 <$> getHexDigit
+    ll <- toInt <$> getHexDigit
+    return $ hh .|. h .|. l .|. ll
+
+fromDigit :: Num a => Word8 -> Maybe a
+fromDigit w =
+    if 48 <= w && w <= 57
+        then Just $ fromIntegral $ w - 48
+        else Nothing
+
+fromDecimal :: Num a => ByteString -> Maybe a
+fromDecimal s = go s 0
+    where
+    go b n =
+        case B.uncons b of
+            Nothing     -> Just n
+            Just (w, r) ->
+                case fromDigit w of
+                    Nothing -> Nothing
+                    Just d  -> go r $ 10 * n + d
+
+-- Read a string of given size representing an integer in decimal, and parse
+-- the integer.
+getDecimal :: Num a => Int -> Get a
+getDecimal len = do
+    s <- getByteString len
+    case fromDecimal s of
+        Nothing -> fail "s doesn't represent a decimal integer"
+        Just n  -> return n
+
+-- | Get a word which satisfies the predicate, otherwise fail.
+requireWord8 :: (Word8 -> Bool) -> Get Word8
+requireWord8 p = do
+    w <- getWord8
+    if p w
+        then return w
+        else fail "Word doesn't satisfy predicate"
+
+requireNull :: Get ()
+requireNull = void $ requireWord8 (== 0)
+
+requireSpace :: Get ()
+requireSpace = void $ requireWord8 (== 32)
+
+requireNewline :: Get ()
+requireNewline = void $ requireWord8 (== 10)
+
+-- | Read a bytestring of the same length as the parameter, and fail if they
+-- aren't equal.
+requireByteString :: ByteString -> Get ()
+requireByteString s = do
+    b <- getByteString $ B.length s
+    if b == s
+        then return ()
+        else fail "Didn't get the expected bytestring"

src/Data/Binary/Put/Local.hs

@@ -0,0 +1,68 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - Written in 2016, 2024 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 Data.Binary.Put.Local
+    ( putNull
+    , putLF
+    , putSpace
+    , putHexDigit
+    , putHex16
+    )
+where
+
+import Data.Binary.Put
+import Data.Bits
+import Data.Maybe (fromMaybe)
+import Data.Word
+
+putNull :: Put
+putNull = putWord8 0
+
+putLF :: Put
+putLF = putWord8 10
+
+putSpace :: Put
+putSpace = putWord8 32
+
+-- | Efficiently convert an integer between 0 and 127 to 'Word8'.
+toWord8 :: Word16 -> Word8
+toWord8 i =
+    fromMaybe (error "Converting Int to Word8 failed") $
+    toIntegralSized i
+
+-- | Take an integral value of a hex digit (i.e. between 0 and 15). Put the
+-- ASCII character representing the digit in lowecase hexadecimal.
+putHexDigit :: Word8 -> Put
+putHexDigit w
+    | 0 <= w && w <= 9   = putWord8 $ w + 48
+    | 10 <= w && w <= 15 = putWord8 $ w + 87
+    | otherwise          = return ()
+
+-- | Takes a number which must be a 16-bit non-negative integer. Generates a
+-- 4-byte ASCII hexadecimal representation of the number's value and puts it.
+putHex16 :: Word16 -> Put
+putHex16 n =
+    let (rem1, ll) = n    `divMod` 16
+        (rem2, l)  = rem1 `divMod` 16
+        (rem3, h)  = rem2 `divMod` 16
+        (rem4, hh) = rem3 `divMod` 16
+    in  if rem4 /= 0
+            then error "Despite using Word16, hex integer to put is too large? Must be 16 bit / we have a bug"
+            else do
+                putHexDigit $ toWord8 hh
+                putHexDigit $ toWord8 h
+                putHexDigit $ toWord8 l
+                putHexDigit $ toWord8 ll

src/Data/Git/Local.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,45 +15,78 @@
  -}
 
 module Data.Git.Local
-    ( -- * Initialize repo
+    ( GitT
-      writeHookFile
+    , withGitRepo
+    , withGitRepoE
+    , git
+    , git_
+    , gitE
+    , gitE_
+
+    , writeHookFile
     , createRepo
-      -- * View repo content
+    , isGitRepo
-    , EntObjType (..)
+
-    , TreeRows
+    , ObjId (..)
-    , PathView (..)
+    , parseObjId
-    , viewPath
+    , renderObjId
-      -- * View refs
+
-    , listBranches
+    , TreeEntryType (..)
-    , listTags
+    , TreeEntry (..)
+    , gitListDir
+    , PathType (..)
+    , gitGetPathType
+    , gitGetFileContentByPath
+    , gitGetFileContentByHash
+
+    , gitListBranches
+    , gitListBranches'
+    , gitListTags
+    , gitListTags'
+    , gitGetObjectHash
+    , gitResolveHead
+    , gitGetObjectHashes
+    , RevType (..)
+    , gitGetRevType
+    , gitGetCommitInfos
+    , gitGetCommitInfo
+    , gitDiff
+    , gitGetCommitParents
+    , gitPeelTag
     )
 where
 
 import Control.Exception
-import Control.Monad (when)
+import Control.Monad
-import Data.Git
+import Control.Monad.IO.Class
-import Data.Git.Harder
+import Control.Monad.Trans.Class
-import Data.Git.Ref (SHA1)
+import Control.Monad.Trans.Except
-import Data.Git.Types
+import Control.Monad.Trans.Reader
+import Data.Either
+import Data.Maybe
+import Data.Map (Map)
 import Data.Set (Set)
 import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8With)
+import Data.Time.Format
-import Data.Text.Encoding.Error (lenientDecode)
+import Data.Traversable
 import System.Directory.Tree
 import System.FilePath
 import System.Posix.Files
+import System.Process.Typed
+--import Text.Diff.Parse
+--import Text.Diff.Parse.Types
+import Text.Email.Validate
 
-import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString as B
-import qualified Data.Set as S (mapMonotonic)
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
+import qualified Data.Set as S
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.IO as TIO
 
-import Data.EventTime.Local
+import qualified Data.VersionControl as VC
-import Data.Hourglass.Local ()
-
-instance SpecToEventTime GitTime where
-    specToEventTime = specToEventTime . gitTimeUTC
-    specsToEventTimes = specsToEventTimes . fmap gitTimeUTC
 
 hookContent :: FilePath -> Text -> Text -> Text
 hookContent hook authority repo =
@@ -120,35 +154,265 @@ createRepo path repo cmd authority = do
         (path </> T.unpack repo </> "hooks" </> "post-receive")
         ownerModes
 
-data EntObjType = EntObjBlob | EntObjTree
+isGitRepo :: FilePath -> IO Bool
+isGitRepo path = do
+    r <- runExceptT $ withGitRepoE path $ gitE "rev-parse" ["--show-prefix"]
+    return $
+        case r of
+            Left _ -> False
+            Right t -> T.null $ T.strip t
 
-type TreeRows = [(ModePerm, ObjId, Text, EntObjType)]
+type GitT m a = ReaderT FilePath m a
 
-data PathView
+withGitRepo :: MonadIO m => FilePath -> GitT m a -> m a
-    = RootView TreeRows
+withGitRepo path action = runReaderT action path
-    | TreeView Text ObjId TreeRows
-    | BlobView Text ObjId BL.ByteString
 
-viewPath :: Git SHA1 -> Tree SHA1 -> EntPath -> IO PathView
+type GitE m a = ExceptT Text (ReaderT FilePath m) a
-viewPath git root path = do
-    let toEnt False = EntObjBlob
-        toEnt True  = EntObjTree
-        toText = decodeUtf8With lenientDecode . getEntNameBytes
-        adapt (perm, oid, name, isTree) =
-            (perm, oid, toText name, toEnt isTree)
-        mkRows t = map adapt <$> viewTree git t
-    mno <- resolveTreePath git root path
-    case mno of
-        Nothing          -> RootView <$> mkRows root
-        Just (name, oid) -> do
-            let nameT = toText name
-            target <- getEntryObject_ git oid
-            case target of
-                Left blob  -> return $ BlobView nameT oid (blobGetContent blob)
-                Right tree -> TreeView nameT oid <$> mkRows tree
 
-listBranches :: Git SHA1 -> IO (Set Text)
+withGitRepoE :: MonadIO m => FilePath -> GitE m a -> ExceptT Text m a
-listBranches git = S.mapMonotonic (T.pack . refNameRaw) <$> branchList git
+withGitRepoE path action = ExceptT $ withGitRepo path $ runExceptT action
 
-listTags :: Git SHA1 -> IO (Set Text)
+git :: MonadIO m => String -> [String] -> GitT m Text
-listTags git = S.mapMonotonic (T.pack . refNameRaw) <$> tagList git
+git cmd args = do
+    repo <- ask
+    lb <- readProcessStdout_ $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
+    liftIO $ either throwIO return $ TE.decodeUtf8' $ BL.toStrict lb
+
+git_ :: MonadIO m => String -> [String] -> GitT m ()
+git_ cmd args = do
+    repo <- ask
+    runProcess_ $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
+
+gitE :: MonadIO m => String -> [String] -> GitE m Text
+gitE cmd args = do
+    repo <- lift ask
+    (code, lb) <- readProcessStdout $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
+    case code of
+        ExitSuccess -> pure ()
+        ExitFailure c -> throwE $ "gitE " <> T.pack cmd <> " exited with code " <> T.pack (show c)
+    either (throwE . T.pack . displayException) return $ TE.decodeUtf8' $ BL.toStrict lb
+
+gitE_ :: MonadIO m => String -> [String] -> GitE m ()
+gitE_ cmd args = do
+    repo <- lift ask
+    code <- runProcess $ setStdin nullStream $ proc "git" $ ["-C", repo, cmd] ++ args
+    case code of
+        ExitSuccess -> pure ()
+        ExitFailure c -> throwE $ "gitE_ " <> T.pack cmd <> " exited with code " <> T.pack (show c)
+
+data ObjId = ObjId { unObjId :: B.ByteString } deriving Eq
+
+parseObjId :: Text -> IO ObjId
+parseObjId t =
+    case B16.decode $ TE.encodeUtf8 t of
+        Left e -> error $ "parseObjId: " ++ e
+        Right b -> pure $ ObjId b
+
+renderObjId :: ObjId -> Text
+renderObjId (ObjId b) =
+    either (error . displayException) id $ TE.decodeUtf8' $ B16.encode b
+
+data TreeEntryType = TETFile Text | TETDir
+
+data TreeEntry = TreeEntry
+    { _teMode :: Text
+    , _teType :: TreeEntryType
+    , _teHash :: ObjId
+    , _teName :: Text
+    }
+
+parseTree :: Text -> IO [TreeEntry]
+parseTree = traverse (parseEntry . T.words) . T.lines
+    where
+    grabName = T.pack . takeFileName . T.unpack
+    parseEntry [mode, "blob", hash, size, path] = do
+        oid <- parseObjId hash
+        pure $ TreeEntry mode (TETFile size) oid (grabName path)
+    parseEntry [mode, "tree", hash, "-", path] = do
+        oid <- parseObjId hash
+        pure $ TreeEntry mode TETDir oid (grabName path)
+    parseEntry _ = error "Unexpected tree entry line"
+
+gitListDir :: MonadIO m => Text -> Maybe FilePath -> GitT m [TreeEntry]
+gitListDir rev maybePath = do
+    let path = fromMaybe "." maybePath
+    t <- git "ls-tree" [T.unpack rev, "--long", addTrailingPathSeparator path]
+    liftIO $ parseTree t
+
+data PathType = PTBlob | PTTree deriving Show
+
+parsePathType :: Text -> IO PathType
+parsePathType t =
+    case T.strip t of
+        "blob" -> pure PTBlob
+        "tree" -> pure PTTree
+        _ -> error "Path type is neither blob nor tree"
+
+gitGetPathType :: Text -> FilePath -> GitT IO PathType
+gitGetPathType rev path = do
+    t <- git "cat-file" ["-t", T.unpack rev ++ ":" ++ path]
+    liftIO $ parsePathType t
+
+parseBranches :: Text -> IO [Text]
+parseBranches t = traverse grab $ map T.words $ T.lines t
+    where
+    grab ["*", b] = pure b
+    grab _        = error "Unexpected branch line"
+
+gitGetFileContentByPath :: Text -> FilePath -> GitT IO Text
+gitGetFileContentByPath rev path =
+    git "cat-file" ["blob", T.unpack rev ++ ":" ++ path]
+
+gitGetFileContentByHash :: MonadIO m => ObjId -> GitT m Text
+gitGetFileContentByHash oid =
+    git "cat-file" ["blob", T.unpack $ renderObjId oid]
+
+gitListBranches :: MonadIO m => GitT m (Set Text)
+gitListBranches = do
+    t <- git "branch" ["--list"]
+    bs <- liftIO $ parseBranches t
+    return $ S.fromList bs
+
+gitListBranches' :: MonadIO m => GitT m (Map Text ObjId)
+gitListBranches' = do
+    t <- git "branch" ["--list"]
+    bs <- liftIO $ parseBranches t
+    hs <- gitGetObjectHashes $ map ("refs/heads/" <>) bs
+    return $ M.fromList $ zip bs hs
+
+parseTags :: Text -> IO [Text]
+parseTags t = traverse grab $ map T.words $ T.lines t
+    where
+    grab [tag] = pure tag
+    grab _     = error "Unexpected tag line"
+
+gitListTags :: MonadIO m => GitT m (Set Text)
+gitListTags = do
+    t <- git "tag" ["--list"]
+    ts <- liftIO $ parseTags t
+    return $ S.fromList ts
+
+gitListTags' :: MonadIO m => GitT m (Map Text ObjId)
+gitListTags' = do
+    t <- git "tag" ["--list"]
+    ts <- liftIO $ parseTags t
+    hs <- gitGetObjectHashes $ map ("refs/tags/" <>) ts
+    return $ M.fromList $ zip ts hs
+
+gitGetObjectHash :: MonadIO m => Text -> GitT m ObjId
+gitGetObjectHash object = do
+    hash <- T.strip <$> git "rev-parse" [T.unpack object]
+    liftIO $ parseObjId hash
+
+gitResolveHead :: MonadIO m => GitT m (Maybe ObjId)
+gitResolveHead = do
+    mh <-
+        either (const Nothing) Just <$>
+            runExceptT (T.strip <$> gitE "rev-parse" ["HEAD"])
+    liftIO $ for mh parseObjId
+
+gitGetObjectHashes :: MonadIO m => [Text] -> GitT m [ObjId]
+gitGetObjectHashes []      = pure []
+gitGetObjectHashes objects = do
+    hashes <- T.lines <$> git "rev-parse" (map T.unpack objects)
+    liftIO $ traverse parseObjId hashes
+
+data RevType = RTCommit | RTTag deriving Show
+
+parseRevType :: Text -> IO RevType
+parseRevType t =
+    case T.strip t of
+        "commit" -> pure RTCommit
+        "tag" -> pure RTTag
+        _ -> error "Rev type is neither commit nor tag"
+
+gitGetRevType :: MonadIO m => Text -> GitT m RevType
+gitGetRevType rev = do
+    t <- git "cat-file" ["-t", T.unpack rev]
+    liftIO $ parseRevType t
+
+parseCommits :: Text -> Maybe [VC.Commit]
+parseCommits input = do
+    input' <- T.stripPrefix "commit " input
+    let sections = T.splitOn "\ncommit " input'
+    traverse (parseSection . T.lines) sections
+    where
+    parseSection (hash : a : ad : c : cd : "" : title : "    " : rest) = do
+        a' <- T.strip <$> T.stripPrefix "Author:" a
+        author <- parsePerson a'
+        ad' <- T.strip <$> T.stripPrefix "AuthorDate:" ad
+        date <- parseDate ad'
+        committed <- do
+            c' <- T.strip <$> T.stripPrefix "Commit:" c
+            cd' <- T.strip <$> T.stripPrefix "CommitDate:" cd
+            if c' == a' && cd' == ad'
+                then pure Nothing
+                else Just $ (,) <$> parsePerson c' <*> parseDate cd'
+        title' <- T.stripPrefix "    " title
+        desc <- T.unlines <$> traverse (T.stripPrefix "    ") rest
+        return $ VC.Commit (author, date) committed hash title' desc
+        where
+        parseDate t =
+            parseTimeM False defaultTimeLocale rfc822DateFormat $ T.unpack t
+        parsePerson t = do
+            let (name, e) = T.break (== '<') t
+            (c, e') <- T.uncons e
+            (e'', c') <- T.unsnoc e'
+            guard $ c == '<'
+            guard $ c' == '>'
+            email <- emailAddress $ TE.encodeUtf8 e''
+            return $ VC.Author name email
+    parseSection _ = Nothing
+
+gitGetCommitInfos
+    :: MonadIO m
+    => Text -> [ObjId] -> Maybe Int -> Maybe Int -> GitT m [VC.Commit]
+gitGetCommitInfos refspec existingBranchHashes maybeLimit maybeOffset = do
+    let limit =
+            case maybeLimit of
+                Nothing -> []
+                Just n -> ["--max-count=" ++ show n]
+        offset =
+            case maybeOffset of
+                Nothing -> []
+                Just n -> ["--skip=" ++ show n]
+    t <- git "rev-list" $ offset ++ limit ++ ["--format=fuller", T.unpack refspec] ++ map (('^' :) . T.unpack . renderObjId) existingBranchHashes
+    case parseCommits t of
+        Just cs -> pure cs
+        Nothing -> error "parseCommits failed"
+
+gitGetCommitInfo :: MonadIO m => ObjId -> GitT m (VC.Commit)
+gitGetCommitInfo oid = do
+    cs <- gitGetCommitInfos (renderObjId oid) [] Nothing Nothing
+    case cs of
+        [c] -> pure c
+        _ -> error "gitGetCommitInfo: Expected a single commit"
+
+--gitDiff :: MonadIO m => Text -> GitT m [FileDelta]
+gitDiff :: MonadIO m => ObjId -> GitT m Text
+gitDiff commitOid =
+    let commitHash = renderObjId commitOid
+    in  git "diff"
+            ["--no-color", T.unpack $ commitHash <> "~", T.unpack commitHash]
+    {-
+    case parseDiff t of
+        Left e -> error $ "gitDiff: " ++ e
+        Right deltas -> pure deltas
+    -}
+
+gitGetCommitParents :: MonadIO m => ObjId -> GitT m [ObjId]
+gitGetCommitParents oid = do
+    hashes <- T.lines <$> git "rev-parse" [T.unpack $ renderObjId oid <> "^@"]
+    liftIO $ traverse parseObjId hashes
+
+-- | Given a tag's hash, if it's an annotated tag, return the commit hash it
+-- points to
+gitPeelTag :: MonadIO m => ObjId -> GitT m (Maybe ObjId)
+gitPeelTag tagOid = do
+    let tagHash = renderObjId tagOid
+    typ <- gitGetRevType tagHash
+    commitHash <- T.strip <$> git "rev-parse" [T.unpack $ tagHash <> "^{commit}"]
+    case (typ, commitHash == tagHash) of
+        (RTCommit, True) -> pure Nothing
+        (RTTag, False) -> liftIO $ Just <$> parseObjId commitHash
+        _ -> error "gitPeelTag unexpected situation"

src/Data/Patch/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -19,9 +19,7 @@
 -- changes are represented and encoded and stored internally. This module is
 -- merely a model for displaying a commit to a human viewer.
 module Data.Patch.Local
-    ( Hunk (..)
+    ( Author (..)
-    , Edit (..)
-    , Author (..)
     , Patch (..)
     )
 where
@@ -34,24 +32,6 @@ import Data.Word (Word32)
 import Data.Vector (Vector)
 import Text.Email.Validate (EmailAddress)
 
-data Hunk = Hunk
-    { hunkAddFirst   :: [Text]
-    , hunkRemoveAdd  :: [(NonEmpty Text, NonEmpty Text)]
-    , hunkRemoveLast :: [Text]
-    }
-
-data Edit
-    = AddTextFile FilePath Word32 [Text]
-    | AddBinaryFile FilePath Word32 Int64
-    | RemoveTextFile FilePath Word32 [Text]
-    | RemoveBinaryFile FilePath Word32 Int64
-    | MoveFile FilePath Word32 FilePath Word32
-    | ChmodFile FilePath Word32 Word32
-    | EditTextFile FilePath (Vector Text) (NonEmpty (Bool, Int, Hunk)) Word32 Word32
-    | EditBinaryFile FilePath Int64 Word32 Int64 Word32
-    | TextToBinary FilePath [Text] Word32 Int64 Word32
-    | BinaryToText FilePath Int64 Word32 [Text] Word32
-
 data Author = Author
     { authorName  :: Text
     , authorEmail :: EmailAddress
@@ -62,5 +42,5 @@ data Patch = Patch
     , patchCommitted   :: Maybe (Author, UTCTime)
     , patchTitle       :: Text
     , patchDescription :: Text
-    , patchDiff        :: [Edit]
+    , patchDiff        :: Text
     }

src/Data/VersionControl.hs

@@ -0,0 +1,94 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2022, 2024 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/>.
+ -}
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Data.VersionControl
+    ( Author (..)
+    , Commit (..)
+    )
+where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Crypto.Random
+import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Char
+import Data.Graph.Inductive.Graph
+import Data.Int
+import Data.Maybe
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Data.Time.Format
+import Data.Word
+import GHC.Generics
+import Network.HTTP.Client
+import Network.HTTP.Types.Header
+import System.Directory
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO
+import Text.Email.Aeson.Instances ()
+import Text.Email.Validate
+import Text.Read
+import Text.XML.Light
+import Yesod.Core.Content
+
+import qualified Data.Attoparsec.Text as A
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.DList as D
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.IO as TIO
+
+import Data.KeyFile
+import Network.FedURI
+
+import Control.Monad.Trans.Except.Local
+--import Data.DList.Local
+import Data.List.NonEmpty.Local
+
+data Author = Author
+    { authorName  :: Text
+    , authorEmail :: EmailAddress
+    }
+    deriving Generic
+
+instance FromJSON Author
+
+instance ToJSON Author
+
+data Commit = Commit
+    { commitWritten     :: (Author, UTCTime)
+    , commitCommitted   :: Maybe (Author, UTCTime)
+    , commitHash        :: Text
+    , commitTitle       :: Text
+    , commitDescription :: Text
+    }
+    deriving Generic
+
+instance FromJSON Commit
+
+instance ToJSON Commit

src/Database/Persist/Box/Internal.hs

@@ -137,6 +137,7 @@ import qualified Data.Aeson as A
 import qualified Data.Serialize as S
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import qualified Database.Persist.Quasi.Internal as PQI
 import qualified Database.Persist.Types as PT
 
 import qualified Database.Persist.Schema.TH as PS
@@ -188,7 +189,7 @@ modelFile = PS.modelFile ""
 
 -- | Declare datatypes and a 'PeristEntity' instance, from the entity
 -- definition produced by 'model' or 'modelFile'
-makeBox :: [PT.EntityDef] -> Q [Dec]
+makeBox :: [PQI.UnboundEntityDef] -> Q [Dec]
 makeBox [e] = PS.makeEntities [e]
 makeBox _   = fail "makeBox requires exactly 1 entity"
 

src/Database/Persist/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -81,6 +81,7 @@ insertBy'
     :: ( MonadIO m
        , PersistUniqueWrite backend
        , PersistRecordBackend record backend
+       , AtLeastOneUniqueKey record
        )
     => record -> ReaderT backend m (Either (Entity record) (Key record))
 insertBy' val = do
@@ -99,6 +100,7 @@ insertByEntity'
     :: ( MonadIO m
        , PersistUniqueWrite backend
        , PersistRecordBackend record backend
+       , AtLeastOneUniqueKey record
        )
     => record -> ReaderT backend m (Either (Entity record) (Entity record))
 insertByEntity' val = second (flip Entity val) <$> insertBy' val

src/Network/Git/Get.hs

@@ -0,0 +1,113 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - Written in 2016, 2024 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/>.
+ -}
+
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Helpers for getting git pack protocol elements.
+module Network.Git.Get
+    ( getFlushPkt
+    , getDataPkt
+    , getObjId
+    , getTaggedObjId
+    , getCapabilitiesFetch
+    , parseService
+    )
+where
+
+import Control.Monad (when)
+import Data.Binary.Get
+import Data.ByteString (ByteString)
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Char8 as BC
+
+import Network.Git.Types
+
+import Data.Binary.Get.Local
+import Data.Git.Local
+
+getFlushPkt :: Get ()
+getFlushPkt = requireByteString "0000"
+
+getDataPkt :: (Int -> Get a) -> Get a
+getDataPkt getPayload = do
+    pktLen <- getHex16
+    if  | pktLen == 0    -> fail "Expected regular pkt-line, got flush-pkt"
+        | pktLen > 65524 -> fail "pkt-len is above the maximum allowed"
+        | pktLen <= 4    -> fail "pkt-len is below the possible minimum"
+        | otherwise      ->
+            let len = pktLen - 4
+            in  isolate len $ getPayload len
+
+getObjId :: Get ObjId
+getObjId = do
+    h <- getByteString 40
+    case B16.decode h of
+        Left e -> fail $ "getObjId: B16.decode: " ++ e
+        Right b -> pure $ ObjId b
+
+getTaggedObjId :: ByteString -> Get ObjId
+getTaggedObjId tag = getDataPkt $ \ len ->
+    let baselen = B.length tag + 1 + 40
+    in  if len < baselen || baselen + 1 < len
+            then fail "Tagged obj id of unexpected length"
+            else do
+                requireByteString tag
+                requireSpace
+                oid <- getObjId
+                when (len == baselen + 1) requireNewline
+                return oid
+
+parseSharedCapability :: ByteString -> Maybe SharedCapability
+parseSharedCapability b
+    | b == "ofs-delta"          = Just CapOfsDelta
+    | b == "side-band-64k"      = Just CapSideBand64k
+    | "agent=" `B.isPrefixOf` b = Just $ CapAgent $ B.drop 6 b
+    | otherwise                 = Nothing
+
+parseFetchCapability :: ByteString -> Maybe FetchCapability
+parseFetchCapability b =
+    case b of
+        "multi_ack"                    -> Just CapMultiAck
+        "multi_ack_detailed"           -> Just CapMultiAckDetailed
+        "no-done"                      -> Just CapNoDone
+        "thin-pack"                    -> Just $ CapThinPack True
+        "no-thin"                      -> Just $ CapThinPack False
+        "side-band"                    -> Just CapSideBand
+        "shallow"                      -> Just CapShallow
+        "no-progres"                   -> Just CapNoProgress
+        "include-tag"                  -> Just CapIncludeTag
+        "allow-tip-sha1-in-want"       -> Just CapAllowTipSHA1InWant
+        "allow-reachable-sha1-in-want" -> Just CapAllowReachableSha1InWant
+        _                              -> Nothing
+
+getCapabilitiesFetch
+    :: Int -> Get (Either ByteString ([SharedCapability], [FetchCapability]))
+getCapabilitiesFetch n = do
+    b <- getByteString n
+    let loop [] scaps fcaps     = Right (scaps, fcaps)
+        loop (w:ws) scaps fcaps =
+            case (parseSharedCapability w, parseFetchCapability w) of
+                (Just sc, _)       -> loop ws (sc : scaps) fcaps
+                (Nothing, Just fc) -> loop ws scaps (fc : fcaps)
+                (Nothing, Nothing) -> Left b
+    return $ loop (BC.words b) [] []
+
+parseService :: ByteString -> Maybe Service
+parseService "git-upload-pack" = Just UploadPack
+parseService _                 = Nothing

src/Network/Git/Put.hs

@@ -0,0 +1,128 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - Written in 2016, 2024 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/>.
+ -}
+
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Helpers for putting git pack protocol elements.
+module Network.Git.Put
+    ( -- * Object ID
+      zeroObjId
+    , putObjId
+      -- * Capability
+    , serializeSharedCapability
+    , serializeFetchCapability
+    , putlenCapabilitiesFetch
+      -- * Pkt Line
+    , putFlushPkt
+    , putDataPkt
+      -- * Common Lines
+    , putTaggedObjId
+      -- * Service
+    , serializeService
+    )
+where
+
+import Control.Monad (when)
+import Data.Binary.Put
+import Data.Bool (bool)
+import Data.ByteString (ByteString)
+import Data.Foldable (traverse_)
+import Data.Monoid ((<>))
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base16 as B16
+
+import Network.Git.Types
+
+import Data.Binary.Put.Local
+import Data.Git.Local
+
+zeroObjId :: ObjId
+zeroObjId = ObjId $ B.replicate 20 0
+
+putObjId :: ObjId -> Put
+putObjId (ObjId ref) = putByteString $ B16.encode ref
+
+serializeSharedCapability :: SharedCapability -> ByteString
+serializeSharedCapability cap =
+    case cap of
+        CapOfsDelta    -> "ofs-delta"
+        CapSideBand64k -> "side-band-64k"
+        CapAgent agent -> "agent=" <> agent
+
+serializeFetchCapability :: FetchCapability -> ByteString
+serializeFetchCapability cap =
+    case cap of
+        CapMultiAck                 -> "multi_ack"
+        CapMultiAckDetailed         -> "multi_ack_detailed"
+        CapNoDone                   -> "no-done"
+        CapThinPack True            -> "thin-pack"
+        CapThinPack False           -> "no-thin"
+        CapSideBand                 -> "side-band"
+        CapShallow                  -> "shallow"
+        CapNoProgress               -> "no-progres"
+        CapIncludeTag               -> "include-tag"
+        CapAllowTipSHA1InWant       -> "allow-tip-sha1-in-want"
+        CapAllowReachableSha1InWant -> "allow-reachable-sha1-in-want"
+
+putlenCapabilitiesFetch
+    :: [SharedCapability] -> [FetchCapability] -> (Put, Int)
+putlenCapabilitiesFetch scaps fcaps =
+    let ss = map serializeSharedCapability scaps
+        fs = map serializeFetchCapability fcaps
+        slens = map B.length ss
+        flens = map B.length fs
+        foldLen = foldr $ \ x s -> x + 1 + s
+        len = case (slens, flens) of
+            ([],   [])   -> 0
+            (n:ns, [])   -> foldLen n ns
+            ([],   m:ms) -> foldLen m ms
+            (n:ns, m:ms) -> foldLen n ns + 1 + foldLen m ms
+        putCaps [] = return ()
+        putCaps (b:bs) = do
+            putByteString b
+            traverse_ (\ c -> putSpace >> putByteString c) bs
+        put = case (null ss, null fs) of
+            (True,  True)  -> return ()
+            (False, True)  -> putCaps ss
+            (True,  False) -> putCaps fs
+            (False, False) -> putCaps ss >> putSpace >> putCaps fs
+    in  (put, len)
+
+putFlushPkt :: Put
+putFlushPkt = putByteString "0000" >> flush
+
+putDataPkt :: Bool -> Int -> Put -> Put
+putDataPkt addLF payloadLen payloadPut =
+    let len = bool id (+1) addLF $ payloadLen
+    in  if  | len == 0    -> error "tried to put an empty pkt-line"
+            | len > 65520 -> error "payload bigger than maximal pkt-len"
+            | otherwise   -> do
+                putHex16 $ toEnum $ len + 4
+                payloadPut
+                when addLF $ putLF
+
+putTaggedObjId :: ByteString -> ObjId -> Put
+putTaggedObjId tag oid =
+    let len = B.length tag + 1 + 40
+    in  putDataPkt True len $ do
+            putByteString tag
+            putSpace
+            putObjId oid
+
+serializeService :: Service -> ByteString
+serializeService UploadPack = "git-upload-pack"

src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs

@@ -0,0 +1,229 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - Written in 2016, 2024 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/>.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Git.Transport.HTTP.Fetch.RefDiscovery
+    ( -- * Types
+      SymRef (..)
+    , RefAd (..)
+    , RefDiscover (..)
+      -- * Put
+    , putService -- TODO temp hack, let Vervis access this function
+    , putRefDiscover
+    , serializeRefDiscover
+      -- * Build
+    , buildRefDiscover'
+    )
+where
+
+import Control.Monad (when)
+import Data.Bifunctor
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.Monoid ((<>))
+import Data.Version (showVersion)
+
+import qualified Data.ByteString as B (length)
+import qualified Data.ByteString.Char8 as BC (pack)
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.Map as M
+import qualified Data.Text.Encoding as TE
+
+import Data.Binary.Put.Local
+import Data.Git.Local
+import Network.Git.Put
+import Network.Git.Types
+
+-------------------------------------------------------------------------------
+-- Types
+-------------------------------------------------------------------------------
+
+-- | A symbolic reference which refers to an object.
+data SymRef
+    -- | The current branch.
+    = SymRefHead
+    -- | A branch with the given name.
+    | SymRefBranch ByteString
+    -- | A tag with the given name, and whether it's a peeled tag.
+    --
+    -- But what's a peeled tag?
+    --
+    -- In Git, there are lightweight tags and annotated tags. A lightweight tag
+    -- is just a named reference to a commit. An annotated tag is a Git object
+    -- with a date, an author, its own SHA1, optional GPG signature and a
+    -- pointer to a commit.
+    --
+    -- For a given tag symref /refs/tags/T which refers to a tag object, i.e.
+    -- an annotated tag, its peeled tag /refs/tags/T^{} refers to the commit to
+    -- which T points. But you won't find the peeled tag in the actual Git
+    -- repo: It's just a way for us to advertise the tagged commit in the Git
+    -- protocol.
+    | SymRefTag ByteString Bool
+    -- | Something else.
+    -- | SymRefOther
+
+-- | A ref advertisement. Used by one side to tell the other which refs it has
+-- locally.
+data RefAd = RefAd
+    { refAdId   :: ObjId
+    , refAdSym  :: SymRef
+    , refAdName :: ByteString
+    }
+
+-- | A message which allows the client to discover what the server side has and
+-- supports.
+data RefDiscover = RefDiscover
+    { rdService    :: Service
+    , rdAds        :: [RefAd]
+    , rdSharedCaps :: [SharedCapability]
+    , rdFetchCaps  :: [FetchCapability]
+    }
+
+-------------------------------------------------------------------------------
+-- Put
+-------------------------------------------------------------------------------
+
+_putSymRef :: SymRef -> Put
+_putSymRef SymRefHead = putByteString "HEAD"
+_putSymRef (SymRefBranch b) = do
+    putByteString "refs/heads/"
+    putByteString b
+_putSymRef (SymRefTag b p) = do
+    putByteString "refs/tags/"
+    putByteString b
+    when p $ putByteString "^{}"
+
+putRefAd :: RefAd -> Put
+putRefAd ad = do
+    putObjId $ refAdId ad
+    putSpace
+    putByteString $ refAdName ad
+
+lenRefAd :: RefAd -> Int
+lenRefAd ad = 40 + 1 + B.length (refAdName ad)
+
+putRefAdLine :: RefAd -> Put
+putRefAdLine ad = putDataPkt True (lenRefAd ad) $ putRefAd ad
+
+putRefAdCapaLine :: RefAd -> [SharedCapability] -> [FetchCapability] -> Put
+putRefAdCapaLine ad scaps fcaps =
+    let (putCaps, lenCaps) = putlenCapabilitiesFetch scaps fcaps
+    in  putDataPkt True (lenRefAd ad + 1 + lenCaps) $ do
+            putRefAd ad
+            putNull
+            putCaps
+
+putDummyRefAdCapaLine :: [SharedCapability] -> [FetchCapability] -> Put
+putDummyRefAdCapaLine = putRefAdCapaLine $ RefAd
+    { refAdId   = zeroObjId
+    , refAdSym  = SymRefHead
+    , refAdName = "capabilities^{}"
+    }
+
+-- | Put a service identification line. This is used only in HTTP smart mode,
+-- at the beginning of the response content, right before the refs themselves.
+--
+-- (2016-04-22) According to git source docs, the service line is a single
+-- pkt-line, followed by refs, and then finally comes a flush-pkt. But in
+-- @http-backend.c@, there's an additional flush-pkt between the service line
+-- and the refs. The git HTTP transport client side requires that flush-pkt and
+-- fails without it. I went to its code, in @remote-curl.c@, and it says there
+-- is room for metadata lines between the service line and the flush-pkt.
+-- Currently there aren't any known ones, so it just skips lines until the
+-- flush-pkt.
+--
+-- For that reason, the flush-pkt must be there, otherwise git client side
+-- simply skips all the refs and fails to complete the ref discovery step.
+--
+-- So to make things work, the code here puts that additional flush-pkt too.
+putService :: Service -> Put
+putService serv = do
+    let prefix = "# service="
+        servB = serializeService serv
+    putDataPkt True (B.length prefix + B.length servB) $ do
+        putByteString prefix
+        putByteString servB
+    putFlushPkt
+
+putRefDiscover :: RefDiscover -> Put
+putRefDiscover (RefDiscover serv [] scaps fcaps) = do
+    putService serv
+    putDummyRefAdCapaLine scaps fcaps
+    putFlushPkt
+putRefDiscover (RefDiscover serv (a:as) scaps fcaps) = do
+    putService serv
+    putRefAdCapaLine a scaps fcaps
+    traverse_ putRefAdLine as
+    putFlushPkt
+
+serializeRefDiscover :: RefDiscover -> BL.ByteString
+serializeRefDiscover = runPut . putRefDiscover
+
+-------------------------------------------------------------------------------
+-- Build
+-------------------------------------------------------------------------------
+
+buildRefDiscover' :: Service -> GitT IO RefDiscover
+buildRefDiscover' serv = do
+    mhead <- gitResolveHead
+    branches <- map (first TE.encodeUtf8) . M.toList <$> gitListBranches'
+    tags <- map (first TE.encodeUtf8) . M.toList <$> gitListTags'
+    let peel (name, oid) = do
+            moid <- gitPeelTag oid
+            return (name, oid, moid)
+    tagsPeels <- traverse peel tags
+    let head2ad oid = RefAd
+            { refAdId   = oid
+            , refAdSym  = SymRefHead
+            , refAdName = "HEAD"
+            }
+        branch2ad (name, oid) = RefAd
+            { refAdId   = oid
+            , refAdSym  = SymRefBranch name
+            , refAdName = "refs/heads/" <> name
+            }
+        tag2ad name oid = RefAd
+            { refAdId   = oid
+            , refAdSym  = SymRefTag name False
+            , refAdName = "refs/tags/" <> name
+            }
+        peel2ad name oid = RefAd
+            { refAdId   = oid
+            , refAdSym  = SymRefTag name True
+            , refAdName = "refs/tags/" <> name <> "^{}"
+            }
+        addTag (name, oid, mpeel) l =
+            let l' = case mpeel of
+                    Nothing -> l
+                    Just p  -> peel2ad name p : l
+            in  tag2ad name oid : l'
+    return RefDiscover
+        { rdService = serv
+        , rdAds =
+            let l = map branch2ad branches ++ foldr addTag [] tagsPeels
+            in  case mhead of
+                    Nothing -> l
+                    Just h  -> head2ad h : l
+        , rdSharedCaps = [CapAgent "vervis/0.1"]
+        , rdFetchCaps = []
+        }
+
+--buildRefDiscover :: FetchT m RefDiscover
+--buildRefDiscover = do
+--    git <- liftGit ask
+--    liftIO $ buildRefDiscover' git

src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs

@@ -0,0 +1,84 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - Written in 2016, 2024 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/>.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Git.Transport.HTTP.Fetch.UploadRequest
+    ( -- * Types
+      UploadRequest (..)
+      -- * Get
+    , getUploadRequest
+    )
+where
+
+import Control.Applicative (many)
+import Data.Binary.Get
+
+import qualified Data.ByteString.Char8 as BC (unpack)
+
+import Network.Git.Get
+import Network.Git.Types
+
+import Data.Binary.Get.Local
+import Data.Git.Local
+
+-------------------------------------------------------------------------------
+-- Types
+-------------------------------------------------------------------------------
+
+data UploadRequest = UploadRequest
+    { urSharedCaps :: [SharedCapability]
+    , urFetchCaps  :: [FetchCapability]
+    , urWants      :: [ObjId]
+    }
+
+-------------------------------------------------------------------------------
+-- Get
+-------------------------------------------------------------------------------
+
+getFirstWant :: Get ([SharedCapability], [FetchCapability], ObjId)
+getFirstWant = getDataPkt $ \ len -> do
+    requireByteString "want"
+    requireSpace
+    oid <- getObjId
+    ecaps <- getCapabilitiesFetch $ len - 45
+    case ecaps of
+        Left b -> fail $ "Unrecognized capability: " ++ BC.unpack b
+        Right (scaps, fcaps) -> return (scaps, fcaps, oid)
+
+getWants :: Get ([SharedCapability], [FetchCapability], [ObjId])
+getWants = do
+    (scaps, fcaps, oid) <- getFirstWant
+    oids <- many $ getTaggedObjId "want"
+    return (scaps, fcaps, oid:oids)
+
+getDone :: Get ()
+getDone = getDataPkt $ \ len ->
+    case len of
+        4 -> requireByteString "done"
+        5 -> requireByteString "done" >> requireNewline
+        _ -> fail "Invalid length for a \"done\" pkt-line"
+
+getUploadRequest :: Get UploadRequest
+getUploadRequest = do
+    (scaps, fcaps, oids) <- getWants
+    getFlushPkt
+    getDone
+    return UploadRequest
+        { urSharedCaps = scaps
+        , urFetchCaps  = fcaps
+        , urWants      = oids
+        }

src/Network/Git/Types.hs

@@ -0,0 +1,110 @@
+{- This file is part of Vervis.
+ - Originally from the hit-network library.
+ -
+ - 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 Network.Git.Types
+    ( -- * Mode helper types
+      SideBandMode (..)
+    , AckMode (..)
+      -- * Capability lists
+    , SharedCapability (..)
+    , FetchCapability (..)
+    , PushCapability (..)
+      -- * Capability mode
+    , SharedCapabilityMode (..)
+    , PushCapabilityMode (..)
+    , FetchCapabilityMode (..)
+      -- * Other
+    , Service (..)
+    )
+where
+
+import Data.ByteString (ByteString)
+
+-- I want to explain how the capability based types are supposed to work.
+-- Basically what we have here is:
+--
+-- * A record to fill and use during communication
+-- * Sum types which specify capability declarations
+--
+-- The idea is that we run like this:
+--
+-- (1) Start with the default record and a record expressing what is supported
+-- (2) Send the differences
+-- (3) Receive and parse a list of values of the sum type
+-- (4) Go over the list and update the record
+-- (5) Finally we have a record to use for the rest of the protocol
+--
+-- Since right now we're just on fetch and the capability list is hardcoded in
+-- 'buildRefDiscover', the changes will be:
+--
+-- (1) Have 2 fields for caps, one for shared and one for fetch-specific
+-- (2) Have functions for Putting caps
+-- (3) Have the 2 fields hardcoded to 2 empty lists for now
+
+data SideBandMode = NoSideBand | SideBand | SideBand64k
+
+data AckMode = SingleAck | MultiAck | MultiAckDetailed
+
+data SharedCapability
+    = CapOfsDelta
+    | CapSideBand64k
+    | CapAgent ByteString
+
+data FetchCapability
+    = CapMultiAck
+    | CapMultiAckDetailed
+    | CapNoDone
+    | CapThinPack Bool
+    | CapSideBand
+    | CapShallow
+    | CapNoProgress
+    | CapIncludeTag
+    | CapAllowTipSHA1InWant
+    | CapAllowReachableSha1InWant
+
+data PushCapability
+    = CapAtomic
+    | CapReportStatus
+    | CapDeleteRefs
+    | CapQuiet
+    | CapPushCert ByteString
+
+data SharedCapabilityMode = SharedCapabilityMode
+    { scOfsDelta :: Bool
+    , scSideBand :: SideBandMode
+    , scAgent    :: ByteString
+    }
+
+data FetchCapabilityMode = FetchCapabilityMode
+    { fcMultiAck                :: AckMode
+    , fcNoDone                  :: Bool
+    , fcThinPack                :: Bool
+    , fcShallow                 :: Bool
+    , fcNoProgress              :: Bool
+    , fcIncludeTag              :: Bool
+    , fcAllowTipShaInWant       :: Bool
+    , fcAllowReachableShaInWant :: Bool
+    }
+
+data PushCapabilityMode = PushCapabilityMode
+    { pcAtomic       :: Bool
+    , pcReportStatus :: Bool
+    , pcDeleteRefs   :: Bool
+    , pcQuiet        :: Bool
+    , pcPushCert     :: Maybe ByteString
+    }
+
+data Service = UploadPack

src/Vervis/Actor/Loom.hs

@@ -36,6 +36,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.Text (Text)
 import Data.These
+import Data.These.Combinators
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist

src/Vervis/Application.hs

@@ -46,7 +46,6 @@ import Control.Monad.Trans.Reader
 import Data.Bifunctor
 import Data.Default.Class
 import Data.Foldable
-import Data.Git.Repository (isRepo)
 import Data.List
 import Data.List.NonEmpty (nonEmpty)
 import Data.Maybe
@@ -56,8 +55,6 @@ import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist.Postgresql
-import Graphics.SVGFonts.Fonts (lin2)
-import Graphics.SVGFonts.ReadFont (loadFont)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
@@ -102,6 +99,7 @@ import Yesod.Hashids
 import Yesod.MonadSite
 
 import Control.Concurrent.Local
+import Data.Git.Local (isGitRepo)
 import Data.List.NonEmpty.Local
 import Web.Hashids.Local
 
@@ -181,11 +179,6 @@ makeFoundation appSettings = do
             Nothing -> return Nothing
             Just _  -> Just <$> newChan
 
-    appSvgFont <-
-        if appLoadFontFromLibData appSettings
-            then lin2
-            else loadFont "data/LinLibertineCut.svg"
-
     appActorKeys <-
         if appPerActorKeys appSettings
             then pure Nothing
@@ -318,7 +311,7 @@ makeFoundation appSettings = do
                 error $ "Non-dir file: " ++ path
         detectVcs path = liftIO $ do
             darcs <- doesDirectoryExist $ path </> "_darcs"
-            git <- isRepo $ fromString path
+            git <- isGitRepo $ fromString path
             return $
                 case (darcs, git) of
                     (True, False) -> Right VCSDarcs

src/Vervis/ChangeFeed.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2020, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -39,6 +39,7 @@ changeEntry rp le = FeedEntry
     , feedEntryTitle     = leMessage le
     , feedEntryContent   = mempty
     , feedEntryEnclosure = Nothing
+    , feedEntryCategories = []
     }
 
 changeFeed

src/Vervis/Darcs.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -29,6 +29,7 @@ where
 import Prelude hiding (lookup)
 
 import Control.Applicative ((<|>))
+import Control.Exception.Base
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except
@@ -59,6 +60,7 @@ import System.Process.Typed
 import Text.Email.Validate (emailAddress)
 
 import qualified Data.Attoparsec.Text as A
+import qualified Data.Attoparsec.ByteString.Char8 as AB
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Base16 as B16 (encode, decode)
@@ -112,7 +114,7 @@ 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 :: [(Name, TreeItem IO)] -> IO (Maybe (Text, Text))
 findReadme pairs =
     case F.find (isReadme . nameToText . fst) pairs of
         Nothing           -> return Nothing
@@ -120,13 +122,15 @@ findReadme pairs =
             case item of
                 File (Blob load _hash) -> do
                     content <- load
-                    return $ Just (nameToText name, content)
+                    content' <- either throwIO return $ TE.decodeUtf8' $ BL.toStrict content
+                    return $ Just (nameToText name, content')
                 _ -> return Nothing
 
-itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView BL.ByteString)
+itemToSourceView :: EntryName -> TreeItem IO -> IO (SourceView Text)
 itemToSourceView name (File (Blob load _hash)) = do
     content <- load
-    return $ SourceFile $ FileView name content
+    content' <- either throwIO return $ TE.decodeUtf8' $ BL.toStrict content
+    return $ SourceFile $ FileView name content'
 itemToSourceView name (SubTree tree) = do
     let items = listImmediate tree
     mreadme <- findReadme items
@@ -261,6 +265,7 @@ lastChange path now = fmap maybeRight $ runExceptT $ do
             FriendlyConvert $
             now `diffUTCTime` piTime pi
 
+{-
 data Change
     = AddFile FilePath
     | AddDir FilePath
@@ -311,6 +316,7 @@ joinHunks =
     lineNumber (n, _, _) = n
     lines (_, rs, as) = (map decodeUtf8 rs, map decodeUtf8 as)
     mkHunk (line, (adds, pairs, rems)) = (False, line, Hunk adds pairs rems)
+-}
 
 -- | Read patch content, both metadata and the actual diff, from a given Darcs
 -- repository. Preconditions:
@@ -324,12 +330,13 @@ joinHunks =
 --   repo with the given hash, 'Nothing' is returned.
 readPatch :: FilePath -> Text -> IO (Maybe DP.Patch)
 readPatch path hash = handle $ runExceptT $ do
-    let pih = PatchInfoHash $ fst $ B16.decode $ encodeUtf8 hash
+    pih <- except $ second PatchInfoHash $ B16.decode $ encodeUtf8 hash
     li <- ExceptT $ readLatestInventory path latestInventoryAllP
     mp <- loop pih (liPatches li) (fst <$> liPrevTag li)
     for mp $ \ (pi, pch) -> do
-        (_pir, changes) <-
+        changes <-
-            ExceptT $ readCompressedPatch path pch (P.patch <* A.endOfInput)
+            ExceptT $ readCompressedPatch path pch AB.takeByteString -- (P.patch <* A.endOfInput)
+        changes' <- either (throwE . displayException) return $ TE.decodeUtf8' changes
         (an, ae) <-
             ExceptT . pure $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi
         return DP.Patch
@@ -343,12 +350,14 @@ readPatch path hash = handle $ runExceptT $ do
             , patchCommitted   = Nothing
             , patchTitle       = piTitle pi
             , patchDescription = fromMaybe "" $ piDescription pi
-            , patchDiff        =
+            , patchDiff        = changes'
+                {-
                 let (befores, pairs, afters) = groupEithers $ map splitChange changes
                     befores' = mkedit befores
                     pairs' = map (bimap arrangeHunks mkedit) pairs
                     afters' = arrangeHunks <$> nonEmpty afters
                 in  befores' ++ concatMap (NE.toList . uncurry (<>)) pairs' ++ maybe [] NE.toList afters'
+                -}
             }
   where
     handle a = do
@@ -374,20 +383,6 @@ readPatch path hash = handle $ runExceptT $ do
         <*  A.skip (== '<')
         <*> (A.takeWhile1 (/= '>') >>= email)
         <*  A.skip (== '>')
-    arrangeHunks = NE.map (mkhunk . second joinHunks) . groupHunksByFile
-        where
-        mkhunk (file, hunks) =
-            EditTextFile (T.unpack $ decodeUtf8 file) V.empty hunks 0 0
-    mkedit = fmap mkedit'
-        where
-        mkedit' (AddFile fp)               = AddTextFile fp 0 []
-        mkedit' (AddDir fp)                = AddTextFile fp 0 []
-        mkedit' (Move old new)             = MoveFile old 0 new 0
-        mkedit' (RemoveFile fp)            = RemoveTextFile fp 0 []
-        mkedit' (RemoveDir fp)             = RemoveTextFile fp 0 []
-        mkedit' (Replace fp regex old new) = AddTextFile "Replace" 0 [T.concat ["replace ", T.pack fp, " ", regex, " ", old, " ", new]]
-        mkedit' (Binary fp old new)        = EditBinaryFile fp (fromIntegral $ B.length old) 0 (fromIntegral $ B.length new) 0
-        mkedit' (Pref pref old new)        = AddTextFile "Pref" 0 [T.concat ["changepref ", pref, " ", old, " ", new]]
 
 writePostApplyHooks :: WorkerDB ()
 writePostApplyHooks = do

src/Vervis/Foundation.hs

@@ -35,7 +35,6 @@ import Data.Traversable
 import Data.Vector (Vector)
 import Database.Persist.Postgresql
 import Database.Persist.Sql (ConnectionPool)
-import Graphics.SVGFonts.ReadFont (PreparedFont)
 import Network.HTTP.Client (Manager, HasHttpManager (..))
 import Network.HTTP.Types.Header
 import Text.Shakespeare.Text (textFile)
@@ -127,7 +126,7 @@ data App = App
     , appHttpManager  :: Manager
     , appLogger       :: Logger
     , appMailQueue    :: Maybe (Chan (MailRecipe App))
-    , appSvgFont      :: PreparedFont Double
+    --, appSvgFont      :: PreparedFont Double
     , appActorKeys    :: Maybe (TVar (ActorKey, ActorKey, Bool))
     , appInstanceMutex :: InstanceMutex
     , appCapSignKey   :: AccessTokenSecretKey

src/Vervis/Git.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -17,9 +17,7 @@
 module Vervis.Git
     ( readSourceView
     , readChangesView
-    , listRefs
     , readPatch
-    --, lastCommitTime
     , writePostReceiveHooks
     , generateGitPatches
     , canApplyGitPatches
@@ -29,49 +27,39 @@ where
 
 import Control.Arrow ((***))
 import Control.Exception.Base
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except
-import Patience (diff, Item (..))
+import Data.Bifunctor
 import Data.Foldable
-import Data.Git.Diff
-import Data.Git.Graph
-import Data.Git.Harder
-import Data.Git.Monad
-import Data.Git.Ref (SHA1, fromHex, toHex)
-import Data.Git.Storage (getObject_)
-import Data.Git.Storage.Object (Object (..))
-import Data.Git.Types hiding (ObjectType (..))
-import Data.Graph.Inductive.Graph (noNodes)
-import Data.Graph.Inductive.Query.Topsort
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.Maybe
 import Data.Set (Set)
 import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Time.Calendar (Day (..))
-import Data.Time.Clock (UTCTime (..))
+import Data.Time.Clock
-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Data.Traversable (for)
 import Data.Word (Word32)
 import Database.Persist
 import System.Exit
 import System.FilePath
-import System.Hourglass (timeCurrent)
 import System.Process.Typed
+--import Text.Diff.Parse
+--import Text.Diff.Parse.Types
 import Text.Email.Validate (emailAddress)
-import Time.Types (Elapsed (..), Seconds (..))
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.DList as D (DList, empty, snoc, toList)
-import qualified Data.Git as G
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as S (member, mapMonotonic, toList)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Encoding.Error as TE (lenientDecode)
-import qualified Data.Vector as V (fromList)
+import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
 
 import Network.FedURI
@@ -79,13 +67,15 @@ import Yesod.ActivityPub
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Data.VersionControl as VC
+
 import Control.Monad.Trans.Except.Local
 import Data.ByteString.Char8.Local (takeLine)
-import Data.DList.Local
+--import Data.DList.Local
 import Data.EventTime.Local
 import Data.Git.Local
 import Data.List.Local
-import Data.Patch.Local hiding (Patch)
+import Data.Time.Clock.Local
 import System.Process.Typed.Local
 
 import qualified Data.Patch.Local as P
@@ -101,254 +91,137 @@ import Vervis.Readme
 import Vervis.Settings
 import Vervis.SourceTree
 
-matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
+matchReadme (TreeEntry _ (TETFile _) _ name) = isReadme name
-matchReadme (_, _, name, EntObjBlob) = isReadme name
 matchReadme _                                = False
 
 -- | Find a README file in a directory. Return the filename and the file
 -- content.
-findReadme :: Git SHA1 -> TreeRows -> IO (Maybe (Text, BL.ByteString))
+findReadme :: [TreeEntry] -> GitT IO (Maybe (Text, Text))
-findReadme git rows =
+findReadme entries =
-    case find matchReadme rows of
+    case find matchReadme entries of
         Nothing -> return Nothing
-        Just (_perm, oid, name, _etype) -> do
+        Just (TreeEntry _ _ hash name) ->
-            obj <- getObject_ git (unObjId oid) True
+            Just . (name,) <$> gitGetFileContentByHash hash
-            return $ case obj of
-                ObjBlob b -> Just (name, blobGetContent b)
-                _         -> Nothing
 
-matchType :: EntObjType -> EntryType
+matchType (TETFile _) = TypeBlob
-matchType EntObjBlob = TypeBlob
+matchType TETDir      = TypeTree
-matchType EntObjTree = TypeTree
 
-rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry
+rowToEntry (TreeEntry _ typ _ name) = DirEntry (matchType typ) name
-rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name
 
 loadSourceView
-    :: Git SHA1
+    :: Text
-    -> Text
     -> [Text]
-    -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
+    -> GitT IO (Set Text, Set Text, Maybe (SourceView Text))
-loadSourceView git refT dir = do
+loadSourceView ref dir = do
-    branches <- G.branchList git
+    let invalid t = T.null t || t == "." || t == ".." || T.any (== '/') t
-    tags <- G.tagList git
+    when (any invalid dir) $
-    let refS = T.unpack refT
+        error $ "loadSourceView invalid dir: " ++ show dir
-        refN = RefName refS
+    branches <- gitListBranches
+    tags <- gitListTags
     msv <-
         if null branches
             then return $ Just $ SourceDir $ DirectoryView Nothing [] Nothing
-            else if refN `S.member` branches || refN `S.member` tags
+            else if ref `S.member` branches || ref `S.member` tags
-                then do
+                then Just <$> do
-                    tipOid <- resolveName git refS
+                    let dir' =
-                    mtree <- G.resolveTreeish git $ unObjId tipOid
+                            if null dir
-                    for mtree $ \ tree -> do
+                                then Nothing
-                        let dir' = map (G.entName . encodeUtf8) dir
+                                else Just $ T.unpack $ T.intercalate "/" dir
-                        view <- viewPath git tree dir'
+                    pt <-
-                        case view of
+                        case dir' of
-                            RootView rows -> do
+                            Nothing -> pure PTTree
-                                mreadme <- findReadme git rows
+                            Just s -> gitGetPathType ref s
-                                let ents = map rowToEntry rows
+                    case pt of
-                                return $ SourceDir $
+                        PTTree -> do
-                                    DirectoryView Nothing ents mreadme
+                            entries <- gitListDir ref dir'
-                            TreeView name _ rows -> do
+                            mreadme <- findReadme entries
-                                mreadme <- findReadme git rows
+                            let ents = map rowToEntry entries
-                                let ents = map rowToEntry rows
+                                mname =
-                                return $ SourceDir $
+                                    if isNothing dir'
-                                    DirectoryView (Just name) ents mreadme
+                                        then Nothing
-                            BlobView name _ body ->
+                                        else Just $ last dir
+                            return $
+                                SourceDir $ DirectoryView mname ents mreadme
+                        PTBlob -> do
+                            (name, path) <-
+                                case dir' of
+                                    Nothing -> error "loadSourceView: Top-level is expected to be a dir, not a file"
+                                    Just s -> pure (last dir, s)
+                            body <- gitGetFileContentByPath ref path
                             return $ SourceFile $ FileView name body
                 else return Nothing
     return (branches, tags, msv)
 
 readSourceView
-    :: FilePath
+    :: Text
-    -- ^ Repository path
-    -> Text
     -- ^ Name of branch or tag
     -> [Text]
     -- ^ Path in the source tree pointing to a file or directory
-    -> IO (Set Text, Set Text, Maybe (SourceView Widget))
+    -> GitT IO (Set Text, Set Text, Maybe (SourceView Widget))
     -- ^ Branches, tags, view of the selected item
-readSourceView path ref dir = do
+readSourceView ref dir = do
-    (bs, ts, msv) <-
+    (bs, ts, msv) <- loadSourceView ref dir
-        G.withRepo (fromString path) $ \ git -> loadSourceView git ref dir
+    return (bs, ts, renderSources dir <$> msv)
-    let toTexts = S.mapMonotonic $ T.pack . refNameRaw
-    return (toTexts bs, toTexts ts, renderSources dir <$> msv)
 
 readChangesView
-    :: FilePath
+    :: Text
-    -- ^ Repository path
-    -> Text
     -- ^ Name of branch or tag
     -> Int
     -- ^ Offset, i.e. latest commits to skip
     -> Int
     -- ^ Limit, i.e. how many latest commits to take after the offset
-    -> IO (Int, [LogEntry])
+    -> GitT IO (Int, [LogEntry])
     -- ^ Total number of ref's changes, and view of selected ref's change log
-readChangesView path ref off lim = G.withRepo (fromString path) $ \ git -> do
+readChangesView ref off lim = do
-    oid <- resolveName git $ T.unpack ref
+    commits <- gitGetCommitInfos ref [] Nothing Nothing
-    graph <- loadCommitGraphPT git [oid]
+    now <- liftIO getCurrentTime
-    let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
+    let commits' = take lim $ drop off commits
-        nodes = case mnodes of
+        mkrow commit = LogEntry
-            Nothing -> error "commit graph contains a cycle"
+            { leAuthor  = VC.authorName $ fst $ VC.commitWritten commit
-            Just ns -> ns
+            , leHash    = VC.commitHash commit
-        pairs = D.toList $ fmap (nodeLabel graph) nodes
+            , leMessage = VC.commitTitle commit
-        pairs' = take lim $ drop off pairs
-        toText = TE.decodeUtf8With TE.lenientDecode
-    Elapsed now <- timeCurrent
-    let mkrow oid commit = LogEntry
-            { leAuthor  = toText $ personName $ commitAuthor commit
-            , leHash    = toText $ toHex $ unObjId oid
-            , leMessage = toText $ takeLine $ commitMessage commit
             , leTime    =
-                ( utc t
+                let t = snd $ VC.commitWritten commit
-                , intervalToEventTime $
+                in  ( t
-                  FriendlyConvert $
+                    , intervalToEventTime $ FriendlyConvert $
-                  now - t
+                        now `diffUTCTime` t
                     )
             }
-            where
+    return (length commits, map mkrow commits')
-            Elapsed t = gitTimeUTC $ personTime $ commitAuthor commit
-            utc (Seconds i) = posixSecondsToUTCTime $ fromIntegral i
-    return (noNodes graph, map (uncurry mkrow) pairs')
-
-listRefs :: FilePath -> IO (Set Text, Set Text)
-listRefs path = G.withRepo (fromString path) $ \ git ->
-    (,) <$> listBranches git <*> listTags git
-
-patch :: [Edit] -> Commit SHA1 -> P.Patch
-patch edits c = P.Patch
-    { patchWritten     = makeAuthor $ commitAuthor c
-    , patchCommitted   =
-        if commitAuthor c == commitCommitter c
-            then Nothing
-            else Just $ makeAuthor $ commitCommitter c
-    , patchTitle       = title
-    , patchDescription = desc
-    , patchDiff        = edits
-    }
-    where
-    split t =
-        let (l, r) = T.break (\ c -> c == '\n' || c == '\r') t
-        in  (T.strip l, T.strip r)
-    (title, desc) = split $ decodeUtf8 $ commitMessage c
-
-    makeAuthor (G.Person name email time) =
-        ( Author
-            { authorName  = decodeUtf8 name
-            , authorEmail =
-                case emailAddress email of
-                    Nothing ->
-                        error $ "Invalid email " ++ T.unpack (decodeUtf8 email)
-                    Just e  -> e
-            }
-        , let Elapsed (Seconds t) = gitTimeUTC time
-          in  posixSecondsToUTCTime $ fromIntegral t
-        )
-
-ep2fp :: EntPath -> FilePath
-ep2fp = T.unpack . decodeUtf8 . B.intercalate "/" . map getEntNameBytes
-
-unModePerm :: ModePerm -> Word32
-unModePerm (ModePerm w) = w
-
-data Line = Line
-    { lineNumber :: Int
-    , lineText   :: Text
-    }
-
-instance Eq Line where
-    Line _ t == Line _ s = t == s
-
-instance Ord Line where
-    Line _ t `compare` Line _ s = t `compare` s
-
-mkdiff :: [Text] -> [Text] -> [(Bool, Int, Hunk)]
-mkdiff old new =
-    let eitherOldNew (Old a)    = Just $ Left a
-        eitherOldNew (New a)    = Just $ Right a
-        eitherOldNew (Both _ _) = Nothing
-        stripLineNumber = fmap lineText
-        mkhunk' (adds, pairs, rems) = Hunk
-            { hunkAddFirst   = stripLineNumber adds
-            , hunkRemoveAdd  = map (stripLineNumber *** stripLineNumber) pairs
-            , hunkRemoveLast = stripLineNumber rems
-            }
-        line ((Line n _):_, _                     , _)            = (True, n)
-        line ([]          , ((Line n _) :| _, _):_, _)            = (False, n)
-        line ([]          , []                    , (Line n _):_) = (False, n)
-        line ([]          , []                    , [])           = error "empty hunk"
-        mkhunk h =
-            let (n, l) = line h
-            in  (n, l, mkhunk' h)
-    in  map (mkhunk . groupEithers . NE.toList) $
-        groupJusts $
-        map eitherOldNew $
-        diff (zipWith Line [1..] old) (zipWith Line [1..] new)
-
-accumEdits :: BlobStateDiff SHA1 -> [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) (V.fromList $ map (decodeUtf8 . BL.toStrict) ols) (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 (P.Patch, [Text])
-readPatch path hash = G.withRepo (fromString path) $ \ git -> do
-    let ref = fromHex $ encodeUtf8 hash
-    c <- G.getCommit git ref
-    medits <- case commitParents c of
-        []  -> 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 <$> G.getCommit git p
-    return $ case medits of
-        Left parents -> (patch []    c, parents)
-        Right edits  -> (patch edits c, [])
 
 {-
-lastCommitTime :: FilePath -> IO (Maybe UTCTime)
+gatherLines (Hunk _ _ lines) = map lineContent lines
-lastCommitTime repo =
+
-    (either fail return =<<) $ fmap join $ withRepo (fromString repo) $ runExceptT $ do
+toEdit (FileDelta Created _ dest Binary) =
-        branches <- S.toList <$> lift branchList
+    P.AddBinaryFile (T.unpack dest) 0 0
-        lct <- foldlM' utc0 branches $ \ time branch -> do
+toEdit (FileDelta Created _ dest (Hunks hunks)) =
-            mcommit <- lift $ getCommit branch
+    P.AddTextFile (T.unpack dest) 0 $ concatMap gatherLines hunks
-            case mcommit of
+toEdit (FileDelta Deleted source _ Binary) =
-                Nothing ->
+    P.RemoveBinaryFile (T.unpack source) 0 0
-                    throwE $
+toEdit (FileDelta Deleted source _ (Hunks hunks)) =
-                        "lastCommitTime: Failed to get commit for branch " ++
+    P.RemoveTextFile (T.unpack source) 0 $ concatMap gatherLines hunks
-                        refNameRaw branch
+toEdit (FileDelta Modified _ dest Binary) =
-                Just c ->
+    P.EditBinaryFile (T.unpack dest) 0 0 0 0
-                    return $ max time $
+toEdit (FileDelta Modified _ dest (Hunks [])) = error "Modified into empty?"
-                    utc $ gitTimeUTC $ personTime $ commitCommitter c
+toEdit (FileDelta Modified _ dest (Hunks (h:unks))) =
-        return $ if null branches
+    P.EditTextFile (T.unpack dest) V.empty (NE.map adaptHunk $ h:|unks) 0 0
-            then Nothing
-            else Just lct
     where
-    utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
+    adaptHunk _ = error "TODO adaptHunk: implement properly"
-    utc0 = UTCTime (ModifiedJulianDay 0) 0
-    foldlM' i l f = foldlM f i l
 -}
 
+patch :: Text -> VC.Commit -> P.Patch
+patch edits (VC.Commit a c _ t d) = P.Patch (mk a) (mk <$> c) t d edits
+    where
+    mk = first mk'
+    mk' (VC.Author n e) = P.Author n e
+
+readPatch :: ObjId -> GitT IO (P.Patch, [ObjId])
+readPatch oid = do
+    commit <- gitGetCommitInfo oid
+    deltas <- gitDiff oid
+    parents <- gitGetCommitParents oid
+    return (patch deltas commit, parents)
+
 writePostReceiveHooks :: WorkerDB ()
 writePostReceiveHooks = do
     hook <- asksSite $ appPostReceiveHookFile . appSettings

src/Vervis/Handler/Cloth.hs

@@ -81,6 +81,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Maybe
 import Data.Text (Text)
 import Data.These
+import Data.These.Combinators
 import Data.Traversable
 import Database.Persist
 import Network.HTTP.Types.Method

src/Vervis/Handler/Repo.hs

@@ -94,17 +94,6 @@ import Data.Binary.Put
 import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
-import Data.Git.Graph
-import Data.Git.Harder
-import Data.Git.Harder.Pack
-import Data.Git.Named (RefName (..))
-import Data.Git.Ref (toHex)
-import Data.Git.Repository
-import Data.Git.Storage (withRepo)
-import Data.Git.Storage.Object (Object (..))
-import Data.Git.Types (Blob (..), Person (..), entName)
-import Data.Graph.Inductive.Graph (noNodes)
-import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
@@ -116,7 +105,6 @@ import Data.Time.Clock
 import Data.Traversable (for)
 import Database.Persist
 import Database.Persist.Sql
-import Data.Hourglass (timeConvert)
 import Formatting (sformat, stext, (%))
 import Network.Git.Transport.HTTP.Fetch.RefDiscovery
 import Network.Git.Transport.HTTP.Fetch.UploadRequest
@@ -126,7 +114,6 @@ import Network.Wai (strictRequestBody)
 import Optics.Core
 import System.Directory
 import System.FilePath
-import System.Hourglass (dateCurrent)
 import System.IO
 import System.Process
 import Text.Blaze.Html (Html)
@@ -340,7 +327,7 @@ getGitRefDiscoverR repoHash = do
     let typ = "application/x-git-upload-pack-advertisement"
     path <- askRepoDir repoHash
     let pathG = fromString path
-    seemsThere <- liftIO $ isRepo pathG
+    seemsThere <- liftIO $ isGitRepo pathG
     if seemsThere
         then do
             rq <- getRequest
@@ -376,7 +363,7 @@ postGitUploadRequestR repoHash = do
     let typ = "application/x-git-upload-pack-result"
     path <- askRepoDir repoHash
     let pathG = fromString path
-    seemsThere <- liftIO $ isRepo pathG
+    seemsThere <- liftIO $ isGitRepo pathG
     if seemsThere
         then do
             getBody <- strictRequestBody <$> waiRequest
@@ -1394,7 +1381,7 @@ getRepoFollowersR shr rp = getFollowersCollection here getFsid
 
 getHighlightStyleR :: Text -> Handler TypedContent
 getHighlightStyleR styleName =
-    case lookup (unpack styleName) highlightingStyles of
+    case lookup styleName highlightingStyles of
         Nothing -> notFound
         Just style ->
             return $ TypedContent typeCss $ toContent $ styleToCss style

src/Vervis/Handler/Ticket.hs

@@ -115,8 +115,6 @@ import qualified Data.Text as T (filter, intercalate, pack)
 import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
 
-import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
-
 import Data.Aeson.Encode.Pretty.ToEncoding
 import Data.MediaType
 import Network.FedURI

src/Vervis/Hook.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -33,18 +33,13 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Class
 import Crypto.Random
 import Data.Aeson
 import Data.Bifunctor
 import Data.ByteString (ByteString)
 import Data.Char
-import Data.Git hiding (Commit)
-import Data.Git.Ref
-import Data.Git.Types hiding (Commit)
-import Data.Git.Graph
-import Data.Git.Harder
 import Data.Graph.Inductive.Graph
-import Data.Graph.Inductive.Query.Topsort
 import Data.Int
 import Data.Maybe
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
@@ -63,27 +58,28 @@ import System.FilePath
 import System.IO
 import Text.Email.Aeson.Instances ()
 import Text.Email.Validate
-import Text.Read
+import Text.Read (readMaybe)
 import Text.XML.Light
-import Time.Types
 import Yesod.Core.Content
 
+import qualified Control.Monad.Catch as MC
 import qualified Data.Attoparsec.Text as A
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Base16 as B16
-import qualified Data.DList as D
-import qualified Data.Git as G
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.IO as TIO
 
 import Data.KeyFile
+import Data.VersionControl
 import Network.FedURI
 
 import Control.Monad.Trans.Except.Local
-import Data.DList.Local
+--import Data.DList.Local
 import Data.List.NonEmpty.Local
+import Data.Git.Local
 
 data HookSecret = HookSecret ByteString
 
@@ -109,29 +105,6 @@ instance FromJSON Config
 
 instance ToJSON Config
 
-data Author = Author
-    { authorName  :: Text
-    , authorEmail :: EmailAddress
-    }
-    deriving Generic
-
-instance FromJSON Author
-
-instance ToJSON Author
-
-data Commit = Commit
-    { commitWritten     :: (Author, UTCTime)
-    , commitCommitted   :: Maybe (Author, UTCTime)
-    , commitHash        :: Text
-    , commitTitle       :: Text
-    , commitDescription :: Text
-    }
-    deriving Generic
-
-instance FromJSON Commit
-
-instance ToJSON Commit
-
 data Push = Push
     { pushSecret :: Text
     , pushUser   :: Int64
@@ -179,7 +152,7 @@ splitCommits config commits =
     where
     maxCommits = configMaxCommits config
 
-sendPush :: Config -> Manager -> Push -> ExceptT Text IO (Response ())
+sendPush :: (MonadIO m, MC.MonadThrow m) => Config -> Manager -> Push -> ExceptT Text m (Response ())
 sendPush config manager push = do
     let uri :: ObjURI Dev
         uri =
@@ -193,114 +166,97 @@ sendPush config manager push = do
             req { method      = "POST"
                 , requestBody = RequestBodyLBS $ encode push
                 }
-    ExceptT $ first adaptErr <$> try (httpNoBody req' manager)
+    ExceptT $ liftIO $ first adaptErr <$> try (httpNoBody req' manager)
     where
     adaptErr :: HttpException -> Text
     adaptErr = T.pack . displayException
     consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
 
+data ChangeType = Create ObjId | Delete ObjId | Update ObjId ObjId
+
+data Situation = UnannotatedTag Text | AnnotatedTag Text | Branch Text | TrackingBranch Text
+
 reportNewCommits :: Config -> Text -> IO ()
 reportNewCommits config repo = do
     user <- read <$> getEnv "VERVIS_SSH_USER"
     manager <- newManager defaultManagerSettings
-    withRepo "." $ loop user manager
+    withGitRepo "." $ loop user manager
     where
-    loop user manager git = do
+    -- Written while looking at contrib/hooks/post-receive-email in Git source repo
-        eof <- isEOF
+    loop user manager = do
+        eof <- liftIO isEOF
         unless eof $ do
             result <- runExceptT $ do
                 line <- liftIO TIO.getLine
                 (old, new, refname) <-
                     case T.words line of
-                        [o, n, r] -> return (o, n, r)
+                        [o, n, r] -> lift $ do
+                            o' <- gitGetObjectHash o
+                            n' <- gitGetObjectHash n
+                            return (o', n', r)
                         _ -> throwE $ "Weird line: " <> line
-                moldRef <- parseRef old
+                let change =
-                newRef <- do
+                        if isZeroObj old
-                    mr <- parseRef new
+                            then Create new
-                    case mr of
+                        else if isZeroObj new
-                        Nothing -> throwE $ "Ref deletion: " <> new
+                            then Delete old
-                        Just r -> return r
+                        else Update old new
+                    rev =
+                        case change of
+                            Create h -> h
+                            Delete h -> h
+                            Update o n -> n
+                revType <- lift $ gitGetRevType $ renderObjId $ rev
+                situation <-
+                    case (T.stripPrefix "refs/tags/" refname, T.stripPrefix "refs/heads/" refname, T.stripPrefix "refs/remotes/" refname, revType) of
+                        (Just tag, _, _, RTCommit) -> pure $ UnannotatedTag tag
+                        (Just tag, _, _, RTTag) -> pure $ AnnotatedTag tag
+                        (_, Just branch, _, RTCommit) -> pure $ Branch branch
+                        (_, _, Just branch, RTCommit) -> pure $ TrackingBranch branch
+                        _ -> throwE $ "Unknown type of update to " <> refname <> " (" <> T.pack (show revType) <> ")"
+
                 branch <-
-                    case T.stripPrefix "refs/heads/" refname of
+                    case situation of
-                        Just t | not (T.null t) -> return t
+                        Branch b -> pure b
-                        _ -> throwE $ "Unexpected refname: " <> refname
+                        _ -> throwE "Non-branch situation, not supported yet"
-                graph <- liftIO $ loadCommitGraphPT git [ObjId newRef]
+
-                nodes <-
+                refSpec <-
-                    case topsortUnmixOrder graph (NodeStack [noNodes graph]) of
+                    case change of
-                        Nothing -> throwE "Commit graph contains a cycle"
+                        Create h -> pure $ renderObjId h
-                        Just ns -> return ns
+                        Delete _ -> throwE "Branch deletion, not supported yet"
-                historyAll <-
+                        Update o n -> pure $ renderObjId o <> ".." <> renderObjId n
-                    case nonEmpty $ D.toList $ nodeLabel graph <$> nodes of
+                otherBranchHashes <- lift $ do
-                        Nothing -> throwE "Empty commit graph"
+                    otherBranches <- S.delete branch <$> gitListBranches
-                        Just h -> return h
+                    gitGetObjectHashes $ map ("refs/heads/" <>) $ S.toList otherBranches
-                historyNew <-
+                commits <- lift $ gitGetCommitInfos refSpec otherBranchHashes Nothing Nothing
-                    case moldRef of
+                commits' <-
-                        Nothing -> return historyAll
+                    case NE.nonEmpty commits of
-                        Just oldRef -> do
+                        Nothing -> throwE "No commits"
-                            let (before, after) =
+                        Just ne -> pure ne
-                                    NE.break
+
-                                        ((== ObjId oldRef) . fst)
+                (early, late) <- splitCommits config commits'
-                                        historyAll
-                            when (null after) $
-                                throwE "oldRef not found"
-                            nonEmptyE before "No new commits"
-                let commits = NE.map (uncurry makeCommit) historyNew
-                    maxCommits = configMaxCommits config
-                (early, late) <- splitCommits config commits
                 let push = Push
                         { pushSecret = configSecret config
                         , pushUser   = user
                         , pushRepo   = repo
                         , pushBranch = Just branch
-                        , pushBefore = old <$ moldRef
+                        , pushBefore =
-                        , pushAfter  = Just new
+                            renderObjId <$>
+                            case change of
+                                Create _ -> Nothing
+                                Delete h -> Just h
+                                Update h _ -> Just h
+                        , pushAfter  = Just $ renderObjId new
                         , pushInit   = early
                         , pushLast   = late
                         }
                 sendPush config manager push
             case result of
-                Left e -> TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
+                Left e -> lift $ TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
                 Right _resp -> return ()
-            loop user manager git
+            loop user manager
         where
-        parseRef t =
+        isZeroObj (ObjId b) = B.all (== 0) b
-            if t == nullRef
-                then return Nothing
-                else
-                    let b = TE.encodeUtf8 t
-                    in  if isHex b
-                            then return $ Just $ fromHex b
-                            else throwE $ "Invalid ref: " <> t
-            where
-            nullRef = T.replicate 40 "0"
-        makeCommit (ObjId ref) c = Commit
-            { commitWritten     = makeAuthor $ commitAuthor c
-            , commitCommitted   =
-                if commitAuthor c == commitCommitter c
-                    then Nothing
-                    else Just $ makeAuthor $ commitCommitter c
-            , commitHash        = T.pack $ toHexString ref
-            , commitTitle       = title
-            , commitDescription = desc
-            }
-            where
-            split t =
-                let (l, r) = T.break (\ c -> c == '\n' || c == '\r') t
-                in  (T.strip l, T.strip r)
-            (title, desc) = split $ TE.decodeUtf8 $ commitMessage c
-
-            makeAuthor (Person name email time) =
-                ( Author
-                    { authorName  = TE.decodeUtf8 name
-                    , authorEmail =
-                        case emailAddress email of
-                            Nothing ->
-                                error $ "Invalid email " ++ T.unpack (TE.decodeUtf8 email)
-                            Just e  -> e
-                    }
-                , let Elapsed (Seconds t) = gitTimeUTC time
-                  in  posixSecondsToUTCTime $ fromIntegral t
-                )
 
 postReceive :: IO ()
 postReceive = do

src/Vervis/Migration/Model2016.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2016
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2018.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2018
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2019.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2019
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2020.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2020
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2022.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2022
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2023.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2023
     {-
     ( EntityField (..)

src/Vervis/Migration/Model2024.hs

@@ -14,6 +14,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE UndecidableInstances #-}
+
 module Vervis.Migration.Model2024
     {-
     ( EntityField (..)

src/Vervis/Model.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022, 2023
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -16,6 +16,11 @@
 
 {-# LANGUAGE FlexibleInstances #-}
 
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DataKinds #-}
+
 module Vervis.Model where
 
 import Yesod hiding (Header, parseTime)
@@ -34,7 +39,6 @@ import Yesod.Auth.Account (PersistUserCredentials (..))
 import Crypto.ActorKey
 import Crypto.PublicVerifKey
 import Database.Persist.EmailAddress
-import Database.Persist.Graph.Class
 import Database.Persist.JSON
 import Development.PatchMediaType
 import Development.PatchMediaType.Persist

src/Vervis/Persist/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2020, 2022, 2023
+ - Written in 2016, 2019, 2020, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -234,8 +234,8 @@ getMessageFromID getdid mid = do
     mlocal <- getBy $ UniqueLocalMessage mid
     mremote <- getBy $ UniqueRemoteMessage mid
     author <- case (mlocal, mremote) of
-        (Nothing, Nothing) -> fail "Message with no author"
+        (Nothing, Nothing) -> error "Message with no author"
-        (Just _, Just _) -> fail "Message used as both local and remote"
+        (Just _, Just _) -> error "Message used as both local and remote"
         (Just (Entity lmid lm), Nothing) -> do
             let actorID = localMessageAuthor lm
             name <- actorName <$> getJust actorID

src/Vervis/Persist/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -31,7 +31,7 @@ import Data.Bitraversable
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.Text (Text)
-import Data.These
+import Data.These.Combinators
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql

src/Vervis/Readme.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -23,14 +23,9 @@ where
 import Prelude hiding (takeWhile)
 
 import Data.ByteString.Lazy (ByteString)
-import Data.Git.Harder (ObjId (..))
-import Data.Git.Storage (Git, getObject_)
-import Data.Git.Storage.Object (Object (..))
-import Data.Git.Types (Blob (..), Tree (..))
 import Data.Text (Text, toCaseFold, takeWhile, unpack)
 import System.FilePath (isExtSeparator)
 
-import Data.Git.Local (TreeRows)
 import Text.FilePath.Local (breakExt)
 import Vervis.Foundation (Widget)
 import Data.MediaType
@@ -44,8 +39,8 @@ isReadme file =
     in  toCaseFold "readme" == toCaseFold basename
 
 -- | Render README content into a widget for inclusion in a page.
-renderReadme :: [Text] -> Text -> ByteString -> Widget
+renderReadme :: [Text] -> Text -> Text -> Widget
 renderReadme dir name content =
     let (base, ext) = breakExt name
         mediaType = chooseMediaType dir base ext () ()
-    in  renderSourceBL mediaType content
+    in  renderSourceT mediaType content

src/Vervis/Settings.hs

@@ -132,7 +132,7 @@ data AppSettings = AppSettings
 
       -- | Load SVG font file from the data file path of the @SVGFonts@
       -- library, instead of the app's production runtime data directory.
-    , appLoadFontFromLibData    :: Bool
+    --, appLoadFontFromLibData    :: Bool
 
       -- | Path to the directory under which git repos are placed
     , appRepoDir                :: FilePath
@@ -242,7 +242,7 @@ instance FromJSON AppSettings where
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         --appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
 
-        appLoadFontFromLibData    <- o .:? "load-font-from-lib-data" .!= defaultDev
+        --appLoadFontFromLibData    <- o .:? "load-font-from-lib-data" .!= defaultDev
 
         appRepoDir                <- o .: "repo-dir"
         appDiffContextLines       <- o .: "diff-context-lines"
@@ -268,8 +268,8 @@ instance FromJSON AppSettings where
         appHighlightStyle           <- do
             s <- o .:? "highlight-style" .!= "zenburn"
             case lookup s highlightingStyles of
-                Nothing -> fail $ "Highlighting style " ++ s ++ " not found"
+                Nothing -> fail $ "Highlighting style " ++ T.unpack s ++ " not found"
-                Just _ -> return $ T.pack s
+                Just _ -> return s
         appMainColor                <- o .:? "main-color" .!= 0
 
         return AppSettings {..}

src/Vervis/SourceTree.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -28,8 +28,6 @@ where
 
 import Data.Text (Text)
 
-import qualified Data.ByteString.Lazy as BL (ByteString)
-
 import Text.FilePath.Local (breakExt)
 import Vervis.Foundation (Widget)
 import Data.MediaType
@@ -61,7 +59,7 @@ data SourceView a
     = SourceDir (DirectoryView a)
     | SourceFile (FileView a)
 
-renderSources :: [EntryName] -> SourceView BL.ByteString -> SourceView Widget
+renderSources :: [EntryName] -> SourceView Text -> SourceView Widget
 renderSources dir (SourceDir (DirectoryView mname rows mreadme)) =
     SourceDir $ case mreadme of
         Nothing -> DirectoryView mname rows Nothing
@@ -71,4 +69,4 @@ renderSources dir (SourceFile (FileView name body)) =
     let parent = init dir
         (base, ext) = breakExt name
         mediaType = chooseMediaType parent base ext () ()
-    in  SourceFile $ FileView name $ renderSourceBL mediaType body
+    in  SourceFile $ FileView name $ renderSourceT mediaType body

src/Vervis/Ssh.hs

@@ -29,7 +29,6 @@ import Data.Attoparsec.Text
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromStrict)
 import Data.Foldable (find)
-import Data.Git.Storage (isRepo)
 import Data.Maybe (isJust)
 import Data.Monoid ((<>))
 import Data.String (fromString)
@@ -53,6 +52,8 @@ import qualified Formatting as F
 
 import Yesod.Hashids
 
+import Data.Git.Local
+
 import Vervis.Access
 import Vervis.Actor
 import Vervis.Model
@@ -215,7 +216,7 @@ whenDarcsRepoExists =
 
 whenGitRepoExists
     :: Bool -> FilePath -> Channel ActionResult -> Channel ActionResult
-whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
+whenGitRepoExists = whenRepoExists "Git" isGitRepo
 
 canPushTo :: RepoId -> Channel Bool
 canPushTo repoID = do

src/Vervis/TicketFilter.hs

@@ -34,9 +34,11 @@ instance Default TicketFilter where
     def = TicketFilter True True
 
 filterTickets
-    :: Esqueleto q e b
+    :: TicketFilter
-    => TicketFilter
+    -> Maybe
-    -> Maybe (e (Maybe (Entity TicketResolve)) -> e (Value Bool))
+        ( SqlExpr (Maybe (Entity TicketResolve)) ->
+          SqlExpr (Value Bool)
+        )
 filterTickets (TicketFilter False False) = Just $ \ _ -> val (0::Int) ==. val 1
 filterTickets (TicketFilter False True)  = Just $ \ t -> not_ $ isNothing $ t ?. TicketResolveId
 filterTickets (TicketFilter True  False) = Just $ \ t -> isNothing $ t ?. TicketResolveId

src/Vervis/Web/Git.hs

@@ -24,16 +24,6 @@ where
 
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
-import Data.Git.Graph
-import Data.Git.Harder
-import Data.Git.Named (RefName (..))
-import Data.Git.Ref (toHex)
-import Data.Git.Repository
-import Data.Git.Storage (withRepo)
-import Data.Git.Storage.Object (Object (..))
-import Data.Git.Types (Blob (..), Commit (..), Person (..), entName)
-import Data.Graph.Inductive.Graph (noNodes)
-import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
 import Data.Maybe
 import Data.Text (Text, unpack)
@@ -41,10 +31,8 @@ import Data.Text.Encoding
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Traversable (for)
 import Database.Esqueleto
-import Data.Hourglass (timeConvert)
 import Network.HTTP.Types
 import System.Directory (createDirectoryIfMissing)
-import System.Hourglass (dateCurrent)
 import Text.Blaze.Html (Html)
 import Yesod.Auth
 import Yesod.Core
@@ -103,7 +91,7 @@ getGitRepoSource
     :: Repo -> Actor -> KeyHashid Repo -> Text -> [Text] -> [LoomId] -> Handler Html
 getGitRepoSource repository actor repo ref dir loomIDs = do
     path <- askRepoDir repo
-    (branches, tags, msv) <- liftIO $ G.readSourceView path ref dir
+    (branches, tags, msv) <- liftIO $ withGitRepo path $ G.readSourceView ref dir
     case msv of
         Nothing -> notFound
         Just sv -> do
@@ -149,7 +137,8 @@ getGitRepoBranch shar repo ref = do
 getGitRepoChanges :: KeyHashid Repo -> Text -> Handler TypedContent
 getGitRepoChanges repo ref = do
     path <- askRepoDir repo
-    (branches, tags) <- liftIO $ G.listRefs path
+    (branches, tags) <- liftIO $ withGitRepo path $ (,)
+        <$> gitListBranches <*> gitListTags
     unless (ref `S.member` branches || ref `S.member` tags)
         notFound
     let here = RepoBranchCommitsR repo ref
@@ -157,7 +146,7 @@ getGitRepoChanges repo ref = do
     encodeRouteHome <- getEncodeRouteHome
     encodeRoutePageLocal <- getEncodeRoutePageLocal
     let pageUrl = encodeRoutePageLocal here
-        getChanges o l = liftIO $ G.readChangesView path ref o l
+        getChanges o l = liftIO $ withGitRepo path $ G.readChangesView ref o l
     mpage <- getPageAndNavMaybe getChanges
     case mpage of
         Nothing -> do
@@ -206,5 +195,7 @@ getGitRepoChanges repo ref = do
 getGitPatch :: KeyHashid Repo -> Text -> Handler TypedContent
 getGitPatch hash ref = do
     path <- askRepoDir hash
-    (patch, parents) <- liftIO $ G.readPatch path ref
+    oid <- liftIO $ parseObjId ref
-    serveCommit hash ref patch parents
+    (patch, parents) <- liftIO $ withGitRepo path $ G.readPatch oid
+    let parents' = map renderObjId parents
+    serveCommit hash ref patch parents'

src/Vervis/Widget.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2023, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -38,7 +39,9 @@ import Vervis.Settings (widgetFile)
 import Vervis.Style
 import Vervis.Time (showDate)
 
-breadcrumbsW :: YesodBreadcrumbs site => WidgetFor site ()
+breadcrumbsW
+    :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site))
+    => WidgetFor site ()
 breadcrumbsW = do
     (current, bcs) <- handlerToWidget breadcrumbs
     $(widgetFile "widget/breadcrumbs")

src/Vervis/Widget/Repo.hs

@@ -16,7 +16,6 @@
 module Vervis.Widget.Repo
     ( refSelectW
     , changesW
-    , inlineDiffW
     , repoNavW
     )
 where
@@ -35,8 +34,6 @@ import qualified Data.Vector as V
 
 import Yesod.Hashids
 
-import Data.Patch.Local (Hunk (..))
-
 import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Model
@@ -50,90 +47,6 @@ refSelectW hash branches tags = $(widgetFile "repo/widget/ref-select")
 changesW :: Foldable f => KeyHashid Repo -> f LogEntry -> Widget
 changesW hash entries = $(widgetFile "repo/widget/changes")
 
-numberHunk :: Int -> Int -> Hunk -> (Int, Int, [(Bool, Int, Text)])
-numberHunk startOld startNew hunk = j $ i ((startOld, startNew), []) hunk
-    where
-    f add n line = (add, n, line)
-    g add ((o, n), l) lines =
-        ( if add
-            then (o               , n + length lines)
-            else (o + length lines, n)
-        , zipWith (f add) (if add then [n..] else [o..]) lines : l
-        )
-    h s (rems, adds) = g True (g False s $ N.toList rems) $ N.toList adds
-    i s (Hunk adds pairs rems) =
-        g False (foldl' h (g True s adds) pairs) rems
-    j ((o, n), l) = (o - 1, n - 1, concat $ reverse l)
-
-hunkLines
-    :: NonEmpty (Bool, Int, Hunk)
-    -- ^ Whether the line number is for new file; line number; text lines
-    -> NonEmpty (Int, Int, Int, Int, [(Bool, Int, Text)])
-    -- ^ First line numbers in old and new; last line numbers in old and new;
-    -- whether the line is added (otherwise removed); line number (in new if
-    -- added, in old if removed); line content text
-hunkLines = N.fromList . reverse . foldl' f []
-    where
-    f [] (_, ln, hunk) =
-        let (o, n, lines) = numberHunk ln ln hunk
-        in  [(ln, ln, o, n, lines)]
-    f l@((_, _, o, n, _) : _) (new, ln, hunk) =
-        let (oln, nln) =
-                if new
-                    then (ln - n + o, ln)
-                    else (ln        , ln + n - o)
-            (o', n', lines) = numberHunk oln nln hunk
-        in  (oln, nln, o', n', lines) : l
-
-data LineNumber = Old Int | Both Int Int | New Int
-
-diffLine :: (Bool, Int, Text) -> (LineNumber, Text)
-diffLine (True, n, t) = (New n, t)
-diffLine (False, n, t) = (Old n, t)
-
-context :: Vector Text -> Int -> Int -> Int -> [(LineNumber, Text)]
-context orig startOld startNew len =
-    let n = V.length orig
-        number i j t = (Both i j, t)
-        len' = min len $ n - startOld + 1
-    in  if startOld > n
-            then []
-            else zipWith3 number [startOld..] [startNew..] $
-                    V.toList $ V.slice (startOld - 1) len' orig
-
-addContext
-    :: Int
-    -> Vector Text
-    -> NonEmpty (Int, Int, Int, Int, [(Bool, Int, Text)])
-    -> [[(LineNumber, Text)]]
-addContext ctx orig = prepend . foldr f (undefined, [])
-    where
-    f (startOld, startNew, endOld, endNew, lines) (_, []) =
-        ( (startOld, startNew)
-        , [map diffLine lines ++ context orig (endOld + 1) (endNew + 1) ctx]
-        )
-    f (startOld, startNew, endOld, endNew, lines) ((o, n), l:ls) =
-        ( (startOld, startNew)
-        , let len = o - endOld - 1
-              ds = map diffLine lines
-              ctxCurr = context orig (endOld + 1) (endNew + 1)
-              ctxNext = context orig (o - ctx) (n - ctx) ctx
-          in  if len <= 2 * ctx
-                then (ds ++ ctxCurr len ++ l) : ls
-                else (ds ++ ctxCurr ctx)      : (ctxNext ++ l) : ls
-        )
-    prepend ((_       , _       ), [])   = []
-    prepend ((startOld, startNew), l:ls) =
-        let o = max 1 $ startOld - ctx
-            len = min (startOld - o) ctx
-        in  (context orig o (startNew - len) len ++ l) : ls
-
-inlineDiffW :: Vector Text -> NonEmpty (Bool, Int, Hunk) -> Widget
-inlineDiffW orig hunks = do
-    ctx <- getsYesod $ appDiffContextLines . appSettings
-    let diffs = addContext ctx orig $ hunkLines hunks
-    $(widgetFile "repo/widget/inline-diff")
-
 repoNavW :: Entity Repo -> Actor -> Widget
 repoNavW (Entity repoID repo) actor = do
     repoHash <- encodeKeyHashid repoID

src/Web/Text.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -30,8 +31,8 @@ import Control.Exception
 import Data.Aeson
 import Data.Bifunctor
 import Data.Text (Text)
-import Database.Persist
+import Database.Persist hiding (Escaped)
-import Database.Persist.Sql
+import Database.Persist.Sql hiding (Escaped)
 import HTMLEntities.Decoder
 import Text.Blaze (preEscapedText)
 import Text.Blaze.Html (Html)

src/Yesod/MonadSite.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -166,9 +166,6 @@ newtype WorkerT site m a = WorkerT
         )
 
 instance MonadUnliftIO m => MonadUnliftIO (WorkerT site m) where
-    askUnliftIO =
-        WorkerT $ withUnliftIO $ \ u ->
-            return $ UnliftIO $ unliftIO u . unWorkerT
     withRunInIO inner =
         WorkerT $ withRunInIO $ \ run -> inner (run . unWorkerT)
 

stack.yaml

@@ -3,7 +3,7 @@
 
 # Specifies the GHC version and set of packages available (e.g., lts-3.5,
 # nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-13.22
+resolver: lts-18.28
 
 # Local packages, usually specified by relative directory name
 packages:
@@ -14,27 +14,25 @@ packages:
 extra-deps:
   # yesod-auth-account
   - git: https://vervis.peers.community/repos/VE2Kr
-    commit: 70024e76cafb95bfa50b456efcf0970d720207bd
+    commit: c2fe99bfe987512b677a32902a4e8b3f3c0009b5
   - git: https://codeberg.org/ForgeFed/darcs-lights
-    commit: d12cfc6f7ac7593910da0803ff7fb7ac82a3a460
+    commit: c6005155bcd28f6e4243e8cafed1bd61384cae48
   - git: https://codeberg.org/ForgeFed/dvara
-    commit: 01c01ecce624b366cb630ec93e2a80bb873ef7e2
+    commit: 2a93bf977b7b1529212999f05525e9158afde7ad
-  - git: https://codeberg.org/ForgeFed/haskell-hit-graph
-    commit: f00d8c927ac37f4c4c28aee56069d2ca068b6536
-  - git: https://codeberg.org/ForgeFed/haskell-hit-harder
-    commit: e8cc33700f796532644a6a95afbcc39f63ee1f92
-  - git: https://codeberg.org/ForgeFed/haskell-hit-network
-    commit: 5b7a0e22db10b48c31894f1f31b300c07420fd63
   - git: https://codeberg.org/ForgeFed/haskell-http-signature
     commit: 0ff017f91169f1d23e78a2edf9ba2e59b227dc86
   - git: https://codeberg.org/ForgeFed/haskell-http-client-signature
     commit: 42b01e0b57c2dcaf78a5dc13c298ec985524d8af
-  - git: https://codeberg.org/ForgeFed/haskell-persistent-graph
-    commit: 429b7cb3d744a66543e25467e43ae7339bd35534
   - git: https://codeberg.org/ForgeFed/haskell-persistent-migration
-    commit: 7ee6510d08d2b1fba8928d9d63170c08d719bc9c
+    commit: 6cfc4292fe78d7be380e2a37751099f55d4cb7b7
   - git: https://codeberg.org/ForgeFed/haskell-persistent-email-address
     commit: ddf0ea55d4e7a0cdf8d57b40f0fc6841de8657af
+  - git: https://codeberg.org/ForgeFed/haskell-time-interval-aeson
+    commit: 7a9a17abb1b27b79a4b2d535f3f1f163afea071e
+  - git: https://codeberg.org/ForgeFed/haskell-yesod-http-signature
+    commit: 02536f0802120d887ae84bdaeac3e269de82fe2a
+  - git: https://codeberg.org/ForgeFed/haskell-yesod-mail-send
+    commit: ccdc3b453a46d7d3f38998478c421ddc791591ff
 # - git: https://notabug.org/fr33domlover/haskell-persistent
 #   commit: 9cc700b540a680ac1fdc9df94847a631013cb3ca
 #   subdirs:
@@ -42,34 +40,35 @@ extra-deps:
 #     - persistent-postgresql
 
   - ./lib/ssh
-  - ./lib/time-interval-aeson
-  - ./lib/yesod-http-signature
-  - ./lib/yesod-mail-send
 
   - DRBG-0.5.5
+  - cipher-aes128-0.7.0.6
   - SimpleAES-0.4.2
-  - darcs-2.14.2
+  - darcs-2.16.5
-  - data-default-instances-bytestring-0.0.1
+  - constraints-0.12
-  - esqueleto-2.7.0
+#  - data-default-instances-bytestring-0.0.1
-  - git-0.3.0
+#  - esqueleto-2.7.0
-  - graphviz-2999.20.0.3
+#  - graphviz-2999.20.0.3
   - highlighter2-0.2.5
   - libravatar-0.4.0.2
   - monad-hash-0.1.0.2
   - monadcryptorandom-0.7.2.1
-  - patience-0.2.1.1
+#  - patience-0.3
   - pwstore-fast-2.4.4
-  - sandi-0.5
+#  - sandi-0.5
   - email-validate-json-0.1.0.0
   - time-interval-0.1.1
-  - time-units-1.0.0
+#  - time-units-1.0.0
-  - url-2.1.3
+#  - url-2.1.3
-  - annotated-exception-0.2.0.4
+  - annotated-exception-0.3.0.1
   - retry-0.9.3.1
-  - base58-bytestring-0.1.0
+#  - base58-bytestring-0.1.0
-  - indexed-profunctors-0.1.1
+#  - indexed-profunctors-0.1.1
-  - indexed-traversable-0.1.2.1
+#  - indexed-traversable-0.1.2.1
-  - optics-core-0.4.1
+#  - optics-core-0.4.1
+  - HList-0.5.3.0
+#  - first-class-families-0.8.1.0
+  - diff-parse-0.2.1
 
 # Override default flag values for local packages and extra-deps
 flags:

templates/repo/patch.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2018, 2019, 2022, 2024 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -40,65 +40,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <td>
       <p>#{patchDescription patch}
 
-$if null parents
+<p>Parent commits:
-  <ul>
+<ol>
-    $forall edit <- patchDiff patch
-      <li>
-        $case edit
-          $of AddTextFile path mode lines
-            <p>Add file #{path} #{mode}
-            <table .lines>
-              $forall (n, t) <- number lines
-                <tr>
-                  <td>+
-                  <td>#{n}
-                  <td>#{t}
-          $of AddBinaryFile path mode size
-            <p>Add binary file #{path} #{mode} #{size}
-          $of RemoveTextFile path mode lines
-            <p>Remove file #{path} #{mode}
-            <table .lines>
-              $forall (n, t) <- number lines
-                <tr>
-                  <td>-
-                  <td>#{n}
-                  <td>#{t}
-          $of RemoveBinaryFile path mode size
-            <p>Remove binary file #{path} #{mode} #{size}
-          $of MoveFile oldPath oldMode newPath newMode
-            <p>Move file #{oldPath} #{oldMode} → #{newPath} #{newMode}
-          $of ChmodFile path old new
-            <p>Change file mode #{path} #{old} → #{new}
-          $of EditTextFile path orig hunks oldMode newMode
-            <p>Edit file #{path} #{oldMode} → #{newMode}
-            ^{inlineDiffW orig hunks}
-          $of EditBinaryFile path oldSize oldMode newSize newMode
-            <p>
-              Edit binary file #{path} #{oldSize} #{oldMode} →
-              #{newSize} #{newMode}
-          $of TextToBinary path lines oldMode newSize newMode
-            <p>Edit file #{path} #{oldMode} → #{newSize} #{newMode}
-            <table .lines>
-              $forall (n, t) <- number lines
-                <tr>
-                  <td>-
-                  <td>#{n}
-                  <td>#{t}
-          $of BinaryToText path oldSize oldMode lines newMode
-            <p>Edit file #{path} #{oldMode} #{oldSize} → #{newMode}
-            <table .lines>
-              $forall (n, t) <- number lines
-                <tr>
-                  <td>+
-                  <td>#{n}
-                  <td>#{t}
-$else
-  <p>
-    This commit has multiple parents, and to be honest, I'm unsure how exactly
-    to decide against which one to run the diff. Do I just pick the first
-    parent? Or otherwise somehow detect which one is the right one? Advice is
-    very welcome. For now, to help me find and observe such cases, I'm just
-    listing here the parents of the commit:
-  <ol>
   $forall parent <- parents
     <li>#{parent}
+
+<p>Diff:
+<pre>#{patchDiff patch}

templates/repo/widget/inline-diff.cassius

@@ -1,28 +0,0 @@
-/* This file is part of Vervis.
- *
- * Written in 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/>.
- */
-
-pre
-    margin: 0px
-
-.lines
-    font-family: monospace
-
-.remove
-    background: #{light red}
-    color:      #{black}
-
-.add
-    background: #{light green}
-    color:      #{black}

templates/repo/widget/inline-diff.hamlet

@@ -1,44 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 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/>.
-
-<table .lines>
-  $forall lines <- diffs
-    $forall (ln, t) <- lines
-      $case ln
-        $of Old n
-          <tr .remove>
-            <td>-
-            <td>#{n}
-            <td>
-            <td>
-              <pre>#{t}
-        $of New n
-          <tr .add>
-            <td>+
-            <td>
-            <td>#{n}
-            <td>
-              <pre>#{t}
-        $of Both o n
-          <tr>
-            <td>
-            <td>#{o}
-            <td>#{n}
-            <td>
-              <pre>#{t}
-    <tr>
-      <td>…
-      <td>…
-      <td>…
-      <td>…

update-deps.sh

@@ -2,10 +2,7 @@
 
 VERVIS='https://vervis.peers.community/repos'
 
-DEPS="6r4Ao   ssh                      \n
+DEPS="6r4Ao   ssh"
-      AoO7o   time-interval-aeson      \n
-      r6WGo   yesod-http-signature     \n
-      2vanE   yesod-mail-send"
 
 mkdir -p lib
 cd lib

vervis.cabal

@@ -43,8 +43,17 @@ library
                        Vervis.Application
                        Vervis.Hook
   other-modules:
+                       Network.Git.Transport.HTTP.Fetch.RefDiscovery
+                       Network.Git.Transport.HTTP.Fetch.UploadRequest
+                       Network.Git.Get
+                       Network.Git.Put
+                       Network.Git.Types
+                       Data.Binary.Get.Local
+                       Data.Binary.Put.Local
+
                        Control.Applicative.Local
                        Control.Concurrent.Actor
+                       --Control.Concurrent.ActorNew2
                        Control.Concurrent.Local
                        Control.Concurrent.ResultShare
                        Control.Concurrent.Return
@@ -65,7 +74,7 @@ library
                        Data.ByteString.Local
                        Data.CaseInsensitive.Local
                        Data.Char.Local
-                       Data.DList.Local
+                       --Data.DList.Local
                        Data.Either.Local
                        Data.EventTime.Local
                        Data.Functor.Local
@@ -76,7 +85,7 @@ library
                        Data.Graph.Inductive.Query.Path
                        Data.Graph.Inductive.Query.TransRed
                        Data.HashMap.Lazy.Local
-                       Data.Hourglass.Local
+                       --Data.Hourglass.Local
                        Data.Int.Local
                        Data.KeyFile
                        Data.List.Local
@@ -90,6 +99,7 @@ library
                        Data.Time.Clock.Local
                        Data.Tree.Local
                        Data.Tuple.Local
+                       Data.VersionControl
                        Database.Esqueleto.Local
                        Database.Persist.Box
                        Database.Persist.Box.Internal
@@ -99,12 +109,12 @@ library
                        Database.Persist.Sql.Local
                        Database.Persist.Sqlite.Local
                        Database.Persist.Local
-                       Database.Persist.Local.Class.PersistEntityHierarchy
+                       --Database.Persist.Local.Class.PersistEntityHierarchy
                        Database.Persist.Local.RecursionDoc
                        Development.PatchMediaType
                        Development.PatchMediaType.JSON
                        Development.PatchMediaType.Persist
-                       Diagrams.IntransitiveDAG
+                       --Diagrams.IntransitiveDAG
                        Formatting.CaseInsensitive
                        Language.Haskell.TH.Quote.Local
                        Network.FedURI
@@ -160,8 +170,8 @@ library
                        --Vervis.Class.Actor
                        Vervis.Client
                        Vervis.Cloth
-                       Vervis.Colour
+                       --Vervis.Colour
-                       Vervis.Content
+                       --Vervis.Content
                        Vervis.Darcs
 
                        Vervis.Data.Actor
@@ -298,6 +308,9 @@ library
                        TupleSections
                        RecordWildCards
                        LambdaCase
+                       DerivingStrategies
+                       StandaloneDeriving
+                       DataKinds
 
   build-depends:       aeson
                        -- For activity JSOn display in /inbox test page
@@ -329,8 +342,6 @@ library
                      , case-insensitive
                        -- For slab/box/citron serialization
                      , cereal
-                       -- for defining colors for use with diagrams
-                     , colour
                      , conduit
                        -- For httpAPEither
                      , conduit-extra
@@ -344,10 +355,7 @@ library
                      , data-default-class
                      , data-default-instances-bytestring
                      , data-ordlist
-                       -- for drawing DAGs: RBAC role inheritance, etc.
+                     --, diff-parse
-                       , diagrams-core
-                       , diagrams-lib
-                       , diagrams-svg
                      , directory
                        -- for Data.Git.Local
                      , directory-tree
@@ -372,15 +380,10 @@ library
                      , http-client-signature
                      , html-entities
                      , http-signature
-                     , git
                      , gitrev
-                     , hit-graph
-                     , hit-harder
-                     , hit-network
                      -- currently discarding all JS so no need for minifier
                      --, hjsmin
-                     -- 'git' uses it for 'GitTime'
+                     --, hourglass
-                     , hourglass
                      , yesod-http-signature
                      , http-client
                      , http-client-tls
@@ -400,15 +403,13 @@ library
                      , pandoc-types
                        -- for PathPiece instance for CI, Web.PathPieces.Local
                      , path-pieces
-                     , patience
+                     --, patience
                      , pem
                      , persistent
                      , persistent-email-address
-                     , persistent-graph
                      , persistent-migration
                      , persistent-postgresql
                      , persistent-sqlite
-                     , persistent-template
                      , process
                        -- for generating hashids salt
                      , random
@@ -416,6 +417,7 @@ library
                      , resourcet
                      , retry
                      , safe
+                     , semialign
                      , shakespeare
                        -- for json debug highlighting in Yesod.RenderSource
                      , skylighting
@@ -423,10 +425,6 @@ library
                      , ssh
                        -- for holding actor key in a TVar
                      , stm
-                       -- for rendering diagrams
-                     , svg-builder
-                       -- for text drawing in 'diagrams'
-                     , SVGFonts
                      , template-haskell
                      , temporary
                      , text
@@ -440,6 +438,10 @@ library
                        -- probably should be replaced with lenses once I learn
                      , tuple
                      , typed-process
+                       -- for the actor system Theater actormap
+                     , typerep-map
+                     , first-class-families
+                     , HList
                        -- For making git hooks executable, i.e. set file mode
                      , unix
                        -- For httpAPEither