C2S: offerTicketC re-enabled and supporting looms and remote origin repo
What's missing: - Match patch VCS, origin repo VCS and target repo VCS - Hook into postPersonInboxR - If only origin is provided, generate patches / otherwise somehow remember the commits proposed
This commit is contained in:
fr33domlover
parent
0b10056cc3
commit
de2e29d505
16 changed files with 725 additions and 415 deletions
19
migrations/495_2022-09-21_ticket_title.model
Normal file
19
migrations/495_2022-09-21_ticket_title.model
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
Discussion
|
||||
FollowerSet
|
||||
OutboxItem
|
||||
|
||||
Ticket
|
||||
number Int Maybe
|
||||
created UTCTime
|
||||
title Text
|
||||
source Text
|
||||
description HTML
|
||||
status Text
|
||||
discuss DiscussionId
|
||||
followers FollowerSetId
|
||||
accept OutboxItemId
|
||||
|
||||
-- UniqueTicket project number
|
||||
UniqueTicketDiscuss discuss
|
||||
UniqueTicketFollowers followers
|
||||
UniqueTicketAccept accept
|
||||
|
|
@ -118,4 +118,4 @@ getEntityE
|
|||
, PersistRecordBackend record backend
|
||||
)
|
||||
=> Key record -> e -> ExceptT e (ReaderT backend m) (Entity record)
|
||||
getEntityE key msg = (Entity key) <$> getE key msg
|
||||
getEntityE key msg = Entity key <$> getE key msg
|
||||
|
|
|
|||
|
|
@ -41,15 +41,18 @@ import Control.Monad
|
|||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Align
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.Bifoldable
|
||||
import Data.Bitraversable
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Functor.Identity
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist hiding (deleteBy)
|
||||
|
|
@ -60,6 +63,7 @@ import Text.Blaze.Html.Renderer.Text
|
|||
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
|
|
@ -67,6 +71,7 @@ import Database.Persist.JSON
|
|||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -86,6 +91,7 @@ import Vervis.ActivityPub
|
|||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
|
|
@ -133,7 +139,7 @@ verifyRemoteAddressed remoteRecips u =
|
|||
acceptC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Accept URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
|
|
@ -373,7 +379,7 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept
|
|||
|
||||
addBundleC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> NonEmpty (AP.Patch URIMode)
|
||||
-> FedURI
|
||||
|
|
@ -572,7 +578,7 @@ addBundleC (Entity pidUser personUser) summary audience patches uTarget = do
|
|||
|
||||
applyC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Maybe (ObjURI URIMode)
|
||||
-> Apply URIMode
|
||||
|
|
@ -1012,7 +1018,7 @@ noteC eperson@(Entity personID person) note = do
|
|||
personHash <- encodeKeyHashid personID
|
||||
let username = personUsername person
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
renderHTML <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
|
|
@ -1030,7 +1036,7 @@ noteC eperson@(Entity personID person) note = do
|
|||
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
|
||||
createNoteC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Note URIMode
|
||||
-> Maybe FedURI
|
||||
|
|
@ -1260,28 +1266,10 @@ checkFederation remoteRecips = do
|
|||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients found"
|
||||
|
||||
{-
|
||||
verifyProjectRecip (Right _) _ = return ()
|
||||
verifyProjectRecip (Left (WITProject shr prj)) localRecips =
|
||||
fromMaybeE verify "Local context project isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
projectSet <- lookup prj $ localRecipProjectRelated sharerSet
|
||||
guard $ localRecipProject $ localRecipProjectDirect projectSet
|
||||
verifyProjectRecip (Left (WITRepo shr rp _ _ _)) localRecips =
|
||||
fromMaybeE verify "Local context repo isn't listed as a recipient"
|
||||
where
|
||||
verify = do
|
||||
sharerSet <- lookup shr localRecips
|
||||
repoSet <- lookup rp $ localRecipRepoRelated sharerSet
|
||||
guard $ localRecipRepo $ localRecipRepoDirect repoSet
|
||||
-}
|
||||
|
||||
createPatchTrackerC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> AP.ActorDetail
|
||||
-> NonEmpty FedURI
|
||||
|
|
@ -1551,7 +1539,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor summary audience det
|
|||
createRepositoryC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> AP.ActorDetail
|
||||
-> VersionControlSystem
|
||||
|
|
@ -1815,7 +1803,7 @@ createRepositoryC (Entity pidUser personUser) senderActor summary audience detai
|
|||
createTicketTrackerC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> AP.ActorDetail
|
||||
-> Maybe (Host, AP.ActorLocal URIMode)
|
||||
|
|
@ -2067,7 +2055,7 @@ data Followee
|
|||
|
||||
followC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
|
|
@ -2197,7 +2185,7 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
|
|||
insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do
|
||||
now <- liftIO getCurrentTime
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
renderHTML <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
|
|
@ -2256,7 +2244,7 @@ inviteC
|
|||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe FedURI
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Invite URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
|
|
@ -2504,387 +2492,393 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience
|
|||
|
||||
offerTicketC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Actor
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
offerTicketC (Entity pidUser personUser) summary audience ticket uTarget = do
|
||||
error "offerTicketC temporarily disabled"
|
||||
offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience ticket uTarget = do
|
||||
|
||||
|
||||
{-
|
||||
senderHash <- encodeKeyHashid pidUser
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(target, title, desc, source) <- checkOfferTicket shrUser ticket uTarget
|
||||
-- Check input
|
||||
(title, desc, source, tam) <- do
|
||||
hostLocal <- asksSite siteInstanceHost
|
||||
WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget
|
||||
unless (wioAuthor == Left senderPersonID) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
return (wioTitle, wioDesc, wioSource, wioRest)
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Offer Ticket with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
verifyProjectRecip target localRecips
|
||||
checkFederation remoteRecips
|
||||
|
||||
-- Verify that the target tracker is addressed by the Offer
|
||||
case tam of
|
||||
TAM_Task deckID -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
unless (actorIsAddressed localRecips $ LocalActorDeck deckHash) $
|
||||
throwE "Local target deck not addressed by the Offer"
|
||||
TAM_Merge loomID _ -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $
|
||||
throwE "Local target loom not addressed by the Offer"
|
||||
TAM_Remote uTracker _ -> verifyRemoteAddressed remoteRecips uTracker
|
||||
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
(obiidOffer, docOffer, remotesHttpOffer, maybeAccept) <- runDBExcept $ do
|
||||
mproject <-
|
||||
case target of
|
||||
Left (WITProject shr prj) -> Just . Left <$> do
|
||||
mproj <- lift $ runMaybeT $ do
|
||||
Entity sid s <- MaybeT $ getBy $ UniqueSharer shr
|
||||
ej@(Entity _ j) <- MaybeT $ getBy $ UniqueProject prj sid
|
||||
a <- lift $ getJust $ projectActor j
|
||||
return (s, ej, a)
|
||||
fromMaybeE mproj "Offer target no such local project in DB"
|
||||
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 == 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
|
||||
let sieve =
|
||||
case target of
|
||||
Left (WITProject shr prj) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorProject shr prj
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Left (WITRepo shr rp _ _ _) ->
|
||||
makeRecipientSet
|
||||
[ LocalActorRepo shr rp
|
||||
]
|
||||
[ LocalPersonCollectionSharerFollowers shrUser
|
||||
, LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
Right _ ->
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
moreRemoteRecips <-
|
||||
lift $
|
||||
deliverLocal'
|
||||
True
|
||||
(LocalActorSharer shrUser)
|
||||
(personInbox personUser)
|
||||
obiid
|
||||
(localRecipSieve sieve False localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
throwE "Federation disabled, but recipient collection remote members found"
|
||||
lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips
|
||||
maccept <- lift $ for mproject $ \ project -> do
|
||||
let obid =
|
||||
case project of
|
||||
Left (_, _, a) -> actorOutbox a
|
||||
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, _, _) ->
|
||||
\ tclid -> insert_ $ TicketRepoLocal tclid rid mb
|
||||
(tid, ltid) <- insertTicket pidUser now title desc source insertTXL obiid obiidAccept
|
||||
case project of
|
||||
Left _ -> return ()
|
||||
Right (_, _, _, typ, diffs) -> do
|
||||
bnid <- insert $ Bundle tid
|
||||
insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs
|
||||
(docAccept, localRecipsAccept) <- insertAccept shrUser luOffer project obiidAccept ltid
|
||||
let (actor, ibid) =
|
||||
case project of
|
||||
Left (s, Entity _ j, a) ->
|
||||
( LocalActorProject (sharerIdent s) (projectIdent j)
|
||||
, actorInbox a
|
||||
)
|
||||
Right (s, Entity _ r, _, _, _) ->
|
||||
( LocalActorRepo (sharerIdent s) (repoIdent r)
|
||||
, repoInbox r
|
||||
)
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal' False actor ibid obiidAccept localRecipsAccept
|
||||
(obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
|
||||
return (obiid, doc, remotesHttpOffer, maccept)
|
||||
lift $ do
|
||||
forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp' fwdHosts obiidOffer docOffer remotesHttpOffer
|
||||
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
|
||||
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
|
||||
return obiidOffer
|
||||
where
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
checkOfferTicket
|
||||
:: ShrIdent
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler
|
||||
( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchMediaType, NonEmpty Text))
|
||||
, TextHtml
|
||||
, TextHtml
|
||||
, TextPandocMarkdown
|
||||
)
|
||||
checkOfferTicket shrUser??? ticket uTarget = do
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
target <- parseTarget uTarget
|
||||
(muContext, summary, content, source, mmr) <- checkTicket shrUser ticket
|
||||
for_ muContext $
|
||||
\ u -> unless (u == uTarget) $ throwE "Offer target != ticket context"
|
||||
target' <- matchTargetAndMR target mmr
|
||||
return (target', summary, content, source)
|
||||
where
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Offer target is local but not a valid route"
|
||||
case route of
|
||||
DeckR d t -> return $ Left (d, t)
|
||||
LoomR l c -> return $ Right (l, c)
|
||||
_ -> throwE "Offer target is local but isn't a deck/loom route"
|
||||
else return $ Right u
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
checkTicket
|
||||
shrUser
|
||||
(AP.Ticket mlocal attrib mpublished mupdated muContext summary
|
||||
content source muAssigned mresolved mmr) = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
shrAttrib <- do
|
||||
route <- fromMaybeE (decodeRouteLocal attrib) "Ticket attrib not a valid route"
|
||||
case route of
|
||||
SharerR shr -> return shr
|
||||
_ -> throwE "Ticket attrib not a sharer route"
|
||||
unless (shrAttrib == shrUser) $
|
||||
throwE "Ticket attibuted to someone else"
|
||||
|
||||
verifyNothingE mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
||||
when (isJust mresolved) $ throwE "Ticket is resolved"
|
||||
|
||||
mmr' <- traverse (uncurry checkMR) mmr
|
||||
|
||||
return (muContext, summary, content, source, mmr')
|
||||
where
|
||||
checkMR h (MergeRequest muOrigin luTarget ebundle) = do
|
||||
verifyNothingE muOrigin "MR with 'origin'"
|
||||
branch <- checkBranch h luTarget
|
||||
(typ, diffs) <-
|
||||
case ebundle of
|
||||
Left _ -> throwE "MR bundle specified as a URI"
|
||||
Right (hBundle, bundle) -> checkBundle hBundle bundle
|
||||
case (typ, diffs) of
|
||||
(PatchMediaTypeDarcs, _ :| _ : _) ->
|
||||
throwE "More than one Darcs patch bundle provided"
|
||||
_ -> return ()
|
||||
return (branch, typ, diffs)
|
||||
where
|
||||
checkBranch h lu = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <-
|
||||
-- If tracker is a local loom, and a remote origin repo is specified, fetch
|
||||
-- that repo's AP object via HTTP and remember in DB
|
||||
maybeLocalTracker <-
|
||||
case tam of
|
||||
TAM_Task deckID -> pure $ Just $ Left deckID
|
||||
TAM_Merge loomID (Merge maybeOriginTip maybeBundle targetTip) -> do
|
||||
maybeOrigin <- for maybeOriginTip $ \case
|
||||
TipLocalRepo repoID -> pure $ Left (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch)
|
||||
TipRemote uOrigin -> Right <$> do
|
||||
(vcs, raid, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
|
||||
return (vcs, raid, first Just <$> mb)
|
||||
TipRemoteBranch uRepo branch -> Right <$> do
|
||||
(vcs, raid) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
|
||||
return (vcs, raid, Just (Nothing, branch))
|
||||
originOrBundle <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
"MR target is local but isn't a valid route"
|
||||
case route of
|
||||
RepoR shr rp -> return (shr, rp, Nothing)
|
||||
RepoBranchR shr rp b -> return (shr, rp, Just b)
|
||||
_ ->
|
||||
throwE
|
||||
"MR target is a valid local route, but isn't a \
|
||||
\repo or branch route"
|
||||
else return $ Right $ ObjURI h lu
|
||||
checkBundle _ (AP.BundleHosted _ _) =
|
||||
throwE "Patches specified as URIs"
|
||||
checkBundle h (AP.BundleOffer mlocal patches) = do
|
||||
verifyNothingE mlocal "Bundle has 'id'"
|
||||
(typ:|typs, diffs) <- NE.unzip <$> traverse (checkPatch h) patches
|
||||
unless (all (== typ) typs) $ throwE "Different patch types"
|
||||
return (typ, diffs)
|
||||
where
|
||||
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
|
||||
verifyNothingE mlocal "Patch with 'id'"
|
||||
hl <- hostIsLocal h
|
||||
shrAttrib <- do
|
||||
route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route"
|
||||
case route of
|
||||
SharerR shr -> return shr
|
||||
_ -> throwE "Patch attrib not a sharer route"
|
||||
unless (hl && shrAttrib == shrUser) $
|
||||
throwE "Ticket and Patch attrib mismatch"
|
||||
verifyNothingE mpub "Patch has 'published'"
|
||||
return (typ, content)
|
||||
matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WITProject shr prj
|
||||
matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
|
||||
matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
|
||||
matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, diffs)) = do
|
||||
branch' <-
|
||||
case branch of
|
||||
Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
|
||||
_ -> throwE "MR target repo/branch and Offer target repo mismatch"
|
||||
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' typ diffs
|
||||
matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
|
||||
matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, diffs)) = do
|
||||
luBranch <-
|
||||
case branch of
|
||||
Right (ObjURI h' lu') | h == h' -> return lu
|
||||
_ -> throwE "MR target repo/branch and Offer target repo mismatch"
|
||||
let bundle =
|
||||
( if lu == luBranch then Nothing else Just luBranch
|
||||
, typ
|
||||
, diffs
|
||||
)
|
||||
return $ Right (h, lu, Just bundle)
|
||||
(align maybeOrigin maybeBundle)
|
||||
"MR provides neither origin nor patches"
|
||||
(targetRepoID, maybeTargetBranch) <-
|
||||
case targetTip of
|
||||
TipLocalRepo repoID -> pure (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure (repoID, Just branch)
|
||||
_ -> throwE "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)"
|
||||
return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch)
|
||||
TAM_Remote _ _ -> pure Nothing
|
||||
|
||||
insertOfferToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
(offerID, deliverHttpOffer, maybeDeliverHttpAccept) <- runDBExcept $ do
|
||||
|
||||
-- If target tracker is local, find it in our DB
|
||||
-- If that tracker is a loom, find and check the MR too
|
||||
maybeLocalTrackerDB <- for maybeLocalTracker $ bitraverse
|
||||
(\ deckID -> do
|
||||
deck <- getE deckID "Offer local target no such deck in DB"
|
||||
return (deckID, deckActor deck)
|
||||
)
|
||||
(\ (loomID, originOrBundle, targetRepoID, maybeTargetBranch) -> do
|
||||
loom <- getE loomID "Offer local target no such loom in DB"
|
||||
|
||||
unless (targetRepoID == loomRepo loom) $
|
||||
throwE "MR target repo isn't the one served by the Offer target loom"
|
||||
targetRepo <- getE targetRepoID "MR target local repo not found in DB"
|
||||
unless (repoLoom targetRepo == Just loomID) $
|
||||
throwE "Offer target loom doesn't have repo's consent to serve it"
|
||||
|
||||
originOrBundle' <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
(\ (repoID, maybeBranch) -> do
|
||||
repo <- getE repoID "MR origin local repo not found in DB"
|
||||
return (repoID, repoVcs repo, maybeBranch)
|
||||
)
|
||||
pure
|
||||
)
|
||||
pure
|
||||
originOrBundle
|
||||
|
||||
return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch)
|
||||
)
|
||||
|
||||
-- Insert Offer to sender's outbox
|
||||
offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
docOffer <- lift $ insertOfferToOutbox senderHash blinded offerID
|
||||
|
||||
-- Deliver the Offer activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpOffer <- do
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
let tipRepo tip =
|
||||
case tip of
|
||||
TipLocalRepo repoID -> Just $ hashRepo repoID
|
||||
TipLocalBranch repoID _ -> Just $ hashRepo repoID
|
||||
_ -> Nothing
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
let (tracker, target, origin) =
|
||||
case tam of
|
||||
TAM_Task deckID ->
|
||||
( Just $ Left $ hashDeck deckID
|
||||
, Nothing
|
||||
, Nothing
|
||||
)
|
||||
TAM_Merge loomID (Merge maybeOriginTip _ targetTip) ->
|
||||
( Just $ Right $ hashLoom loomID
|
||||
, tipRepo targetTip
|
||||
, tipRepo =<< maybeOriginTip
|
||||
)
|
||||
TAM_Remote _ maybeMerge ->
|
||||
( Nothing
|
||||
, tipRepo . mergeTarget =<< maybeMerge
|
||||
, tipRepo =<< mergeOrigin =<< maybeMerge
|
||||
)
|
||||
sieveActors = catMaybes
|
||||
[ tracker <&> \case
|
||||
Left deckHash -> LocalActorDeck deckHash
|
||||
Right loomHash -> LocalActorLoom loomHash
|
||||
, LocalActorRepo <$> target
|
||||
, LocalActorRepo <$> origin
|
||||
]
|
||||
sieveStages = catMaybes
|
||||
[ tracker <&> \case
|
||||
Left deckHash -> LocalStageDeckFollowers deckHash
|
||||
Right loomHash -> LocalStageLoomFollowers loomHash
|
||||
, LocalStageRepoFollowers <$> target
|
||||
, LocalStageRepoFollowers <$> origin
|
||||
, Just $ LocalStagePersonFollowers senderHash
|
||||
]
|
||||
sieve = makeRecipientSet sieveActors sieveStages
|
||||
moreRemoteRecips <-
|
||||
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) offerID $
|
||||
localRecipSieve sieve False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHosts offerID remoteRecips moreRemoteRecips
|
||||
|
||||
-- If Offer target is a local deck/loom, verify that it has received
|
||||
-- the Offer, insert a new Ticket to DB, and publish Accept
|
||||
maybeDeliverHttpAccept <- for maybeLocalTrackerDB $ \ tracker -> do
|
||||
|
||||
-- Verify that tracker received the Offer
|
||||
let trackerActorID =
|
||||
case tracker of
|
||||
Left (_, actorID) -> actorID
|
||||
Right (_, actorID, _, _, _) -> actorID
|
||||
verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer"
|
||||
|
||||
-- Insert ticket/MR to DB
|
||||
acceptID <- lift $ do
|
||||
trackerActor <- getJust trackerActorID
|
||||
insertEmptyOutboxItem (actorOutbox trackerActor) now
|
||||
ticketRoute <- lift $ do
|
||||
ticketID <- insertTicket now title desc source offerID acceptID
|
||||
case tracker of
|
||||
Left (deckID, _) -> insertTask deckID ticketID
|
||||
Right (loomID, _, originOrBundle, _, maybeTargetBranch) ->
|
||||
insertMerge now loomID ticketID maybeTargetBranch originOrBundle
|
||||
|
||||
-- Insert an Accept activity to tracker's outbox
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
let acceptRecipActors = [LocalActorPerson senderHash]
|
||||
acceptRecipStages =
|
||||
[ case tracker of
|
||||
Left (deckID, _) ->
|
||||
LocalStageDeckFollowers $ hashDeck deckID
|
||||
Right (loomID, _, _, _, _) ->
|
||||
LocalStageLoomFollowers $ hashLoom loomID
|
||||
, LocalStagePersonFollowers senderHash
|
||||
]
|
||||
docAccept <-
|
||||
lift $ insertAcceptToOutbox senderHash tracker ticketRoute offerID acceptID acceptRecipActors acceptRecipStages
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpAccept <- do
|
||||
let trackerLocalActor =
|
||||
case tracker of
|
||||
Left (deckID, _) ->
|
||||
LocalActorDeck $ hashDeck deckID
|
||||
Right (loomID, _, _, _, _) ->
|
||||
LocalActorLoom $ hashLoom loomID
|
||||
remoteRecips <-
|
||||
lift $ deliverLocal' True trackerLocalActor trackerActorID acceptID $
|
||||
makeRecipientSet acceptRecipActors acceptRecipStages
|
||||
checkFederation remoteRecips
|
||||
lift $ deliverRemoteDB'' [] acceptID [] remoteRecips
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return $
|
||||
deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return
|
||||
( offerID
|
||||
, deliverRemoteHttp' fwdHosts offerID docOffer remoteRecipsHttpOffer
|
||||
, maybeDeliverHttpAccept
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Offer and Accept
|
||||
lift $ do
|
||||
forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
|
||||
for_ maybeDeliverHttpAccept $
|
||||
forkWorker "offerTicketC: async HTTP Accept delivery"
|
||||
|
||||
return offerID
|
||||
|
||||
--unless (repoVcs r == patchMediaTypeVCS typ) $
|
||||
-- throwE "Patch type and repo VCS mismatch"
|
||||
|
||||
where
|
||||
|
||||
fetchRepoE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchAPID' manager apRepoId h lu
|
||||
|
||||
insertRemoteActor h lu (AP.Actor local detail) = do
|
||||
iid <- either entityKey id <$> insertBy' (Instance h)
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
let ra = RemoteActor
|
||||
{ remoteActorIdent = roid
|
||||
, remoteActorName =
|
||||
AP.actorName detail <|> AP.actorUsername detail
|
||||
, remoteActorInbox = AP.actorInbox local
|
||||
, remoteActorFollowers = AP.actorFollowers local
|
||||
, remoteActorErrorSince = Nothing
|
||||
}
|
||||
either entityKey id <$> insertBy' ra
|
||||
|
||||
httpGetRemoteTip
|
||||
:: FedURI
|
||||
-> ExceptT Result Handler
|
||||
( VersionControlSystem
|
||||
, RemoteActorId
|
||||
, Maybe (LocalURI, Text)
|
||||
)
|
||||
httpGetRemoteTip (ObjURI host localURI) = do
|
||||
repoOrBranch <- fetchTipE host localURI
|
||||
case repoOrBranch of
|
||||
Left repo -> do
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
return (AP.repoVcs repo, remoteActorID, Nothing)
|
||||
Right (AP.Branch name _ luRepo) -> do
|
||||
repo <- fetchRepoE host luRepo
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host luRepo $ AP.repoActor repo
|
||||
return (AP.repoVcs repo, remoteActorID, Just (localURI, name))
|
||||
where
|
||||
fetchTipE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchTip manager h lu
|
||||
|
||||
httpGetRemoteRepo
|
||||
:: FedURI -> ExceptT Result Handler (VersionControlSystem, RemoteActorId)
|
||||
httpGetRemoteRepo (ObjURI host localURI) = do
|
||||
repo <- fetchRepoE host localURI
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
return (AP.repoVcs repo, remoteActorID)
|
||||
|
||||
insertOfferToOutbox senderHash blinded offerID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
offerHash <- encodeKeyHashid offerID
|
||||
let doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
PersonOutboxItemR senderHash offerHash
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activityFulfills = []
|
||||
, activitySpecific =
|
||||
OfferActivity $ Offer (OfferTicket ticket) uTarget
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
insertTicket pidAuthor now title desc source insertTXL obiid obiidAccept = do
|
||||
update offerID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
|
||||
insertTicket now title desc source offerID acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = unTextHtml title
|
||||
, ticketSource = unTextPandocMarkdown source
|
||||
, ticketDescription = unTextHtml desc
|
||||
, ticketAssignee = Nothing
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketStatus = TSNew
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
ltid <- insert LocalTicket
|
||||
{ localTicketTicket = tid
|
||||
, localTicketDiscuss = did
|
||||
, localTicketFollowers = fsid
|
||||
insert_ TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = tid
|
||||
, ticketAuthorLocalAuthor = senderPersonID
|
||||
, ticketAuthorLocalOpen = offerID
|
||||
}
|
||||
tclid <- insert TicketContextLocal
|
||||
{ ticketContextLocalTicket = tid
|
||||
, ticketContextLocalAccept = obiidAccept
|
||||
}
|
||||
insertTXL tclid
|
||||
talid <- insert TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = ltid
|
||||
, ticketAuthorLocalAuthor = pidAuthor
|
||||
, ticketAuthorLocalOpen = obiid
|
||||
}
|
||||
insert_ TicketUnderProject
|
||||
{ ticketUnderProjectProject = tclid
|
||||
, ticketUnderProjectAuthor = talid
|
||||
}
|
||||
return (tid, ltid)
|
||||
insertAccept shrUser luOffer project obiidAccept ltid = do
|
||||
let (collections, outboxItemRoute, projectRoute, ticketRoute) =
|
||||
case project of
|
||||
Left (s, Entity _ j, _) ->
|
||||
let shr = sharerIdent s
|
||||
prj = projectIdent j
|
||||
in ( [ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
, ProjectOutboxItemR shr prj
|
||||
, ProjectR shr prj
|
||||
, ProjectTicketR shr prj
|
||||
)
|
||||
Right (s, Entity _ r, _, _, _) ->
|
||||
let shr = sharerIdent s
|
||||
rp = repoIdent r
|
||||
in ( [ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
, RepoOutboxItemR shr rp
|
||||
, RepoR shr rp
|
||||
, RepoProposalR shr rp
|
||||
return tid
|
||||
|
||||
insertTask deckID ticketID = do
|
||||
ticketDeckID <- insert $ TicketDeck ticketID deckID
|
||||
TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID
|
||||
|
||||
insertMerge
|
||||
:: UTCTime
|
||||
-> LoomId
|
||||
-> TicketId
|
||||
-> Maybe Text
|
||||
-> These
|
||||
(Either
|
||||
(RepoId, VersionControlSystem, Maybe Text)
|
||||
(VersionControlSystem, RemoteActorId, Maybe (Maybe LocalURI, Text))
|
||||
)
|
||||
Material
|
||||
-> AppDB (Route App)
|
||||
insertMerge now loomID ticketID maybeBranch originOrBundle = do
|
||||
clothID <- insert $ TicketLoom ticketID loomID maybeBranch
|
||||
for_ (justHere originOrBundle) $ \case
|
||||
Left (repoID, _, maybeOriginBranch) ->
|
||||
insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
|
||||
Right (_, remoteActorID, maybeOriginBranch) -> do
|
||||
originID <- insert $ MergeOriginRemote clothID remoteActorID
|
||||
for_ maybeOriginBranch $ \ (mlu, b) ->
|
||||
insert_ $ MergeOriginRemoteBranch originID mlu b
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
bundleID <- insert $ Bundle clothID
|
||||
insertMany_ $ NE.toList $ NE.reverse $
|
||||
NE.map (Patch bundleID now typ) diffs
|
||||
ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID
|
||||
|
||||
insertAcceptToOutbox personHash tracker ticketRoute offerID acceptID actors stages = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
tracker' <-
|
||||
bitraverse
|
||||
(\ (deckID, _) -> encodeKeyHashid deckID)
|
||||
(\ (loomID, _, _, _, _) -> encodeKeyHashid loomID)
|
||||
tracker
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let actors = [LocalActorSharer shrUser]
|
||||
recips =
|
||||
offerHash <- encodeKeyHashid offerID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalPersonCollection collections
|
||||
map renderLocalStage stages
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept
|
||||
, activityActor = encodeRouteLocal projectRoute
|
||||
Just $ encodeRouteLocal $
|
||||
case tracker' of
|
||||
Left deckHash -> DeckOutboxItemR deckHash acceptHash
|
||||
Right loomHash -> LoomOutboxItemR loomHash acceptHash
|
||||
, activityActor =
|
||||
encodeRouteLocal $ either DeckR LoomR tracker'
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult =
|
||||
Just $ encodeRouteLocal $ ticketRoute ltkhid
|
||||
{ acceptObject =
|
||||
encodeRouteHome $
|
||||
PersonOutboxItemR personHash offerHash
|
||||
, acceptResult = Just $ encodeRouteLocal ticketRoute
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, makeRecipientSet actors collections)
|
||||
-}
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
|
||||
{-
|
||||
verifyHosterRecip _ _ (Right _) = return ()
|
||||
|
|
@ -2949,7 +2943,7 @@ actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l
|
|||
|
||||
offerDepC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> TicketDependency URIMode
|
||||
-> FedURI
|
||||
|
|
@ -3211,7 +3205,7 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve
|
|||
|
||||
resolveC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Resolve URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
|
|
@ -3329,7 +3323,7 @@ resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do
|
|||
|
||||
undoC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
-> Maybe HTML
|
||||
-> Audience URIMode
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
|
|
@ -3527,7 +3521,7 @@ pushCommitsC eperson summary push shrRepo rpRepo = do
|
|||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activityCapability = Nothing
|
||||
, activitySummary =
|
||||
Just $ TextHtml $ TL.toStrict $ renderHtml summary
|
||||
Just $ renderHTML summary
|
||||
, activityAudience = Audience aud [] [] [] [] []
|
||||
, activitySpecific = PushActivity push
|
||||
}
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ import qualified Data.Text.Lazy as TL
|
|||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Follow, Ticket, Project (..), Repo, ActorLocal (..))
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -603,7 +604,7 @@ createDeck
|
|||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail)
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
||||
createDeck senderHash name desc = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
|
|
@ -629,7 +630,7 @@ createLoom
|
|||
-> Text
|
||||
-> Text
|
||||
-> KeyHashid Repo
|
||||
-> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail, NonEmpty FedURI)
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail, NonEmpty FedURI)
|
||||
createLoom senderHash name desc repoHash = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
|
|
@ -659,7 +660,7 @@ createRepo
|
|||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe TextHtml, Audience URIMode, AP.ActorDetail)
|
||||
-> m (Maybe HTML, Audience URIMode, AP.ActorDetail)
|
||||
createRepo senderHash name desc = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
|
|
|
|||
196
src/Vervis/Data/Ticket.hs
Normal file
196
src/Vervis/Data/Ticket.hs
Normal file
|
|
@ -0,0 +1,196 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 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.Data.Ticket
|
||||
( Tip (..)
|
||||
, Material (..)
|
||||
, Merge (..)
|
||||
, TrackerAndMerge (..)
|
||||
, WorkItemOffer (..)
|
||||
, checkOfferTicket
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
|
||||
import Vervis.Foundation
|
||||
import Vervis.FedURI
|
||||
import Vervis.Model
|
||||
|
||||
data Tip
|
||||
= TipLocalRepo RepoId
|
||||
| TipLocalBranch RepoId Text
|
||||
| TipRemote FedURI
|
||||
| TipRemoteBranch FedURI Text
|
||||
|
||||
data Material = Material
|
||||
{ materialType :: PatchMediaType
|
||||
, materialPatches :: NonEmpty Text
|
||||
}
|
||||
|
||||
data Merge = Merge
|
||||
{ mergeOrigin :: Maybe Tip
|
||||
, mergeMaterial :: Maybe Material
|
||||
, mergeTarget :: Tip
|
||||
}
|
||||
|
||||
data Tracker = TrackerDeck DeckId | TrackerLoom LoomId | TrackerRemote FedURI
|
||||
deriving Eq
|
||||
|
||||
data TrackerAndMerge =
|
||||
TAM_Task DeckId | TAM_Merge LoomId Merge | TAM_Remote FedURI (Maybe Merge)
|
||||
|
||||
data WorkItemOffer = WorkItemOffer
|
||||
{ wioAuthor :: Either PersonId FedURI
|
||||
, wioTitle :: Text
|
||||
, wioDesc :: HTML
|
||||
, wioSource :: PandocMarkdown
|
||||
, wioRest :: TrackerAndMerge
|
||||
}
|
||||
|
||||
checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI)
|
||||
checkAuthor u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route"
|
||||
case route of
|
||||
PersonR personHash -> Left <$> decodeKeyHashidE personHash "Local author invalid person hash"
|
||||
_ -> throwE "Local author not a person route"
|
||||
else pure $ Right u
|
||||
|
||||
checkPatch :: Host -> AP.Patch URIMode -> ExceptT Text Handler (Either PersonId FedURI, PatchMediaType, Text)
|
||||
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
|
||||
verifyNothingE mlocal "Patch has 'id'"
|
||||
author <- checkAuthor $ ObjURI h attrib
|
||||
verifyNothingE mpub "Patch has 'published'"
|
||||
return (author, typ, content)
|
||||
|
||||
checkBundle :: Host -> AP.Bundle URIMode -> ExceptT Text Handler (Either PersonId FedURI, Material)
|
||||
checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs"
|
||||
checkBundle h (AP.BundleOffer mlocal patches) = do
|
||||
verifyNothingE mlocal "Bundle has 'id'"
|
||||
(author, typ, content) :| rest <- traverse (checkPatch h) patches
|
||||
let authors = map (\ (a, _, _) -> a) rest
|
||||
typs = map (\ (_, t, _) -> t) rest
|
||||
contents = map (\ (_, _, c) -> c) rest
|
||||
unless (all (== author) authors) $ throwE "Different patch authors"
|
||||
unless (all (== typ) typs) $ throwE "Different patch types"
|
||||
return (author, Material typ (content :| contents))
|
||||
|
||||
checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI)
|
||||
checkTipURI u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route"
|
||||
case route of
|
||||
RepoR repoHash -> decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid"
|
||||
_ -> throwE "URI is local route but not a repo route"
|
||||
else pure $ Right u
|
||||
|
||||
checkBranch :: Host -> AP.Branch URIMode -> ExceptT Text Handler (Either RepoId FedURI, Text)
|
||||
checkBranch h (AP.Branch name _ luRepo) =
|
||||
(,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo)
|
||||
|
||||
checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ExceptT Text Handler Tip
|
||||
checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u
|
||||
checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b
|
||||
|
||||
checkMR
|
||||
:: Host
|
||||
-> AP.MergeRequest URIMode
|
||||
-> ExceptT Text Handler
|
||||
(Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
|
||||
checkMR h (AP.MergeRequest muOrigin target mbundle) =
|
||||
(,,)
|
||||
<$> traverse checkTip muOrigin
|
||||
<*> (for mbundle $ \ bundle ->
|
||||
case bundle of
|
||||
Left _ -> throwE "MR bundle specified as a URI"
|
||||
Right (h, b) -> checkBundle h b
|
||||
)
|
||||
<*> checkTip (bimap (ObjURI h) (h,) target)
|
||||
|
||||
checkTracker :: FedURI -> ExceptT Text Handler Tracker
|
||||
checkTracker u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then do
|
||||
route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route"
|
||||
case route of
|
||||
DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash"
|
||||
LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash"
|
||||
_ -> throwE "Local tracker not a deck/loom route"
|
||||
else pure $ TrackerRemote u
|
||||
|
||||
checkTicket
|
||||
:: Host
|
||||
-> AP.Ticket URIMode
|
||||
-> ExceptT Text Handler
|
||||
( Either PersonId FedURI
|
||||
, Text, HTML, PandocMarkdown
|
||||
, Maybe Tracker
|
||||
, Maybe Merge
|
||||
)
|
||||
checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary content source muAssigned mresolved mmr) = do
|
||||
verifyNothingE mlocal "Ticket with 'id'"
|
||||
author <- checkAuthor $ ObjURI h attrib
|
||||
verifyNothingE mpublished "Ticket with 'published'"
|
||||
verifyNothingE mupdated "Ticket with 'updated'"
|
||||
maybeTracker <- traverse checkTracker muContext
|
||||
verifyNothingE muAssigned "Ticket has 'assignedTo'"
|
||||
verifyNothingE mresolved "Ticket is resolved"
|
||||
maybeMerge <- for mmr $ \ (h, mr) -> do
|
||||
(maybeOriginTip, maybeAuthorAndBundle, targetTip) <- checkMR h mr
|
||||
maybeBundle <- for maybeAuthorAndBundle $ \ (author', bundle) -> do
|
||||
unless (author == author') $
|
||||
throwE "Ticket author and patch(es) author are different"
|
||||
return bundle
|
||||
return $ Merge maybeOriginTip maybeBundle targetTip
|
||||
return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge)
|
||||
|
||||
checkTrackerAndMerge :: Tracker -> Maybe Merge -> ExceptT Text Handler TrackerAndMerge
|
||||
checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID
|
||||
checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR"
|
||||
checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR"
|
||||
checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge
|
||||
checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge
|
||||
|
||||
checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler WorkItemOffer
|
||||
checkOfferTicket host ticket uTarget = do
|
||||
target <- checkTracker uTarget
|
||||
(author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket
|
||||
for_ maybeTracker $ \ tracker ->
|
||||
unless (tracker == target) $ throwE "Offer target != ticket context"
|
||||
tam <- checkTrackerAndMerge target maybeBundle
|
||||
return $ WorkItemOffer author title desc source tam
|
||||
|
|
@ -85,6 +85,7 @@ import Data.MediaType
|
|||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..), ActorDetail (..))
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
|
@ -247,9 +248,9 @@ getClothR loomHash clothHash = do
|
|||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Just $ encodeRouteHome $ LoomR loomHash
|
||||
-- , AP.ticketName = Just $ "#" <> T.pack (show num)
|
||||
, AP.ticketSummary = TextHtml $ ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketSummary = encodeEntities $ ticketTitle ticket
|
||||
, AP.ticketContent = ticketDescription ticket
|
||||
, AP.ticketSource = ticketSource ticket
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketResolved =
|
||||
let u (Left (actor, obiid)) =
|
||||
|
|
@ -305,7 +306,7 @@ getClothR loomHash clothHash = do
|
|||
(justHere proposal)
|
||||
hashMessageKey <- handlerToWidget getEncodeKeyHashid
|
||||
let desc :: Widget
|
||||
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
|
||||
desc = toWidget $ markupHTML $ ticketDescription ticket
|
||||
discuss =
|
||||
discussionW
|
||||
(return $ ticketDiscuss ticket)
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ import Data.Time.Format (formatTime, defaultTimeLocale)
|
|||
import Data.Traversable (for)
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
||||
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||||
|
|
@ -120,6 +120,7 @@ import Data.Aeson.Encode.Pretty.ToEncoding
|
|||
import Data.MediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Ticket (..), Project, TicketDependency)
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
|
|
@ -230,9 +231,9 @@ getTicketR deckHash ticketHash = do
|
|||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = Just $ encodeRouteHome $ DeckR deckHash
|
||||
-- , AP.ticketName = Just $ "#" <> T.pack (show num)
|
||||
, AP.ticketSummary = TextHtml $ ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketSummary = encodeEntities $ ticketTitle ticket
|
||||
, AP.ticketContent = ticketDescription ticket
|
||||
, AP.ticketSource = ticketSource ticket
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketResolved =
|
||||
let u (Left (actor, obiid)) =
|
||||
|
|
@ -269,7 +270,7 @@ getTicketR deckHash ticketHash = do
|
|||
<*> getTicketClasses ticketID --wid
|
||||
hashMessageKey <- handlerToWidget getEncodeKeyHashid
|
||||
let desc :: Widget
|
||||
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
|
||||
desc = toWidget $ markupHTML $ ticketDescription ticket
|
||||
discuss =
|
||||
discussionW
|
||||
(return $ ticketDiscuss ticket)
|
||||
|
|
@ -1085,9 +1086,9 @@ getSharerTicketR shr talkhid = do
|
|||
ProjectR (sharerIdent s) (projectIdent j)
|
||||
Right (i, ro) ->
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
, AP.ticketSummary = TextHtml $ ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketSummary = encodeEntities $ ticketTitle ticket
|
||||
, AP.ticketContent = ticketDescription ticket
|
||||
, AP.ticketSource = ticketSource ticket
|
||||
, AP.ticketAssignedTo =
|
||||
encodeRouteHome . SharerR . sharerIdent <$> massignee
|
||||
, AP.ticketResolved =
|
||||
|
|
|
|||
|
|
@ -62,7 +62,9 @@ import qualified Data.CaseInsensitive as CI
|
|||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified HTMLEntities.Decoder as HED
|
||||
|
||||
import qualified Database.Persist.Schema as S
|
||||
import qualified Database.Persist.Schema.Types as ST
|
||||
|
|
@ -2690,6 +2692,14 @@ changes hLocal ctx =
|
|||
, addFieldRefOptional "Repo" Nothing "loom" "Loom"
|
||||
-- 494
|
||||
, addEntities model_494_mr_origin
|
||||
-- 495
|
||||
, unchecked $ lift $ do
|
||||
tickets <- selectList [] []
|
||||
for_ tickets $ \ (Entity ticketID ticket) -> do
|
||||
let plain =
|
||||
TL.toStrict . TLB.toLazyText . HED.htmlEncodedText $
|
||||
ticket495Title ticket
|
||||
update ticketID [Ticket495Title =. plain]
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -296,6 +296,7 @@ import Database.Persist.Schema.SQL ()
|
|||
import Database.Persist.Schema.TH (makeEntitiesMigration)
|
||||
import Database.Persist.Sql (SqlBackend)
|
||||
import Text.Email.Validate (EmailAddress)
|
||||
import Web.Text (HTML, PandocMarkdown)
|
||||
|
||||
import Development.PatchMediaType
|
||||
import Development.PatchMediaType.Persist
|
||||
|
|
@ -665,3 +666,6 @@ makeEntitiesMigration "486"
|
|||
|
||||
model_494_mr_origin :: [Entity SqlBackend]
|
||||
model_494_mr_origin = $(schema "494_2022-09-17_mr_origin")
|
||||
|
||||
makeEntitiesMigration "495"
|
||||
$(modelFile "migrations/495_2022-09-21_ticket_title.model")
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ import Development.PatchMediaType
|
|||
import Development.PatchMediaType.Persist
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub (Doc, Activity)
|
||||
import Web.Text (HTML, PandocMarkdown)
|
||||
|
||||
import Vervis.FedURI
|
||||
import Vervis.Model.Group
|
||||
|
|
|
|||
|
|
@ -47,8 +47,6 @@ module Web.ActivityPub
|
|||
-- * Content objects
|
||||
, Note (..)
|
||||
, TicketDependency (..)
|
||||
, TextHtml (..)
|
||||
, TextPandocMarkdown (..)
|
||||
, PatchLocal (..)
|
||||
, Patch (..)
|
||||
, BundleLocal (..)
|
||||
|
|
@ -100,6 +98,7 @@ module Web.ActivityPub
|
|||
, fetchAP
|
||||
, fetchAPID
|
||||
, fetchAPID'
|
||||
, fetchTip
|
||||
, fetchRecipient
|
||||
, fetchResource
|
||||
, keyListedByActor
|
||||
|
|
@ -161,6 +160,7 @@ import Development.PatchMediaType
|
|||
import Development.PatchMediaType.JSON
|
||||
import Network.FedURI
|
||||
import Network.HTTP.Digest
|
||||
import Web.Text
|
||||
|
||||
import Data.Aeson.Local
|
||||
|
||||
|
|
@ -902,16 +902,6 @@ instance ActivityPub TicketDependency where
|
|||
, relationshipUpdated = ticketDepUpdated td
|
||||
}
|
||||
|
||||
newtype TextHtml = TextHtml
|
||||
{ unTextHtml :: Text
|
||||
}
|
||||
deriving (FromJSON, ToJSON)
|
||||
|
||||
newtype TextPandocMarkdown = TextPandocMarkdown
|
||||
{ unTextPandocMarkdown :: Text
|
||||
}
|
||||
deriving (FromJSON, ToJSON)
|
||||
|
||||
data PatchLocal = PatchLocal
|
||||
{ patchId :: LocalURI
|
||||
, patchContext :: LocalURI
|
||||
|
|
@ -1149,9 +1139,9 @@ data Ticket u = Ticket
|
|||
, ticketUpdated :: Maybe UTCTime
|
||||
, ticketContext :: Maybe (ObjURI u)
|
||||
-- , ticketName :: Maybe Text
|
||||
, ticketSummary :: TextHtml
|
||||
, ticketContent :: TextHtml
|
||||
, ticketSource :: TextPandocMarkdown
|
||||
, ticketSummary :: Escaped
|
||||
, ticketContent :: HTML
|
||||
, ticketSource :: PandocMarkdown
|
||||
, ticketAssignedTo :: Maybe (ObjURI u)
|
||||
, ticketResolved :: Maybe (Maybe (ObjURI u), Maybe UTCTime)
|
||||
, ticketAttachment :: Maybe (Authority u, MergeRequest u)
|
||||
|
|
@ -1195,8 +1185,8 @@ instance ActivityPub Ticket where
|
|||
<*> o .:? "updated"
|
||||
<*> o .:? "context"
|
||||
-- <*> o .:? "name"
|
||||
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
|
||||
<*> (TextHtml . sanitizeBalance <$> o .: "content")
|
||||
<*> o .: "summary"
|
||||
<*> o .: "content"
|
||||
<*> source .: "content"
|
||||
<*> o .:? "assignedTo"
|
||||
<*> pure mresolved
|
||||
|
|
@ -1687,7 +1677,7 @@ data Activity u = Activity
|
|||
{ activityId :: Maybe LocalURI
|
||||
, activityActor :: LocalURI
|
||||
, activityCapability :: Maybe (ObjURI u)
|
||||
, activitySummary :: Maybe TextHtml
|
||||
, activitySummary :: Maybe HTML
|
||||
, activityAudience :: Audience u
|
||||
, activityFulfills :: [ObjURI u]
|
||||
, activitySpecific :: SpecificActivity u
|
||||
|
|
@ -1702,7 +1692,7 @@ instance ActivityPub Activity where
|
|||
<$> withAuthorityMaybeO a (o .:? "id")
|
||||
<*> pure actor
|
||||
<*> o .:? "capability"
|
||||
<*> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary")
|
||||
<*> o .:? "summary"
|
||||
<*> parseAudience o
|
||||
<*> o .:? "fulfills" .!= []
|
||||
<*> do
|
||||
|
|
@ -1961,6 +1951,18 @@ fetchAPID' m getId h lu = runExceptT $ do
|
|||
then return v
|
||||
else throwE Nothing
|
||||
|
||||
fetchTip :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Either (Repo u) (Branch u)))
|
||||
fetchTip m h lu = runExceptT $ do
|
||||
tip <- fmap toEither $ withExceptT Just $ fetchAP' m $ Left $ ObjURI h lu
|
||||
bitraverse
|
||||
(\ (Doc h' repo) ->
|
||||
if h == h' && actorId (actorLocal $ repoActor repo) == lu
|
||||
then return repo
|
||||
else throwE Nothing
|
||||
)
|
||||
(\ (Doc _ branch) -> pure branch)
|
||||
tip
|
||||
|
||||
fetchRecipient :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u))
|
||||
fetchRecipient m = fetchAPID' m getId
|
||||
where
|
||||
|
|
|
|||
77
src/Web/Text.hs
Normal file
77
src/Web/Text.hs
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 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 Web.Text
|
||||
( HTML ()
|
||||
, PandocMarkdown ()
|
||||
, Escaped ()
|
||||
, renderHTML
|
||||
, markupHTML
|
||||
, encodeEntities
|
||||
, decodeEntities
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import HTMLEntities.Decoder
|
||||
import Text.Blaze (preEscapedText)
|
||||
import Text.Blaze.Html (Html)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import qualified HTMLEntities.Text as HET
|
||||
|
||||
newtype HTML = HTML { unHTML :: Text }
|
||||
deriving (ToJSON, PersistField, PersistFieldSql)
|
||||
|
||||
instance FromJSON HTML where
|
||||
parseJSON = fmap (HTML . sanitizeBalance) . parseJSON
|
||||
|
||||
newtype PandocMarkdown = PandocMarkdown { _unPandocMarkdown :: Text }
|
||||
deriving (FromJSON, ToJSON, PersistField, PersistFieldSql)
|
||||
|
||||
newtype Escaped = Escaped { unEscaped :: Text }
|
||||
deriving (ToJSON, PersistField, PersistFieldSql)
|
||||
|
||||
escape :: Text -> Text
|
||||
escape = HET.text
|
||||
|
||||
unescape :: Text -> Text
|
||||
unescape = TL.toStrict . TLB.toLazyText . htmlEncodedText
|
||||
|
||||
instance FromJSON Escaped where
|
||||
parseJSON =
|
||||
withText "Escaped" $ \ t ->
|
||||
let decoded = unescape t
|
||||
in if escape decoded == t
|
||||
then return $ Escaped t
|
||||
else fail "HTML contains more than just HTML-escaped plain text"
|
||||
|
||||
renderHTML :: Html -> HTML
|
||||
renderHTML = HTML . TL.toStrict . renderHtml
|
||||
|
||||
markupHTML :: HTML -> Html
|
||||
markupHTML = preEscapedText . unHTML
|
||||
|
||||
encodeEntities :: Text -> Escaped
|
||||
encodeEntities = Escaped . escape
|
||||
|
||||
decodeEntities :: Escaped -> Text
|
||||
decodeEntities = unescape . unEscaped
|
||||
|
|
@ -13,7 +13,7 @@ $# 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/>.
|
||||
|
||||
<h2>#{preEscapedToHtml $ ticketTitle ticket}
|
||||
<h2>#{ticketTitle ticket}
|
||||
|
||||
<div>
|
||||
Created on #{showDate $ ticketCreated ticket} by
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ $# 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/>.
|
||||
|
||||
<h2>#{preEscapedToHtml $ ticketTitle ticket}
|
||||
<h2>#{ticketTitle ticket}
|
||||
|
||||
<div>
|
||||
Created on #{showDate $ ticketCreated ticket} by
|
||||
|
|
|
|||
|
|
@ -415,9 +415,9 @@ TicketParamClass
|
|||
Ticket
|
||||
number Int Maybe
|
||||
created UTCTime
|
||||
title Text -- HTML
|
||||
source Text -- Pandoc Markdown
|
||||
description Text -- HTML
|
||||
title Text
|
||||
source PandocMarkdown
|
||||
description HTML
|
||||
status TicketStatus
|
||||
discuss DiscussionId
|
||||
followers FollowerSetId
|
||||
|
|
|
|||
|
|
@ -108,6 +108,7 @@ library
|
|||
Web.ActivityAccess
|
||||
Web.ActivityPub
|
||||
-- Web.Capability
|
||||
Web.Text
|
||||
Web.Hashids.Local
|
||||
Web.PathPieces.Local
|
||||
Yesod.ActivityPub
|
||||
|
|
@ -140,6 +141,7 @@ library
|
|||
|
||||
Vervis.Data.Actor
|
||||
Vervis.Data.Collab
|
||||
Vervis.Data.Ticket
|
||||
|
||||
Vervis.Delivery
|
||||
Vervis.Discussion
|
||||
|
|
@ -256,6 +258,7 @@ library
|
|||
ViewPatterns
|
||||
TupleSections
|
||||
RecordWildCards
|
||||
LambdaCase
|
||||
|
||||
build-depends: aeson
|
||||
-- For activity JSOn display in /inbox test page
|
||||
|
|
@ -324,6 +327,7 @@ library
|
|||
-- for source file highlighting
|
||||
, highlighter2
|
||||
, http-client-signature
|
||||
, html-entities
|
||||
, http-signature
|
||||
, git
|
||||
, hit-graph
|
||||
|
|
|
|||
Loading…
Reference in a new issue