diff --git a/config/settings-default.yaml b/config/settings-default.yaml index bfb7bbf..e23eadc 100644 --- a/config/settings-default.yaml +++ b/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 ############################################################################### diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs index 65c3b5f..c68d9ee 100644 --- a/src/Control/Concurrent/Actor.hs +++ b/src/Control/Concurrent/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2023 by fr33domlover . + - Written in 2019, 2020, 2023, 2024 by fr33domlover . - - ♡ 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) diff --git a/src/Data/Binary/Get/Local.hs b/src/Data/Binary/Get/Local.hs new file mode 100644 index 0000000..897111a --- /dev/null +++ b/src/Data/Binary/Get/Local.hs @@ -0,0 +1,119 @@ +{- This file is part of hit-network. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module 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" diff --git a/src/Data/Binary/Put/Local.hs b/src/Data/Binary/Put/Local.hs new file mode 100644 index 0000000..0537a0f --- /dev/null +++ b/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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module 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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 8c809db..2b8baf8 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2022 by fr33domlover . + - Written in 2016, 2018, 2019, 2022, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -14,45 +15,78 @@ -} module Data.Git.Local - ( -- * Initialize repo - writeHookFile + ( GitT + , withGitRepo + , withGitRepoE + , git + , git_ + , gitE + , gitE_ + + , writeHookFile , createRepo - -- * View repo content - , EntObjType (..) - , TreeRows - , PathView (..) - , viewPath - -- * View refs - , listBranches - , listTags + , isGitRepo + + , ObjId (..) + , parseObjId + , renderObjId + + , TreeEntryType (..) + , 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 Data.Git -import Data.Git.Harder -import Data.Git.Ref (SHA1) -import Data.Git.Types +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +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.Text.Encoding.Error (lenientDecode) +import Data.Time.Format +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.Set as S (mapMonotonic) +import qualified Data.ByteString as B +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 Data.Hourglass.Local () - -instance SpecToEventTime GitTime where - specToEventTime = specToEventTime . gitTimeUTC - specsToEventTimes = specsToEventTimes . fmap gitTimeUTC +import qualified Data.VersionControl as VC 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 - = RootView TreeRows - | TreeView Text ObjId TreeRows - | BlobView Text ObjId BL.ByteString +withGitRepo :: MonadIO m => FilePath -> GitT m a -> m a +withGitRepo path action = runReaderT action path -viewPath :: Git SHA1 -> Tree SHA1 -> EntPath -> IO PathView -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 +type GitE m a = ExceptT Text (ReaderT FilePath m) a -listBranches :: Git SHA1 -> IO (Set Text) -listBranches git = S.mapMonotonic (T.pack . refNameRaw) <$> branchList git +withGitRepoE :: MonadIO m => FilePath -> GitE m a -> ExceptT Text m a +withGitRepoE path action = ExceptT $ withGitRepo path $ runExceptT action -listTags :: Git SHA1 -> IO (Set Text) -listTags git = S.mapMonotonic (T.pack . refNameRaw) <$> tagList git +git :: MonadIO m => String -> [String] -> GitT m Text +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" diff --git a/src/Data/Patch/Local.hs b/src/Data/Patch/Local.hs index 4c1c69e..09ace37 100644 --- a/src/Data/Patch/Local.hs +++ b/src/Data/Patch/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018 by fr33domlover . + - Written in 2018, 2024 by fr33domlover . - - ♡ 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 (..) - , Edit (..) - , Author (..) + ( 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 } diff --git a/src/Data/VersionControl.hs b/src/Data/VersionControl.hs new file mode 100644 index 0000000..a9a8291 --- /dev/null +++ b/src/Data/VersionControl.hs @@ -0,0 +1,94 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2022, 2024 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +{-# 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 diff --git a/src/Database/Persist/Box/Internal.hs b/src/Database/Persist/Box/Internal.hs index 1769d1c..d0e0b11 100644 --- a/src/Database/Persist/Box/Internal.hs +++ b/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" diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index 858e7d5..ce74b2f 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Network/Git/Get.hs b/src/Network/Git/Get.hs new file mode 100644 index 0000000..79eeffc --- /dev/null +++ b/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 . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Network/Git/Put.hs b/src/Network/Git/Put.hs new file mode 100644 index 0000000..ba49303 --- /dev/null +++ b/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 . + - + - ♡ 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 + - . + -} + +{-# 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" diff --git a/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs b/src/Network/Git/Transport/HTTP/Fetch/RefDiscovery.hs new file mode 100644 index 0000000..4301170 --- /dev/null +++ b/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 . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs b/src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs new file mode 100644 index 0000000..184fcd3 --- /dev/null +++ b/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 . + - + - ♡ 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 + - . + -} + +{-# 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 + } diff --git a/src/Network/Git/Types.hs b/src/Network/Git/Types.hs new file mode 100644 index 0000000..279324f --- /dev/null +++ b/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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module 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 diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 1878dd2..28c0e04 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 1430e02..0fe803f 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/ChangeFeed.hs b/src/Vervis/ChangeFeed.hs index c517c6a..ca21d04 100644 --- a/src/Vervis/ChangeFeed.hs +++ b/src/Vervis/ChangeFeed.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018, 2020, 2022 by fr33domlover . + - Written in 2018, 2020, 2022, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 8b78366..5e2b6af 100644 --- a/src/Vervis/Darcs.hs +++ b/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 . - - ♡ 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) <- - ExceptT $ readCompressedPatch path pch (P.patch <* A.endOfInput) + changes <- + 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 6aabb23..5fad606 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index f7a9ba0..d46fe74 100644 --- a/src/Vervis/Git.hs +++ b/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 . - - ♡ 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.POSIX (posixSecondsToUTCTime) +import Data.Time.Clock 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 (_, _, name, EntObjBlob) = isReadme name -matchReadme _ = False +matchReadme (TreeEntry _ (TETFile _) _ name) = 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 git rows = - case find matchReadme rows of - Nothing -> return Nothing - Just (_perm, oid, name, _etype) -> do - obj <- getObject_ git (unObjId oid) True - return $ case obj of - ObjBlob b -> Just (name, blobGetContent b) - _ -> Nothing +findReadme :: [TreeEntry] -> GitT IO (Maybe (Text, Text)) +findReadme entries = + case find matchReadme entries of + Nothing -> return Nothing + Just (TreeEntry _ _ hash name) -> + Just . (name,) <$> gitGetFileContentByHash hash -matchType :: EntObjType -> EntryType -matchType EntObjBlob = TypeBlob -matchType EntObjTree = TypeTree +matchType (TETFile _) = TypeBlob +matchType TETDir = TypeTree -rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry -rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name +rowToEntry (TreeEntry _ typ _ name) = DirEntry (matchType typ) name loadSourceView - :: Git SHA1 - -> Text + :: Text -> [Text] - -> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString)) -loadSourceView git refT dir = do - branches <- G.branchList git - tags <- G.tagList git - let refS = T.unpack refT - refN = RefName refS + -> GitT IO (Set Text, Set Text, Maybe (SourceView Text)) +loadSourceView ref dir = do + let invalid t = T.null t || t == "." || t == ".." || T.any (== '/') t + when (any invalid dir) $ + error $ "loadSourceView invalid dir: " ++ show dir + 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 - then do - tipOid <- resolveName git refS - mtree <- G.resolveTreeish git $ unObjId tipOid - for mtree $ \ tree -> do - let dir' = map (G.entName . encodeUtf8) dir - view <- viewPath git tree dir' - case view of - RootView rows -> do - mreadme <- findReadme git rows - let ents = map rowToEntry rows - return $ SourceDir $ - DirectoryView Nothing ents mreadme - TreeView name _ rows -> do - mreadme <- findReadme git rows - let ents = map rowToEntry rows - return $ SourceDir $ - DirectoryView (Just name) ents mreadme - BlobView name _ body -> - return $ SourceFile $ FileView name body + else if ref `S.member` branches || ref `S.member` tags + then Just <$> do + let dir' = + if null dir + then Nothing + else Just $ T.unpack $ T.intercalate "/" dir + pt <- + case dir' of + Nothing -> pure PTTree + Just s -> gitGetPathType ref s + case pt of + PTTree -> do + entries <- gitListDir ref dir' + mreadme <- findReadme entries + let ents = map rowToEntry entries + mname = + if isNothing dir' + then Nothing + 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 - -- ^ Repository path - -> Text + :: 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 - (bs, ts, msv) <- - G.withRepo (fromString path) $ \ git -> loadSourceView git ref dir - let toTexts = S.mapMonotonic $ T.pack . refNameRaw - return (toTexts bs, toTexts ts, renderSources dir <$> msv) +readSourceView ref dir = do + (bs, ts, msv) <- loadSourceView ref dir + return (bs, ts, renderSources dir <$> msv) readChangesView - :: FilePath - -- ^ Repository path - -> Text + :: 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 - oid <- resolveName git $ T.unpack ref - graph <- loadCommitGraphPT git [oid] - let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph]) - nodes = case mnodes of - Nothing -> error "commit graph contains a cycle" - Just ns -> ns - pairs = D.toList $ fmap (nodeLabel graph) nodes - 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 +readChangesView ref off lim = do + commits <- gitGetCommitInfos ref [] Nothing Nothing + now <- liftIO getCurrentTime + let commits' = take lim $ drop off commits + mkrow commit = LogEntry + { leAuthor = VC.authorName $ fst $ VC.commitWritten commit + , leHash = VC.commitHash commit + , leMessage = VC.commitTitle commit , leTime = - ( utc t - , intervalToEventTime $ - FriendlyConvert $ - now - t - ) + let t = snd $ VC.commitWritten commit + in ( t + , intervalToEventTime $ FriendlyConvert $ + now `diffUTCTime` t + ) } - where - 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, []) + return (length commits, map mkrow commits') {- -lastCommitTime :: FilePath -> IO (Maybe UTCTime) -lastCommitTime repo = - (either fail return =<<) $ fmap join $ withRepo (fromString repo) $ runExceptT $ do - branches <- S.toList <$> lift branchList - lct <- foldlM' utc0 branches $ \ time branch -> do - mcommit <- lift $ getCommit branch - case mcommit of - Nothing -> - throwE $ - "lastCommitTime: Failed to get commit for branch " ++ - refNameRaw branch - Just c -> - return $ max time $ - utc $ gitTimeUTC $ personTime $ commitCommitter c - return $ if null branches - then Nothing - else Just lct +gatherLines (Hunk _ _ lines) = map lineContent lines + +toEdit (FileDelta Created _ dest Binary) = + P.AddBinaryFile (T.unpack dest) 0 0 +toEdit (FileDelta Created _ dest (Hunks hunks)) = + P.AddTextFile (T.unpack dest) 0 $ concatMap gatherLines hunks +toEdit (FileDelta Deleted source _ Binary) = + P.RemoveBinaryFile (T.unpack source) 0 0 +toEdit (FileDelta Deleted source _ (Hunks hunks)) = + P.RemoveTextFile (T.unpack source) 0 $ concatMap gatherLines hunks +toEdit (FileDelta Modified _ dest Binary) = + P.EditBinaryFile (T.unpack dest) 0 0 0 0 +toEdit (FileDelta Modified _ dest (Hunks [])) = error "Modified into empty?" +toEdit (FileDelta Modified _ dest (Hunks (h:unks))) = + P.EditTextFile (T.unpack dest) V.empty (NE.map adaptHunk $ h:|unks) 0 0 where - utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i - utc0 = UTCTime (ModifiedJulianDay 0) 0 - foldlM' i l f = foldlM f i l + adaptHunk _ = error "TODO adaptHunk: implement properly" -} +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 diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index ed869e3..52ac7cd 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 8985045..bbd0f5d 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index e61b09a..afaf1b3 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 diff --git a/src/Vervis/Hook.hs b/src/Vervis/Hook.hs index 287c36a..d1c7161 100644 --- a/src/Vervis/Hook.hs +++ b/src/Vervis/Hook.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2024 by fr33domlover . - - ♡ 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 - eof <- isEOF + -- Written while looking at contrib/hooks/post-receive-email in Git source repo + 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 - newRef <- do - mr <- parseRef new - case mr of - Nothing -> throwE $ "Ref deletion: " <> new - Just r -> return r + let change = + if isZeroObj old + then Create new + else if isZeroObj new + then Delete old + 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 - Just t | not (T.null t) -> return t - _ -> throwE $ "Unexpected refname: " <> refname - graph <- liftIO $ loadCommitGraphPT git [ObjId newRef] - nodes <- - case topsortUnmixOrder graph (NodeStack [noNodes graph]) of - Nothing -> throwE "Commit graph contains a cycle" - Just ns -> return ns - historyAll <- - case nonEmpty $ D.toList $ nodeLabel graph <$> nodes of - Nothing -> throwE "Empty commit graph" - Just h -> return h - historyNew <- - case moldRef of - Nothing -> return historyAll - Just oldRef -> do - let (before, after) = - NE.break - ((== ObjId oldRef) . fst) - 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 + case situation of + Branch b -> pure b + _ -> throwE "Non-branch situation, not supported yet" + + refSpec <- + case change of + Create h -> pure $ renderObjId h + Delete _ -> throwE "Branch deletion, not supported yet" + Update o n -> pure $ renderObjId o <> ".." <> renderObjId n + otherBranchHashes <- lift $ do + otherBranches <- S.delete branch <$> gitListBranches + gitGetObjectHashes $ map ("refs/heads/" <>) $ S.toList otherBranches + commits <- lift $ gitGetCommitInfos refSpec otherBranchHashes Nothing Nothing + commits' <- + case NE.nonEmpty commits of + Nothing -> throwE "No commits" + Just ne -> pure ne + + (early, late) <- splitCommits config commits' let push = Push { pushSecret = configSecret config , pushUser = user , pushRepo = repo , pushBranch = Just branch - , pushBefore = old <$ moldRef - , pushAfter = Just new + , pushBefore = + 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 = - 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 - ) + isZeroObj (ObjId b) = B.all (== 0) b postReceive :: IO () postReceive = do diff --git a/src/Vervis/Migration/Model2016.hs b/src/Vervis/Migration/Model2016.hs index 30e3c6e..c73799e 100644 --- a/src/Vervis/Migration/Model2016.hs +++ b/src/Vervis/Migration/Model2016.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2016 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2018.hs b/src/Vervis/Migration/Model2018.hs index e7d0546..e9b5d8a 100644 --- a/src/Vervis/Migration/Model2018.hs +++ b/src/Vervis/Migration/Model2018.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2018 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2019.hs b/src/Vervis/Migration/Model2019.hs index ac7763c..4291ccc 100644 --- a/src/Vervis/Migration/Model2019.hs +++ b/src/Vervis/Migration/Model2019.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2019 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2020.hs b/src/Vervis/Migration/Model2020.hs index aa0e38c..156dc54 100644 --- a/src/Vervis/Migration/Model2020.hs +++ b/src/Vervis/Migration/Model2020.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2020 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2022.hs b/src/Vervis/Migration/Model2022.hs index 43769f8..bb1244c 100644 --- a/src/Vervis/Migration/Model2022.hs +++ b/src/Vervis/Migration/Model2022.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2022 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2023.hs b/src/Vervis/Migration/Model2023.hs index dba3521..c7e98a5 100644 --- a/src/Vervis/Migration/Model2023.hs +++ b/src/Vervis/Migration/Model2023.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2023 {- ( EntityField (..) diff --git a/src/Vervis/Migration/Model2024.hs b/src/Vervis/Migration/Model2024.hs index e9757e6..a1c782c 100644 --- a/src/Vervis/Migration/Model2024.hs +++ b/src/Vervis/Migration/Model2024.hs @@ -14,6 +14,8 @@ - . -} +{-# LANGUAGE UndecidableInstances #-} + module Vervis.Migration.Model2024 {- ( EntityField (..) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index b4e7229..7987377 100644 --- a/src/Vervis/Model.hs +++ b/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 . - - ♡ 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 diff --git a/src/Vervis/Persist/Discussion.hs b/src/Vervis/Persist/Discussion.hs index e6a1a76..3af46e7 100644 --- a/src/Vervis/Persist/Discussion.hs +++ b/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 . - - ♡ 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" - (Just _, Just _) -> fail "Message used as both local and remote" + (Nothing, Nothing) -> error "Message with no author" + (Just _, Just _) -> error "Message used as both local and remote" (Just (Entity lmid lm), Nothing) -> do let actorID = localMessageAuthor lm name <- actorName <$> getJust actorID diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs index acdc9ac..6e99369 100644 --- a/src/Vervis/Persist/Ticket.hs +++ b/src/Vervis/Persist/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Readme.hs b/src/Vervis/Readme.hs index e666fac..50c06f3 100644 --- a/src/Vervis/Readme.hs +++ b/src/Vervis/Readme.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 6f8fa89..3e95ae5 100644 --- a/src/Vervis/Settings.hs +++ b/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" - Just _ -> return $ T.pack s + Nothing -> fail $ "Highlighting style " ++ T.unpack s ++ " not found" + Just _ -> return s appMainColor <- o .:? "main-color" .!= 0 return AppSettings {..} diff --git a/src/Vervis/SourceTree.hs b/src/Vervis/SourceTree.hs index b55fbfc..a85b651 100644 --- a/src/Vervis/SourceTree.hs +++ b/src/Vervis/SourceTree.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 78742f6..fb468da 100644 --- a/src/Vervis/Ssh.hs +++ b/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 diff --git a/src/Vervis/TicketFilter.hs b/src/Vervis/TicketFilter.hs index f469dc6..f275ae3 100644 --- a/src/Vervis/TicketFilter.hs +++ b/src/Vervis/TicketFilter.hs @@ -34,9 +34,11 @@ instance Default TicketFilter where def = TicketFilter True True filterTickets - :: Esqueleto q e b - => TicketFilter - -> Maybe (e (Maybe (Entity TicketResolve)) -> e (Value Bool)) + :: TicketFilter + -> Maybe + ( 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 diff --git a/src/Vervis/Web/Git.hs b/src/Vervis/Web/Git.hs index bd351dd..8a19740 100644 --- a/src/Vervis/Web/Git.hs +++ b/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 - serveCommit hash ref patch parents + oid <- liftIO $ parseObjId ref + (patch, parents) <- liftIO $ withGitRepo path $ G.readPatch oid + let parents' = map renderObjId parents + serveCommit hash ref patch parents' diff --git a/src/Vervis/Widget.hs b/src/Vervis/Widget.hs index 3a624e5..e983a49 100644 --- a/src/Vervis/Widget.hs +++ b/src/Vervis/Widget.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2023 by fr33domlover . + - Written in 2016, 2018, 2019, 2023, 2024 + - by fr33domlover . - - ♡ 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") diff --git a/src/Vervis/Widget/Repo.hs b/src/Vervis/Widget/Repo.hs index 1cd9b6c..7a9c815 100644 --- a/src/Vervis/Widget/Repo.hs +++ b/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 diff --git a/src/Web/Text.hs b/src/Web/Text.hs index 4fb8ee6..fec6e69 100644 --- a/src/Web/Text.hs +++ b/src/Web/Text.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2022 by fr33domlover . + - Written in 2016, 2018, 2019, 2022, 2024 + - by fr33domlover . - - ♡ 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.Sql +import Database.Persist hiding (Escaped) +import Database.Persist.Sql hiding (Escaped) import HTMLEntities.Decoder import Text.Blaze (preEscapedText) import Text.Blaze.Html (Html) diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs index 731eedc..1cae236 100644 --- a/src/Yesod/MonadSite.hs +++ b/src/Yesod/MonadSite.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2024 by fr33domlover . - - ♡ 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) diff --git a/stack.yaml b/stack.yaml index 534afb7..fe7aa69 100644 --- a/stack.yaml +++ b/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 - - 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 + commit: 2a93bf977b7b1529212999f05525e9158afde7ad - 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 - - data-default-instances-bytestring-0.0.1 - - esqueleto-2.7.0 - - git-0.3.0 - - graphviz-2999.20.0.3 + - darcs-2.16.5 + - constraints-0.12 +# - data-default-instances-bytestring-0.0.1 +# - esqueleto-2.7.0 +# - 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 - - url-2.1.3 - - annotated-exception-0.2.0.4 +# - time-units-1.0.0 +# - url-2.1.3 + - annotated-exception-0.3.0.1 - retry-0.9.3.1 - - base58-bytestring-0.1.0 - - indexed-profunctors-0.1.1 - - indexed-traversable-0.1.2.1 - - optics-core-0.4.1 +# - base58-bytestring-0.1.0 +# - indexed-profunctors-0.1.1 +# - indexed-traversable-0.1.2.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: diff --git a/templates/repo/patch.hamlet b/templates/repo/patch.hamlet index 919e91e..ea868fc 100644 --- a/templates/repo/patch.hamlet +++ b/templates/repo/patch.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2018, 2019, 2022 by fr33domlover . +$# Written in 2018, 2019, 2022, 2024 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -40,65 +40,10 @@ $# .

