diff --git a/config/models b/config/models index 883d38d..b367ca6 100644 --- a/config/models +++ b/config/models @@ -456,6 +456,7 @@ Bundle Patch bundle BundleId created UTCTime + type PatchMediaType content Text TicketDependencyOffer diff --git a/migrations/2020_08_13_vcs.model b/migrations/2020_08_13_vcs.model new file mode 100644 index 0000000..72e8aef --- /dev/null +++ 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 diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 03e18a1..abcd507 100644 --- 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 diff --git a/src/Development/PatchMediaType.hs b/src/Development/PatchMediaType.hs new file mode 100644 index 0000000..6686aa7 --- /dev/null +++ b/src/Development/PatchMediaType.hs @@ -0,0 +1,73 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2019, 2020 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 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" diff --git a/src/Development/PatchMediaType/JSON.hs b/src/Development/PatchMediaType/JSON.hs new file mode 100644 index 0000000..8b24af7 --- /dev/null +++ b/src/Development/PatchMediaType/JSON.hs @@ -0,0 +1,45 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020 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 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 diff --git a/src/Development/PatchMediaType/Persist.hs b/src/Development/PatchMediaType/Persist.hs new file mode 100644 index 0000000..95743e8 --- /dev/null +++ b/src/Development/PatchMediaType/Persist.hs @@ -0,0 +1,43 @@ +{- This file is part of Vervis. + - + - Written in 2020 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 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 diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 63e8189..3496375 100644 --- 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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index bdfdb87..eb731a9 100644 --- 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 diff --git a/src/Vervis/ChangeFeed.hs b/src/Vervis/ChangeFeed.hs index bd425b5..c15fb4a 100644 --- 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 diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 6922dfa..c79a2ef 100644 --- 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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 44be1fe..48f7ad4 100644 --- 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 diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Project.hs index 38f1aec..d88d3d1 100644 --- 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 diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index 5a680d5..a45e607 100644 --- 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 diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index fdd6e5a..357b83d 100644 --- 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 diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 8282364..852c47a 100644 --- 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 diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index 4678822..8101ac8 100644 --- 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 diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 98a119e..718f9be 100644 --- 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 diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index d213176..5f2ec75 100644 --- 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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 9cdcde5..e793f01 100644 --- 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 -> [] diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index a8e216a..74b7c47 100644 --- 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 diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 5c1ae3f..0d3f0dd 100644 --- 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 diff --git a/src/Vervis/Handler/Wiki.hs b/src/Vervis/Handler/Wiki.hs index de25406..6453229 100644 --- 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) diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index ba4942b..40318c7 100644 --- 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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 9a4962e..9fd7dd1 100644 --- 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") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index d0cacfd..c7da8e4 100644 --- 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 diff --git a/src/Vervis/Model/Repo.hs b/src/Vervis/Model/Repo.hs deleted file mode 100644 index 8dc76c6..0000000 --- a/src/Vervis/Model/Repo.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- This file is part of Vervis. - - - - 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 Vervis.Model.Repo - ( VersionControlSystem (..) - ) -where - -import Database.Persist.TH - -data VersionControlSystem = VCSGit | VCSDarcs - deriving (Eq, Show, Read) - -derivePersistField "VersionControlSystem" diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs index 40a6a7e..4f7934a 100644 --- 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) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 14507c9..e1f1c2a 100644 --- 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 + <> "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 } diff --git a/vervis.cabal b/vervis.cabal index 19ff77b..36a6647 100644 --- 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