Move AP Ticket local URI fields into a dedicated TicketLocal type
This commit is contained in:
fr33domlover
parent
e31c8c600b
commit
b69442b448
2 changed files with 77 additions and 39 deletions
|
|
@ -282,37 +282,45 @@ getTicketR shar proj num = do
|
|||
TSNew -> wffNew filt
|
||||
TSTodo -> wffTodo filt
|
||||
TSClosed -> wffClosed filt
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let siblingUri =
|
||||
encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
|
||||
ticketAP = AP.Ticket
|
||||
{ AP.ticketId =
|
||||
Just $ encodeRouteLocal $ TicketR shar proj num
|
||||
{ AP.ticketLocal = Just
|
||||
( hLocal
|
||||
, AP.TicketLocal
|
||||
{ AP.ticketId =
|
||||
encodeRouteLocal $ TicketR shar proj num
|
||||
, AP.ticketContext =
|
||||
encodeRouteLocal $ ProjectR shar proj
|
||||
, AP.ticketReplies =
|
||||
encodeRouteLocal $ TicketDiscussionR shar proj num
|
||||
, AP.ticketParticipants =
|
||||
encodeRouteLocal $ TicketParticipantsR shar proj num
|
||||
, AP.ticketTeam =
|
||||
encodeRouteLocal $ TicketTeamR shar proj num
|
||||
, AP.ticketEvents =
|
||||
encodeRouteLocal $ TicketEventsR shar proj num
|
||||
}
|
||||
)
|
||||
|
||||
, AP.ticketAttributedTo =
|
||||
encodeRouteHome $ SharerR $ sharerIdent author
|
||||
encodeRouteLocal $ SharerR $ sharerIdent author
|
||||
, AP.ticketPublished = Just $ ticketCreated ticket
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketContext = encodeRouteLocal $ ProjectR shar proj
|
||||
, AP.ticketName = Just $ "#" <> T.pack (show num)
|
||||
, AP.ticketSummary =
|
||||
TextHtml $ TL.toStrict $ renderHtml $ toHtml $
|
||||
ticketTitle ticket
|
||||
, AP.ticketContent = TextHtml $ ticketDescription ticket
|
||||
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
|
||||
, AP.ticketReplies =
|
||||
Just $ encodeRouteLocal $ TicketDiscussionR shar proj num
|
||||
, AP.ticketAssignedTo =
|
||||
encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
|
||||
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
|
||||
, AP.ticketParticipants =
|
||||
Just $ encodeRouteLocal $ TicketParticipantsR shar proj num
|
||||
, AP.ticketTeam =
|
||||
Just $ encodeRouteLocal $ TicketTeamR shar proj num
|
||||
, AP.ticketDependsOn = map siblingUri deps
|
||||
, AP.ticketDependedBy = map siblingUri rdeps
|
||||
, AP.ticketEvents =
|
||||
Just $ encodeRouteLocal $ TicketEventsR shar proj num
|
||||
}
|
||||
provideHtmlAndAP ticketAP $(widgetFile "ticket/one")
|
||||
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ module Web.ActivityPub
|
|||
, Note (..)
|
||||
, TextHtml (..)
|
||||
, TextPandocMarkdown (..)
|
||||
, TicketLocal (..)
|
||||
, Ticket (..)
|
||||
|
||||
-- * Activity
|
||||
|
|
@ -115,7 +116,7 @@ import qualified Data.ByteString as B
|
|||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.HashMap.Strict as M (lookup)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Text as T (pack, unpack)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Network.HTTP.Signature as S
|
||||
|
|
@ -615,24 +616,63 @@ newtype TextPandocMarkdown = TextPandocMarkdown
|
|||
}
|
||||
deriving (FromJSON, ToJSON)
|
||||
|
||||
data TicketLocal = TicketLocal
|
||||
{ ticketId :: LocalURI
|
||||
, ticketContext :: LocalURI
|
||||
, ticketReplies :: LocalURI
|
||||
, ticketParticipants :: LocalURI
|
||||
, ticketTeam :: LocalURI
|
||||
, ticketEvents :: LocalURI
|
||||
}
|
||||
|
||||
parseTicketLocal :: Object -> Parser (Maybe (Text, TicketLocal))
|
||||
parseTicketLocal o = do
|
||||
mid <- fmap f2l <$> o .:? "id"
|
||||
case mid of
|
||||
Nothing -> do
|
||||
verifyNothing "context"
|
||||
verifyNothing "replies"
|
||||
verifyNothing $ frg <> "participants"
|
||||
verifyNothing $ frg <> "team"
|
||||
verifyNothing $ frg <> "events"
|
||||
return Nothing
|
||||
Just (h, id_) ->
|
||||
fmap (Just . (h,)) $
|
||||
TicketLocal
|
||||
<$> pure id_
|
||||
<*> withHost h (f2l <$> o .: "context")
|
||||
<*> withHost h (f2l <$> o .: "replies")
|
||||
<*> withHost h (f2l <$> o .: (frg <> "participants"))
|
||||
<*> withHost h (f2l <$> o .: (frg <> "team"))
|
||||
<*> withHost h (f2l <$> o .: (frg <> "events"))
|
||||
where
|
||||
verifyNothing t =
|
||||
if t `M.member` o
|
||||
then fail $ T.unpack t ++ " field found, expected none"
|
||||
else return ()
|
||||
|
||||
encodeTicketLocal :: Text -> TicketLocal -> Series
|
||||
encodeTicketLocal h (TicketLocal id_ context replies participants team events)
|
||||
= "id" .= l2f h id_
|
||||
<> "context" .= l2f h context
|
||||
<> "replies" .= l2f h replies
|
||||
<> (frg <> "participants") .= l2f h participants
|
||||
<> (frg <> "team") .= l2f h team
|
||||
<> (frg <> "events") .= l2f h events
|
||||
|
||||
data Ticket = Ticket
|
||||
{ ticketId :: Maybe LocalURI
|
||||
, ticketAttributedTo :: FedURI
|
||||
{ ticketLocal :: Maybe (Text, TicketLocal)
|
||||
, ticketAttributedTo :: LocalURI
|
||||
, ticketPublished :: Maybe UTCTime
|
||||
, ticketUpdated :: Maybe UTCTime
|
||||
, ticketContext :: LocalURI
|
||||
, ticketName :: Maybe Text
|
||||
, ticketSummary :: TextHtml
|
||||
, ticketContent :: TextHtml
|
||||
, ticketSource :: TextPandocMarkdown
|
||||
, ticketReplies :: Maybe LocalURI
|
||||
, ticketAssignedTo :: Maybe FedURI
|
||||
, ticketIsResolved :: Bool
|
||||
, ticketParticipants :: Maybe LocalURI
|
||||
, ticketTeam :: Maybe LocalURI
|
||||
, ticketDependsOn :: [FedURI]
|
||||
, ticketDependedBy :: [FedURI]
|
||||
, ticketEvents :: Maybe LocalURI
|
||||
}
|
||||
|
||||
instance ActivityPub Ticket where
|
||||
|
|
@ -651,38 +691,32 @@ instance ActivityPub Ticket where
|
|||
unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
|
||||
fail "source mediaType isn't Pandoc Markdown"
|
||||
|
||||
(h, context) <- f2l <$> o .: "context"
|
||||
(h, attributedTo) <- f2l <$> o .: "attributedTo"
|
||||
|
||||
fmap (h,) $
|
||||
Ticket
|
||||
<$> withHostMaybe h (fmap f2l <$> o .:? "id")
|
||||
<*> o .: "attributedTo"
|
||||
<$> parseTicketLocal o
|
||||
<*> pure attributedTo
|
||||
<*> o .:? "published"
|
||||
<*> o .:? "updated"
|
||||
<*> pure context
|
||||
<*> o .:? "name"
|
||||
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
|
||||
<*> (TextHtml . sanitizeBalance <$> o .: "content")
|
||||
<*> source .: "content"
|
||||
<*> withHostMaybe h (fmap f2l <$> o .:? "replies")
|
||||
<*> o .:? (frg <> "assignedTo")
|
||||
<*> o .: (frg <> "isResolved")
|
||||
<*> withHostMaybe h (fmap f2l <$> o .:? (frg <> "participants"))
|
||||
<*> withHostMaybe h (fmap f2l <$> o .:? (frg <> "team"))
|
||||
<*> o .:? (frg <> "dependsOn") .!= []
|
||||
<*> o .:? (frg <> "dependedBy") .!= []
|
||||
<*> withHostMaybe h (fmap f2l <$> o .:? (frg <> "events"))
|
||||
|
||||
toSeries host
|
||||
(Ticket id_ attributedTo published updated context name summary content
|
||||
source replies assignedTo isResolved participants team
|
||||
dependsOn dependedBy events)
|
||||
= "type" .= ("Ticket" :: Text)
|
||||
<> "id" .=? (l2f host <$> id_)
|
||||
<> "attributedTo" .= attributedTo
|
||||
(Ticket local attributedTo published updated name summary content
|
||||
source assignedTo isResolved dependsOn dependedBy)
|
||||
|
||||
= maybe mempty (uncurry encodeTicketLocal) local
|
||||
<> "type" .= ("Ticket" :: Text)
|
||||
<> "attributedTo" .= l2f host attributedTo
|
||||
<> "published" .=? published
|
||||
<> "updated" .=? updated
|
||||
<> "context" .= l2f host context
|
||||
<> "name" .=? name
|
||||
<> "summary" .= summary
|
||||
<> "content" .= content
|
||||
|
|
@ -691,14 +725,10 @@ instance ActivityPub Ticket where
|
|||
[ "content" .= source
|
||||
, "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
|
||||
]
|
||||
<> "replies" .=? (l2f host <$> replies)
|
||||
<> (frg <> "assignedTo") .=? assignedTo
|
||||
<> (frg <> "isResolved") .= isResolved
|
||||
<> (frg <> "participants") .=? (l2f host <$> participants)
|
||||
<> (frg <> "team") .=? (l2f host <$> team)
|
||||
<> (frg <> "dependsOn") .=% dependsOn
|
||||
<> (frg <> "dependedBy") .=% dependedBy
|
||||
<> (frg <> "events") .=? (l2f host <$> events)
|
||||
|
||||
data Accept = Accept
|
||||
{ acceptObject :: FedURI
|
||||
|
|
|
|||
Loading…
Reference in a new issue