#{patchDescription patch} -$if null parents -

    - $forall edit <- patchDiff patch -
  • - $case edit - $of AddTextFile path mode lines -

    Add file #{path} #{mode} - - $forall (n, t) <- number lines - -
    + - #{n} - #{t} - $of AddBinaryFile path mode size -

    Add binary file #{path} #{mode} #{size} - $of RemoveTextFile path mode lines -

    Remove file #{path} #{mode} - - $forall (n, t) <- number lines - -
    - - #{n} - #{t} - $of RemoveBinaryFile path mode size -

    Remove binary file #{path} #{mode} #{size} - $of MoveFile oldPath oldMode newPath newMode -

    Move file #{oldPath} #{oldMode} → #{newPath} #{newMode} - $of ChmodFile path old new -

    Change file mode #{path} #{old} → #{new} - $of EditTextFile path orig hunks oldMode newMode -

    Edit file #{path} #{oldMode} → #{newMode} - ^{inlineDiffW orig hunks} - $of EditBinaryFile path oldSize oldMode newSize newMode -

    - Edit binary file #{path} #{oldSize} #{oldMode} → - #{newSize} #{newMode} - $of TextToBinary path lines oldMode newSize newMode -

    Edit file #{path} #{oldMode} → #{newSize} #{newMode} - - $forall (n, t) <- number lines - -
    - - #{n} - #{t} - $of BinaryToText path oldSize oldMode lines newMode -

    Edit file #{path} #{oldMode} #{oldSize} → #{newMode} - - $forall (n, t) <- number lines - -
    + - #{n} - #{t} -$else -

    - 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: -

      - $forall parent <- parents -
    1. #{parent} +

      Parent commits: +

        + $forall parent <- parents +
      1. #{parent} + +

        Diff: +

        #{patchDiff patch}
