DB: Add media type field to 'Patch' entity

This patch (haha) also adds a VCS field to the AP representation of repos
2020-08-14 21:16:33 +00:00 · 2020-08-14 21:16:33 +00:00 · cb11ea6447
commit cb11ea6447
parent b16c9505af
29 changed files with 304 additions and 144 deletions
--- a/config/models
+++ b/config/models
@ -456,6 +456,7 @@ Bundle
 Patch
    bundle  BundleId
    created UTCTime
+    type    PatchMediaType
    content Text

 TicketDependencyOffer
--- a/migrations/2020_08_13_vcs.model
+++ b/migrations/2020_08_13_vcs.model
@ -0,0 +1,24 @@
+Sharer
+Project
+Role
+Inbox
+Outbox
+FollowerSet
+
+Repo
+    ident      RpIdent
+    sharer     SharerId
+    vcs        Text
+    project    ProjectId            Maybe
+    desc       Text                 Maybe
+    mainBranch Text
+    collabUser RoleId               Maybe
+    collabAnon RoleId               Maybe
+    inbox      InboxId
+    outbox     OutboxId
+    followers  FollowerSetId
+
+    UniqueRepo ident sharer
+    UniqueRepoInbox inbox
+    UniqueRepoOutbox outbox
+    UniqueRepoFollowers followers
--- a/src/Data/Aeson/Local.hs
+++ b/src/Data/Aeson/Local.hs
@ -58,7 +58,7 @@ fromEither (Right y) = Right' y
 (.:|) :: FromJSON a => Object -> Text -> Parser a
 o .:| t = o .: t <|> o .: (frg <> t)
    where
-    frg = "https://forgefed.angeley.es/ns#"
+    frg = "https://forgefed.peers.community/ns#"

 (.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
 o .:|? t = optional $ o .:| t
--- a/src/Development/PatchMediaType.hs
+++ b/src/Development/PatchMediaType.hs
@ -0,0 +1,73 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Development.PatchMediaType
+    ( VersionControlSystem (..)
+    , PatchMediaType (..)
+    , parseVersionControlSystemName
+    , parseVersionControlSystemURI
+    , versionControlSystemName
+    , versionControlSystemURI
+    , patchMediaTypeVCS
+    , parsePatchMediaType
+    , renderPatchMediaType
+    )
+where
+
+import Control.Monad
+import Data.Text (Text)
+
+import qualified Data.Text as T
+
+data VersionControlSystem = VCSDarcs | VCSGit deriving Eq
+
+data PatchMediaType = PatchMediaTypeDarcs deriving Eq
+
+forgeFedPrefix :: Text
+forgeFedPrefix = "https://forgefed.peers.community/ns#"
+
+parseVersionControlSystemName :: Text -> Maybe VersionControlSystem
+parseVersionControlSystemName = parse . T.toLower
+    where
+    parse "darcs" = Just VCSDarcs
+    parse "git"   = Just VCSGit
+    parse _       = Nothing
+
+parseVersionControlSystemURI :: Text -> Maybe VersionControlSystem
+parseVersionControlSystemURI = parse <=< T.stripPrefix forgeFedPrefix
+    where
+    parse "darcs" = Just VCSDarcs
+    parse "git"   = Just VCSGit
+    parse _       = Nothing
+
+versionControlSystemName :: VersionControlSystem -> Text
+versionControlSystemName VCSDarcs = "Darcs"
+versionControlSystemName VCSGit   = "Git"
+
+versionControlSystemURI :: VersionControlSystem -> Text
+versionControlSystemURI vcs = forgeFedPrefix <> rest vcs
+    where
+    rest VCSDarcs = "darcs"
+    rest VCSGit   = "git"
+
+patchMediaTypeVCS :: PatchMediaType -> VersionControlSystem
+patchMediaTypeVCS PatchMediaTypeDarcs = VCSDarcs
+
+parsePatchMediaType :: Text -> Maybe PatchMediaType
+parsePatchMediaType "application/x-darcs-patch" = Just PatchMediaTypeDarcs
+parsePatchMediaType _                           = Nothing
+
+renderPatchMediaType :: PatchMediaType -> Text
+renderPatchMediaType PatchMediaTypeDarcs = "application/x-darcs-patch"
--- a/src/Development/PatchMediaType/JSON.hs
+++ b/src/Development/PatchMediaType/JSON.hs
@ -0,0 +1,45 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Development.PatchMediaType.JSON () where
+
+import Data.Aeson
+
+import qualified Data.Text as T
+
+import Development.PatchMediaType
+
+instance FromJSON VersionControlSystem where
+    parseJSON =
+        withText "VersionControlSystem" $ \ t ->
+            case parseVersionControlSystemURI t of
+                Nothing ->
+                    fail $ "Unknown version control system URI: " ++ T.unpack t
+                Just vcs -> return vcs
+
+instance ToJSON VersionControlSystem where
+    toJSON = toJSON . versionControlSystemURI
+    toEncoding = toEncoding . versionControlSystemURI
+
+instance FromJSON PatchMediaType where
+    parseJSON =
+        withText "PatchMediaType" $ \ t ->
+            case parsePatchMediaType t of
+                Nothing -> fail $ "Unknown patch media type: " ++ T.unpack t
+                Just pmt -> return pmt
+
+instance ToJSON PatchMediaType where
+    toJSON = toJSON . renderPatchMediaType
+    toEncoding = toEncoding . renderPatchMediaType
--- a/src/Development/PatchMediaType/Persist.hs
+++ b/src/Development/PatchMediaType/Persist.hs
@ -0,0 +1,43 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Development.PatchMediaType.Persist () where
+
+import Database.Persist
+import Database.Persist.Sql
+
+import Development.PatchMediaType
+
+instance PersistField VersionControlSystem where
+    toPersistValue = toPersistValue . versionControlSystemName
+    fromPersistValue v = do
+        t <- fromPersistValue v
+        case parseVersionControlSystemName t of
+            Nothing -> Left $ "Unknown version control system name: " <> t
+            Just vcs -> Right vcs
+
+instance PersistFieldSql VersionControlSystem where
+    sqlType = sqlType . fmap versionControlSystemName
+
+instance PersistField PatchMediaType where
+    toPersistValue = toPersistValue . renderPatchMediaType
+    fromPersistValue v = do
+        t <- fromPersistValue v
+        case parsePatchMediaType t of
+            Nothing -> Left $ "Unknown patch media type: " <> t
+            Just pmt -> Right pmt
+
+instance PersistFieldSql PatchMediaType where
+    sqlType = sqlType . fmap renderPatchMediaType
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@ -85,7 +85,7 @@ import Crypto.PublicVerifKey
 import Database.Persist.JSON
 import Network.FedURI
 import Network.HTTP.Digest
-import Web.ActivityPub hiding (Patch, Ticket, Follow)
+import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..))
 import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
