DB: Add media type field to 'Patch' entity

This patch (haha) also adds a VCS field to the AP representation of repos

config/models

@@ -456,6 +456,7 @@ Bundle
 Patch
     bundle  BundleId
     created UTCTime
+    type    PatchMediaType
     content Text
 
 TicketDependencyOffer

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

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

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"

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

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

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 patchMediaTypeVCS typ of
-                case vcs 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
+                return $ Left $ WITRepo shr rp branch' typ diffs
-                where
-                typ2vcs PatchTypeDarcs = VCSDarcs
             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"
+                    unless (repoVcs r == patchMediaTypeVCS typ) $
-                    return (s, er, mb, diffs)
+                        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 patchMediaTypeVCS typ of
-            case vcs 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
+            return $ Left $ WITRepo shr rp branch' typ diffs
-            where
-            typ2vcs PatchTypeDarcs = VCSDarcs
         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

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

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

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

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 patchMediaTypeVCS typ of
-        case vcs 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
+        return $ Left $ WITRepo shr rp branch' typ diffs
-        where
-        typ2vcs PatchTypeDarcs = VCSDarcs
     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 patchMediaTypeVCS typ of
-            case vcs 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
+            return $ Left $ WITRepo shr rp branch' typ diffs
-            where
-            typ2vcs PatchTypeDarcs = VCSDarcs
         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

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

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

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

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

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
 

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
+    patch <- runDB $ do
-        (_, _, _, repo, _, vers) <- getSharerProposal404 shr talkhid
+        (_, _, _, _, _, vers) <- getSharerProposal404 shr talkhid
         bnid <- decodeKeyHashid404 bnkhid
         unless (bnid `elem` vers) notFound
         ptid <- decodeKeyHashid404 ptkhid
         pt <- get404 ptid
         unless (patchBundle pt == bnid) notFound
-        vcs <-
+        return pt
-            case repo of
-                Left (_, Entity _ trl) ->
-                    repoVcs <$> getJust (ticketRepoLocalRepo trl)
-                Right _ ->
-                    error "TODO determine mediaType of patch of remote repo"
-        return (vcs, 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         =
+            , AP.patchType         = patchType patch
-                case vcs of
-                    VCSDarcs -> PatchTypeDarcs
-                    VCSGit -> error "TODO add PatchType for git patches"
             , 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
+    (patch, author) <- runDB $ do
-        (_, Entity _ repo, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
+        (_, _, _, _, _, _, ta, _, vers) <- getRepoProposal404 shr rp ltkhid
-        (,,)
+        (,) <$> do  bnid <- decodeKeyHashid404 bnkhid
-            <$> pure (repoVcs repo)
-            <*> 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         =
+            , AP.patchType         = patchType patch
-                case vcs of
-                    VCSDarcs -> PatchTypeDarcs
-                    VCSGit -> error "TODO add PatchType for git patches"
             , AP.patchContent      = patchContent patch
             }
     provideHtmlAndAP' host patchAP $ redirectToPrettyJSON here

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

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 -> []

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

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

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)

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

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")

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

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"

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)

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
     }
 

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