diff --git a/templates/repo/widget/inline-diff.cassius b/templates/repo/widget/inline-diff.cassius
deleted file mode 100644
index e6409fd..0000000
--- a/templates/repo/widget/inline-diff.cassius
+++ /dev/null
@@ -1,28 +0,0 @@
-/* This file is part of Vervis.
- *
- * Written in 2018 by fr33domlover .
- *
- * ♡ Copying is an act of love. Please copy, reuse and share.
- *
- * The author(s) have dedicated all copyright and related and neighboring
- * rights to this software to the public domain worldwide. This software is
- * distributed without any warranty.
- *
- * You should have received a copy of the CC0 Public Domain Dedication along
- * with this software. If not, see
- * .
- */
-
-pre
-    margin: 0px
-
-.lines
-    font-family: monospace
-
-.remove
-    background: #{light red}
-    color:      #{black}
-
-.add
-    background: #{light green}
-    color:      #{black}
diff --git a/templates/repo/widget/inline-diff.hamlet b/templates/repo/widget/inline-diff.hamlet
deleted file mode 100644
index 99668dc..0000000
--- a/templates/repo/widget/inline-diff.hamlet
+++ /dev/null
@@ -1,44 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 2018 by fr33domlover .
-$#
-$# ♡ Copying is an act of love. Please copy, reuse and share.
-$#
-$# The author(s) have dedicated all copyright and related and neighboring
-$# rights to this software to the public domain worldwide. This software is
-$# distributed without any warranty.
-$#
-$# You should have received a copy of the CC0 Public Domain Dedication along
-$# with this software. If not, see
-$# .
-
-
-  $forall lines <- diffs
-    $forall (ln, t) <- lines
-      $case ln
-        $of Old n
-          
-            
-            
-            
-      
        -
-            #{n}
-            
-            
-              
        #{t}
-        $of New n
-          
        +
-            
-            #{n}
-            
-              
        #{t}
-        $of Both o n
-          
        
-            #{o}
-            #{n}
-            
-              
        #{t}
-    
        …
-      …
-      …
-      …
diff --git a/update-deps.sh b/update-deps.sh
index 1ee0ffc..d107826 100755
--- a/update-deps.sh
+++ b/update-deps.sh
@@ -2,10 +2,7 @@
 
 VERVIS='https://vervis.peers.community/repos'
 
-DEPS="6r4Ao   ssh                      \n
-      AoO7o   time-interval-aeson      \n
-      r6WGo   yesod-http-signature     \n
-      2vanE   yesod-mail-send"
+DEPS="6r4Ao   ssh"
 
 mkdir -p lib
 cd lib
diff --git a/vervis.cabal b/vervis.cabal
index b65a3c5..8a06389 100644
--- a/vervis.cabal
+++ b/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.Content
+                       --Vervis.Colour
+                       --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.
-                       , diagrams-core
-                       , diagrams-lib
-                       , diagrams-svg
+                     --, diff-parse
                      , 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