@ -111,7 +111,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
 import Vervis.Settings
@ -578,7 +578,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                                        , projectInbox j
                                        , LocalActorProject shr prj
                                        )
-                                Right (Entity _ r, _, _) ->
+                                Right (Entity _ r, _, _, _) ->
                                    let rp = repoIdent r
                                    in  ( [ LocalPersonCollectionRepoTeam shr rp
                                          , LocalPersonCollectionRepoFollowers shr rp
@ -612,7 +612,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                ( Host
                , LocalURI
                , LocalURI
-                , Maybe (Maybe LocalURI, PatchType, NonEmpty Text)
+                , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)
                )
            , TextHtml
            , TextHtml
@ -653,7 +653,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
        checkTicket
            :: AP.Ticket URIMode
            -> ExceptT Text Handler
-                ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
+                ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
                , TextHtml
                , TextHtml
                , TextPandocMarkdown
@ -679,7 +679,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                -> MergeRequest URIMode
                -> ExceptT Text Handler
                    ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
-                    , PatchType
+                    , PatchMediaType
                    , NonEmpty Text
                    )
            checkMR h (MergeRequest muOrigin luTarget ebundle) = do
@ -724,7 +724,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                        :: Host
                        -> AP.Patch URIMode
                        -> ExceptT Text Handler
-                            ( PatchType
+                            ( PatchMediaType
                            , Text
                            )
                    checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
@ -741,7 +741,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                    FedURI
                -> Maybe
                    ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
-                    , PatchType
+                    , PatchMediaType
                    , NonEmpty Text
                    )
                -> ExceptT Text Handler
@ -749,7 +749,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                        WorkItemTarget
                        ( Host
                        , LocalURI
-                        , Maybe (Maybe LocalURI, PatchType, NonEmpty Text)
+                        , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)
                        )
                    )
            matchContextAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj
@ -760,17 +760,14 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                    case branch of
                        Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
                        _ -> throwE "MR target repo/branch and Ticket context repo mismatch"
-                let vcs = typ2vcs typ
-                case vcs of
+                case patchMediaTypeVCS typ of
                    VCSDarcs ->
                        unless (isNothing branch') $
                            throwE "Darcs MR specifies a branch"
                    VCSGit ->
                        unless (isJust branch') $
                            throwE "Git MR doesn't specify the branch"
-                return $ Left $ WITRepo shr rp branch' vcs diffs
-                where
-                typ2vcs PatchTypeDarcs = VCSDarcs
+                return $ Left $ WITRepo shr rp branch' typ diffs
            matchContextAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
            matchContextAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do
                luBranch <-
@ -789,14 +786,14 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                FedURI
            -> Either
                WorkItemTarget
-                (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
+                (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
            -> ExceptT Text Handler
                (Either
                    WorkItemTarget
                    ( Host
                    , LocalURI
                    , LocalURI
-                    , Maybe (Maybe LocalURI, PatchType, NonEmpty Text)
+                    , Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text)
                    )
                )
        checkTargetAndContext (Left _) (Right _) =
@ -836,14 +833,15 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
        ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
        obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
        return (shr, Left ej, obiidAccept)
-    prepareProject now (Left (WITRepo shr rp mb vcs diff)) = Left <$> do
+    prepareProject now (Left (WITRepo shr rp mb typ diff)) = Left <$> do
        mer <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            MaybeT $ getBy $ UniqueRepo rp sid
        er@(Entity _ r) <- fromMaybeE mer "Local context: no such repo"
-        unless (repoVcs r == vcs) $ throwE "Repo VCS and patch VCS mismatch"
+        unless (repoVcs r == patchMediaTypeVCS typ) $
+            throwE "Repo VCS and patch VCS mismatch"
        obiidAccept <- lift $ insertEmptyOutboxItem (repoOutbox r) now
-        return (shr, Right (er, mb, diff), obiidAccept)
+        return (shr, Right (er, mb, typ, diff), obiidAccept)
    prepareProject _   (Right (iid, era, mlu, mpatch)) = lift $ Right <$> do
        let mlu' =
                case mpatch of
@ -889,7 +887,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                                , ticketProjectLocalProject = jid
                                }
                            return Nothing
-                        Right (Entity rid _, mb, diffs) -> Just <$> do
+                        Right (Entity rid _, mb, typ, diffs) -> Just <$> do
                            insert_ TicketRepoLocal
                                { ticketRepoLocalContext = tclid
                                , ticketRepoLocalRepo    = rid
@ -898,18 +896,18 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                            bnid <- insert $ Bundle tid
                            (bnid,) . toNE <$>
                                insertMany
-                                    (NE.toList $ NE.map (Patch bnid now) diffs)
+                                    (NE.toList $ NE.map (Patch bnid now typ) diffs)
                Right (Entity raid _, mroid, mbundle) -> do
                    insert_ TicketProjectRemote
                        { ticketProjectRemoteTicket  = talid
                        , ticketProjectRemoteTracker = raid
                        , ticketProjectRemoteProject = mroid
                        }
-                    for mbundle $ \ (_typ, diffs) -> do
+                    for mbundle $ \ (typ, diffs) -> do
                        bnid <- insert $ Bundle tid
                        (bnid,) . toNE <$>
                            insertMany
-                                (NE.toList $ NE.map (Patch bnid now) diffs)
+                                (NE.toList $ NE.map (Patch bnid now typ) diffs)
        return (talid, mbn)
        where
        toNE = fromMaybe (error "No Patch IDs returned from DB") . NE.nonEmpty
@ -930,7 +928,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                    Left (WITProject shr prj) ->
                        let uProject = encodeRouteHome $ ProjectR shr prj
                        in  (uProject, uProject, Nothing)
-                    Left (WITRepo shr rp mb vcs diffs) ->
+                    Left (WITRepo shr rp mb typ diffs) ->
                        let uRepo = encodeRouteHome $ RepoR shr rp
                            (bnkhid, ptkhids) =
                                case mkh of
@ -939,10 +937,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                            luBundle =
                                encodeRouteLocal $
                                    SharerProposalBundleR shrUser talkhid bnkhid
-                            typ =
-                                case vcs of
-                                    VCSDarcs -> PatchTypeDarcs
-                                    VCSGit -> error "createTicketC VCSGit"
                            mr = MergeRequest
                                { mrOrigin = Nothing
                                , mrTarget =
@ -1081,7 +1075,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
                    Left (Entity _ j) ->
                        let prj = projectIdent j
                        in  (ProjectOutboxItemR shrJ prj, ProjectR shrJ prj)
-                    Right (Entity _ r, _, _) ->
+                    Right (Entity _ r, _, _, _) ->
                        let rp = repoIdent r
                        in  (RepoOutboxItemR shrJ rp, RepoR shrJ rp)
            recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
@ -1342,14 +1336,15 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                        ej <- MaybeT $ getBy $ UniqueProject prj sid
                        return (s, ej)
                    fromMaybeE mproj "Offer target no such local project in DB"
-                Left (WITRepo shr rp mb vcs diffs) -> Just . Right <$> do
+                Left (WITRepo shr rp mb typ diffs) -> Just . Right <$> do
                    mproj <- lift $ runMaybeT $ do
                        Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
                        er <- MaybeT $ getBy $ UniqueRepo rp sid
                        return (s, er)
                    (s, er@(Entity _ r)) <- fromMaybeE mproj "Offer target no such local repo in DB"
-                    unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
-                    return (s, er, mb, diffs)
+                    unless (repoVcs r == patchMediaTypeVCS typ) $
+                        throwE "Patch type and repo VCS mismatch"
+                    return (s, er, mb, typ, diffs)
                Right _ -> return Nothing
        (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
        remotesHttpOffer <- do
@ -1390,20 +1385,20 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
            let obid =
                    case project of
                        Left (_, Entity _ j) -> projectOutbox j
-                        Right (_, Entity _ r, _, _) -> repoOutbox r
+                        Right (_, Entity _ r, _, _, _) -> repoOutbox r
            obiidAccept <- insertEmptyOutboxItem obid now
            let insertTXL =
                    case project of
                        Left (_, Entity jid _) ->
                            \ tclid -> insert_ $ TicketProjectLocal tclid jid
-                        Right (_, Entity rid _, mb, _) ->
+                        Right (_, Entity rid _, mb, _, _) ->
                            \ tclid -> insert_ $ TicketRepoLocal tclid rid mb
            (tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept
            case project of
                Left _ -> return ()
-                Right (_, _, _, diffs) -> do
+                Right (_, _, _, typ, diffs) -> do
                    bnid <- insert $ Bundle tid
-                    insertMany_ $ NE.toList $ NE.map (Patch bnid now) diffs
+                    insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs
            (docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
            let (actor, ibid) =
                    case project of
@ -1411,7 +1406,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                            ( LocalActorProject (sharerIdent s) (projectIdent j)
                            , projectInbox j
                            )
-                        Right (s, Entity _ r, _, _) ->
+                        Right (s, Entity _ r, _, _, _) ->
                            ( LocalActorRepo (sharerIdent s) (repoIdent r)
                            , repoInbox r
                            )
@ -1430,7 +1425,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
        -> AP.Ticket URIMode
        -> FedURI
        -> ExceptT Text Handler
-            ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
+            ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
            , TextHtml
            , TextHtml
            , TextPandocMarkdown
@ -1528,17 +1523,14 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                case branch of
                    Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
                    _ -> throwE "MR target repo/branch and Offer target repo mismatch"
-            let vcs = typ2vcs typ
-            case vcs of
+            case patchMediaTypeVCS typ of
                VCSDarcs ->
                    unless (isNothing branch') $
                        throwE "Darcs MR specifies a branch"
                VCSGit ->
                    unless (isJust branch') $
                        throwE "Git MR doesn't specify the branch"
-            return $ Left $ WITRepo shr rp branch' vcs diffs
-            where
-            typ2vcs PatchTypeDarcs = VCSDarcs
+            return $ Left $ WITRepo shr rp branch' typ diffs
        matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
        matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do
            luBranch <-
@ -1612,7 +1604,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
                            , ProjectR shr prj
                            , ProjectTicketR shr prj
                            )
-                    Right (s, Entity _ r, _, _) ->
+                    Right (s, Entity _ r, _, _, _) ->
                        let shr = sharerIdent s
                            rp = repoIdent r
                        in  ( [ LocalPersonCollectionRepoTeam shr rp
--- a/src/Vervis/Application.hs
+++ b/src/Vervis/Application.hs
@ -121,7 +121,7 @@ import Vervis.Handler.Workflow
 import Vervis.Migration (migrateDB)
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path
 import Vervis.Settings
 import Vervis.Ssh (runSsh)
@ -244,7 +244,8 @@ makeFoundation appSettings = do
            for_ rps $ \ (rp, vcs) ->
                putStrLn $
                    "Found repo " ++
-                    shr ++ " / " ++ rp ++ " [" ++ show vcs ++ "]"
+                    shr ++ " / " ++ rp ++
+                    " [" ++ T.unpack (versionControlSystemName vcs) ++ "]"
    repoTreeFromDir = do
        dir <- askRepoRootDir
        outers <- liftIO $ sort <$> listDirectory dir
--- a/src/Vervis/ChangeFeed.hs
+++ b/src/Vervis/ChangeFeed.hs
@ -28,7 +28,7 @@ import qualified Data.Text as T (concat)
 import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType

 changeEntry :: ShrIdent -> RpIdent -> LogEntry -> FeedEntry (Route App)
 changeEntry shr rp le = FeedEntry
--- a/src/Vervis/Darcs.hs
+++ b/src/Vervis/Darcs.hs
@ -83,7 +83,7 @@ import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path
 import Vervis.Readme
 import Vervis.Settings
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@ -68,7 +68,7 @@ import qualified Data.Text.Lazy as TL

 import Database.Persist.JSON
 import Network.FedURI
-import Web.ActivityPub hiding (Patch, Ticket (..))
+import Web.ActivityPub hiding (Patch, Ticket (..), Repo (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@ -89,7 +89,7 @@ import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.Patch
 import Vervis.Ticket
@ -102,7 +102,7 @@ checkOfferTicket
    -> ExceptT
        Text
        Handler
-        ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, NonEmpty Text))
+        ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
        , TextHtml
        , TextHtml
        , TextPandocMarkdown
@ -195,17 +195,14 @@ checkOfferTicket author ticket uTarget = do
            case branch of
                Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
                _ -> throwE "MR target repo/branch and Offer target repo mismatch"
-        let vcs = typ2vcs typ
-        case vcs of
+        case patchMediaTypeVCS typ of
            VCSDarcs ->
                unless (isNothing branch') $
                    throwE "Darcs MR specifies a branch"
            VCSGit ->
                unless (isJust branch') $
                    throwE "Git MR doesn't specify the branch"
-        return $ Left $ WITRepo shr rp branch' vcs diffs
-        where
-        typ2vcs PatchTypeDarcs = VCSDarcs
+        return $ Left $ WITRepo shr rp branch' typ diffs
    matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
    matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do
        luBranch <-
@ -402,11 +399,12 @@ repoOfferTicketF
    -> ExceptT Text Handler Text
 repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do
    (target, summary, content, source) <- checkOfferTicket author ticket uTarget
-    mmhttp <- for (targetRelevance target) $ \ (mb, vcs, diffs) -> runDBExcept $ do
+    mmhttp <- for (targetRelevance target) $ \ (mb, typ, diffs) -> runDBExcept $ do
        Entity rid r <- lift $ do
            sid <- getKeyBy404 $ UniqueSharer shrRecip
            getBy404 $ UniqueRepo rpRecip sid
-        unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
+        unless (repoVcs r == patchMediaTypeVCS typ) $
+            throwE "Patch type and repo VCS mismatch"
        mractid <- lift $ insertToInbox now author body (repoInbox r) luOffer False
        lift $ for mractid $ \ ractid -> do
            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
@ -427,7 +425,7 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
                let makeTRL tclid = TicketRepoLocal tclid rid mb
                (tid, ltid) <- insertLocalTicket now author makeTRL summary content source ractid obiidAccept
                bnid <- insert $ Bundle tid
-                insertMany_ $ NE.toList $ NE.map (Patch bnid now) diffs
+                insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs
                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
                    insertAccept shrRecip rpRecip author luOffer ltid obiidAccept
                knownRemoteRecipsAccept <-
@ -502,7 +500,7 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =

 data RemoteBundle = RemoteBundle
    { rpBranch :: Maybe LocalURI
-    , rpType   :: PatchType
+    , rpType   :: PatchMediaType
    , rpDiffs  :: NonEmpty Text
    }

@ -603,7 +601,7 @@ checkCreateTicket author ticket muTarget = do
            -> MergeRequest URIMode
            -> ExceptT Text Handler
                ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
-                , PatchType
+                , PatchMediaType
                , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text)
                )
        checkMR luTicket h (MergeRequest muOrigin luTarget ebundle) = do
@ -665,7 +663,7 @@ checkCreateTicket author ticket muTarget = do
                    -> ExceptT Text Handler
                        ( Maybe (LocalURI, LocalURI)
                        , Maybe UTCTime
-                        , PatchType
+                        , PatchMediaType
                        , Text
                        )
                checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
@ -686,7 +684,7 @@ checkCreateTicket author ticket muTarget = do
                FedURI
            -> Maybe
                ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
-                , PatchType
+                , PatchMediaType
                , NonEmpty (Maybe LocalURI, Maybe UTCTime, Text)
                )
            -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemoteBundle))
@ -698,8 +696,7 @@ checkCreateTicket author ticket muTarget = do
                case branch of
                    Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
                    _ -> throwE "MR target repo/branch and Offer target repo mismatch"
-            let vcs = typ2vcs typ
-            case vcs of
+            case patchMediaTypeVCS typ of
                VCSDarcs ->
                    unless (isNothing branch') $
                        throwE "Darcs MR specifies a branch"
@ -711,9 +708,7 @@ checkCreateTicket author ticket muTarget = do
                    unless (pub == pub') $
                        throwE "Ticket & Patch 'published' differ"
                return diff
-            return $ Left $ WITRepo shr rp branch' vcs diffs
-            where
-            typ2vcs PatchTypeDarcs = VCSDarcs
+            return $ Left $ WITRepo shr rp branch' typ diffs
        matchTicketAndMR _ _ (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
        matchTicketAndMR luTicket pub (Right (ObjURI h lu)) (Just (branch, typ, patches)) = do
            luBranch <-
@ -1005,11 +1000,12 @@ repoCreateTicketF
 repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do
    ParsedCreateTicket targetAndContext tlocal published title desc src <-
        checkCreateTicket author ticket muTarget
-    mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, diffs) -> runDBExcept $ do
+    mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, typ, diffs) -> runDBExcept $ do
        Entity rid r <- lift $ do
            sid <- getKeyBy404 $ UniqueSharer shrRecip
            getBy404 $ UniqueRepo rpRecip sid
-        unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
+        unless (repoVcs r == patchMediaTypeVCS typ) $
+            throwE "Patch type and repo VCS mismatch"
        mractid <- lift $ insertToInbox now author body (repoInbox r) luCreate False
        lift $ for mractid $ \ ractid -> do
            obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
@ -1018,7 +1014,7 @@ repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget
            unless (isRight result) $ delete obiidAccept
            for result $ \ tid -> do
                bnid <- insert $ Bundle tid
-                insertMany_ $ NE.toList $ NE.map (Patch bnid published) diffs
+                insertMany_ $ NE.toList $ NE.map (Patch bnid published typ) diffs
                mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
                    let sieve =
                            makeRecipientSet
--- a/src/Vervis/Form/Project.hs
+++ b/src/Vervis/Form/Project.hs
@ -38,7 +38,7 @@ import Vervis.Field.Project
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Model.Workflow

 data NewProject = NewProject
--- a/src/Vervis/Form/Repo.hs
+++ b/src/Vervis/Form/Repo.hs
@ -32,7 +32,7 @@ import Vervis.Field.Repo
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType

 data NewRepo = NewRepo
    { nrpIdent :: RpIdent
--- a/src/Vervis/Git.hs
+++ b/src/Vervis/Git.hs
@ -84,7 +84,7 @@ import Vervis.Changes
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path
 import Vervis.Readme
 import Vervis.Settings
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@ -89,7 +89,7 @@ import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path
 import Vervis.Settings
 import Vervis.Ticket
--- a/src/Vervis/Handler/Home.hs
+++ b/src/Vervis/Handler/Home.hs
@ -37,7 +37,7 @@ import Vervis.Darcs
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path
 import Vervis.Settings

--- a/src/Vervis/Handler/Patch.hs
+++ b/src/Vervis/Handler/Patch.hs
@ -52,7 +52,7 @@ import qualified Data.List.Ordered as LO
 import qualified Database.Esqueleto as E

 import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..))
+import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@ -69,7 +69,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.Paginate
 import Vervis.Patch
@ -309,20 +309,14 @@ getSharerProposalBundlePatchR
    -> KeyHashid Patch
    -> Handler TypedContent
 getSharerProposalBundlePatchR shr talkhid bnkhid ptkhid = do
-    (vcs, patch) <- runDB $ do
-        (_, _, _, repo, _, vers) <- getSharerProposal404 shr talkhid
+    patch <- runDB $ do
+        (_, _, _, _, _, vers) <- getSharerProposal404 shr talkhid
        bnid <- decodeKeyHashid404 bnkhid
        unless (bnid `elem` vers) notFound
        ptid <- decodeKeyHashid404 ptkhid
        pt <- get404 ptid
        unless (patchBundle pt == bnid) notFound
-        vcs <-
-            case repo of
-                Left (_, Entity _ trl) ->
-                    repoVcs <$> getJust (ticketRepoLocalRepo trl)
-                Right _ ->
-                    error "TODO determine mediaType of patch of remote repo"
-        return (vcs, pt)
+        return pt

    encodeRouteLocal <- getEncodeRouteLocal
    hLocal <- getsYesod siteInstanceHost
@ -339,10 +333,7 @@ getSharerProposalBundlePatchR shr talkhid bnkhid ptkhid = do
                )
            , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr
            , AP.patchPublished    = Just $ patchCreated patch
-            , AP.patchType         =
-                case vcs of
-                    VCSDarcs -> PatchTypeDarcs
-                    VCSGit -> error "TODO add PatchType for git patches"
+            , AP.patchType         = patchType patch
            , AP.patchContent      = patchContent patch
            }
    provideHtmlAndAP patchAP $ redirectToPrettyJSON here
@ -663,11 +654,9 @@ getRepoProposalBundlePatchR
    -> KeyHashid Patch
    -> Handler TypedContent
 getRepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid = do
-    (vcs, patch, author) <- runDB $ do
-        (_, Entity _ repo, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
-        (,,)
-            <$> pure (repoVcs repo)
-            <*> do  bnid <- decodeKeyHashid404 bnkhid
+    (patch, author) <- runDB $ do
+        (_, _, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
+        (,) <$> do  bnid <- decodeKeyHashid404 bnkhid
                    unless (bnid `elem` vers) notFound
                    ptid <- decodeKeyHashid404 ptkhid
                    pt <- get404 ptid
@ -709,10 +698,7 @@ getRepoProposalBundlePatchR shr rp ltkhid bnkhid ptkhid = do
                        encodeRouteLocal $ SharerR $ sharerIdent sharer
                    Right (_, object) -> remoteObjectIdent object
            , AP.patchPublished    = Just $ patchCreated patch
-            , AP.patchType         =
-                case vcs of
-                    VCSDarcs -> PatchTypeDarcs
-                    VCSGit -> error "TODO add PatchType for git patches"
+            , AP.patchType         = patchType patch
            , AP.patchContent      = patchContent patch
            }
    provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here
--- a/src/Vervis/Handler/Project.hs
+++ b/src/Vervis/Handler/Project.hs
@ -47,7 +47,7 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
 import qualified Database.Esqueleto as E

 import Network.FedURI
-import Web.ActivityPub hiding (Project (..))
+import Web.ActivityPub hiding (Project (..), Repo (..))
 import Yesod.ActivityPub
 import Yesod.FedURI

@ -63,7 +63,7 @@ import Vervis.Form.Project
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Settings
 import Vervis.Widget.Project
 import Vervis.Widget.Sharer
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@ -88,7 +88,7 @@ import qualified Database.Esqueleto as E

 import Data.MediaType
 import Network.FedURI
-import Web.ActivityPub hiding (Repo, Project)
+import Web.ActivityPub hiding (Repo (..), Project)
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@ -115,7 +115,7 @@ import Vervis.Handler.Repo.Git
 import Vervis.Path
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Settings
@ -246,6 +246,7 @@ getRepoR shr rp = do
                , actorSshKeys    = []
                }
            , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
+            , AP.repoVcs  = repoVcs repo
            }
        dir = case repoVcs repo of
                VCSDarcs -> []
--- a/src/Vervis/Handler/Repo/Darcs.hs
+++ b/src/Vervis/Handler/Repo/Darcs.hs
@ -66,7 +66,7 @@ import Vervis.Foundation
 import Vervis.Path
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Settings
--- a/src/Vervis/Handler/Repo/Git.hs
+++ b/src/Vervis/Handler/Repo/Git.hs
@ -80,7 +80,7 @@ import Vervis.Foundation
 import Vervis.Path
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Paginate
 import Vervis.Readme
 import Vervis.Settings
--- a/src/Vervis/Handler/Wiki.hs
+++ b/src/Vervis/Handler/Wiki.hs
@ -34,7 +34,7 @@ import Vervis.Foundation
 import Data.MediaType
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Path (askRepoDir)
 import Yesod.RenderSource
 import Vervis.Settings (widgetFile)
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@ -1773,6 +1773,18 @@ changes hLocal ctx =
        "Bundle"
      -- 281
    , removeField "Patch" "ticket"
+      -- 282
+    , unchecked $ lift $ do
+        ers <- selectList ([] :: [Filter Repo282]) []
+        for_ ers $ \ (Entity rid r) -> do
+            vcs <-
+                case repo282Vcs r of
+                    "VCSDarcs" -> return "Darcs"
+                    "VCSGit" -> return "Git"
+                    _ -> error "Weird repoVcs"
+            update rid [Repo282Vcs =. vcs]
+      -- 283
+    , addFieldPrimRequired "Patch" ("???" :: Text) "type"
    ]

 migrateDB
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@ -243,6 +243,8 @@ module Vervis.Migration.Model
    , Bundle280Generic (..)
    , Patch280
    , Patch280Generic (..)
+    , Repo282
+    , Repo282Generic (..)
    )
 where

@ -260,7 +262,7 @@ import Vervis.Migration.TH (schema)
 import Vervis.Model (SharerId)
 import Vervis.Model.Group
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Model.Role
 import Vervis.Model.TH
 import Vervis.Model.Workflow
@ -476,3 +478,6 @@ model_2020_08_10 = $(schema "2020_08_10_bundle")

 makeEntitiesMigration "280"
    $(modelFile "migrations/2020_08_10_bundle_mig.model")
+
+makeEntitiesMigration "282"
+    $(modelFile "migrations/2020_08_13_vcs.model")
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@ -34,13 +34,14 @@ import Crypto.PublicVerifKey
 import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
 import Database.Persist.JSON
+import Development.PatchMediaType
+import Development.PatchMediaType.Persist
 import Network.FedURI
 import Web.ActivityPub (Doc, Activity)

 import Vervis.FedURI
 import Vervis.Model.Group
 import Vervis.Model.Ident
-import Vervis.Model.Repo
 import Vervis.Model.Role
 import Vervis.Model.Ticket
 import Vervis.Model.TH
--- a/src/Vervis/Model/Repo.hs
+++ b/src/Vervis/Model/Repo.hs
@ -1,26 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
-module Vervis.Model.Repo
-    ( VersionControlSystem (..)
-    )
-where
-
-import Database.Persist.TH
-
-data VersionControlSystem = VCSGit | VCSDarcs
-    deriving (Eq, Show, Read)
-
-derivePersistField "VersionControlSystem"
--- a/src/Vervis/WorkItem.hs
+++ b/src/Vervis/WorkItem.hs
@ -55,7 +55,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Vervis.Model.Repo
+import Development.PatchMediaType
 import Vervis.Patch
 import Vervis.Ticket

@ -242,4 +242,4 @@ getWorkItemDetail name v = do

 data WorkItemTarget
    = WITProject ShrIdent PrjIdent
-    | WITRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem (NonEmpty Text)
+    | WITRepo ShrIdent RpIdent (Maybe Text) PatchMediaType (NonEmpty Text)
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@ -46,7 +46,6 @@ module Web.ActivityPub
    , TicketDependency (..)
    , TextHtml (..)
    , TextPandocMarkdown (..)
-    , PatchType (..)
    , PatchLocal (..)
    , Patch (..)
    , BundleLocal (..)
@ -147,6 +146,8 @@ import qualified Network.HTTP.Signature as S
 import qualified Text.Email.Parser as E

 import Crypto.PublicVerifKey
+import Development.PatchMediaType
+import Development.PatchMediaType.JSON
 import Network.FedURI
 import Network.HTTP.Digest

@ -402,10 +403,11 @@ instance ActivityPub Actor where
 data Repo u = Repo
    { repoActor :: Actor u
    , repoTeam  :: LocalURI
+    , repoVcs   :: VersionControlSystem
    }

 instance ActivityPub Repo where
-    jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
+    jsonldContext _ = [as2Context, secContext, forgeContext]
    parseObject o = do
        (h, a) <- parseObject o
        unless (actorType a == ActorTypeRepo) $
@ -413,9 +415,11 @@ instance ActivityPub Repo where
        fmap (h,) $
            Repo a
                <$> withAuthorityO h (o .:| "team")
-    toSeries authority (Repo actor team)
+                <*> o .: "versionControlSystem"
+    toSeries authority (Repo actor team vcs)
        =  toSeries authority actor
        <> "team"                 .= ObjURI authority team
+        <> "versionControlSystem" .= vcs

 data Project u = Project
    { projectActor :: Actor u
@ -875,7 +879,7 @@ data Patch u = Patch
    { patchLocal        :: Maybe (Authority u, PatchLocal)
    , patchAttributedTo :: LocalURI
    , patchPublished    :: Maybe UTCTime
-    , patchType         :: PatchType
+    , patchType         :: PatchMediaType
    , patchContent      :: Text
    }

--- a/vervis.cabal
+++ b/vervis.cabal
@ -85,6 +85,9 @@ library
                       Database.Persist.Local
                       Database.Persist.Local.Class.PersistEntityHierarchy
                       Database.Persist.Local.RecursionDoc
+                       Development.PatchMediaType
+                       Development.PatchMediaType.JSON
+                       Development.PatchMediaType.Persist
                       Diagrams.IntransitiveDAG
                       Formatting.CaseInsensitive
                       Language.Haskell.TH.Quote.Local
@ -184,7 +187,6 @@ library
                       Vervis.Model.Entity
                       Vervis.Model.Group
                       Vervis.Model.Ident
-                       Vervis.Model.Repo
                       Vervis.Model.Role
                       Vervis.Model.Ticket
                       Vervis.Model.TH