643 lines
17 KiB
Haskell
643 lines
17 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Fedi.Types where
|
|
|
|
import Control.Monad (guard)
|
|
import Data.Aeson qualified as A
|
|
import Data.Aeson.Types qualified as A
|
|
import Data.Text qualified as T
|
|
import Fedi.UserDetails
|
|
import Prelude hiding (id, last)
|
|
|
|
-- | An Object is what everything is here.
|
|
-- <https://www.w3.org/TR/activitystreams-vocabulary/#object-types>
|
|
data Object typ
|
|
= Object
|
|
{ id :: Maybe ObjectId
|
|
, otype :: typ
|
|
, content :: Maybe Content
|
|
, published :: Maybe UTCTime
|
|
, replies :: Maybe [Link]
|
|
, attachment :: Maybe [AnyMedia]
|
|
, attributedTo :: Maybe (LinkOrObject Actor)
|
|
, -- , audience :: Maybe String
|
|
tag :: Maybe [Tag]
|
|
, to :: Maybe [Link]
|
|
, cc :: Maybe [Link]
|
|
, inReplyTo :: Maybe (LinkOrObject Actor)
|
|
, url :: Maybe Url -- revisit
|
|
, name :: Maybe Name
|
|
, icon :: Maybe Image
|
|
, image :: Maybe Image
|
|
, preview :: Maybe Preview
|
|
, summary :: Maybe T.Text
|
|
, updated :: Maybe UTCTime
|
|
, -- , bto :: Maybe String
|
|
-- , bcc :: Maybe String
|
|
mediaType :: Maybe MediaType
|
|
-- , duration :: Maybe String
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
class ToObject a where
|
|
toObject :: a -> [A.Pair]
|
|
|
|
instance (ToObject a) => A.ToJSON (Object a) where
|
|
toJSON = A.object . toObject
|
|
|
|
instance (ToObject a) => ToObject (Object a) where
|
|
toObject object =
|
|
[ "@context"
|
|
A..=
|
|
[ ("https://www.w3.org/ns/activitystreams" :: String)
|
|
, ("https://w3id.org/security/v1" :: String)
|
|
]
|
|
]
|
|
<> toObject object.otype
|
|
<> [ assignment
|
|
| Just assignment <-
|
|
[ fmap ("id" A..=) object.id
|
|
, fmap ("content" A..=) object.content
|
|
, fmap ("attachement" A..=) object.attachment
|
|
, fmap ("attributedTo" A..=) object.attributedTo
|
|
, fmap ("published" A..=) object.published
|
|
, fmap ("inReplyTo" A..=) object.inReplyTo
|
|
, fmap ("url" A..=) object.url
|
|
, fmap ("name" A..=) object.name
|
|
, fmap ("icon" A..=) object.icon
|
|
, fmap ("image" A..=) object.image
|
|
, -- , fmap ("preview" A..= ) object.preview
|
|
fmap ("summary" A..=) object.summary
|
|
, fmap ("updated" A..=) object.updated
|
|
, fmap ("mediaType" A..=) object.mediaType
|
|
, fmap ("to" A..=) object.to
|
|
, fmap ("cc" A..=) object.cc
|
|
, fmap ("replies" A..=) object.replies
|
|
]
|
|
]
|
|
|
|
instance (A.FromJSON a) => A.FromJSON (Object a) where
|
|
parseJSON object = do
|
|
otype <- A.parseJSON object
|
|
flip (A.withObject "Object") object $ \v -> do
|
|
id <- v A..:? "id"
|
|
content <- v A..:? "content"
|
|
published <- v A..:? "published"
|
|
replies <- v A..:? "replies"
|
|
attachment <- v A..:? "attachment"
|
|
attributedTo <- v A..:? "attributedTo"
|
|
tag <- pure Nothing -- v A..:? "tag"
|
|
to <- v A..:? "to"
|
|
cc <- v A..:? "cc"
|
|
inReplyTo <- v A..:? "inReplyTo"
|
|
url <- v A..:? "url"
|
|
name <- v A..:? "name"
|
|
icon <- v A..:? "icon"
|
|
image <- v A..:? "image"
|
|
preview <- pure Nothing -- v A..:? "preview"
|
|
summary <- v A..:? "summary"
|
|
updated <- v A..:? "updated"
|
|
mediaType <- v A..:? "mediaType"
|
|
pure $ Object {..}
|
|
|
|
newtype ObjectId = ObjectId {unwrap :: String}
|
|
deriving (Show, Eq, A.FromJSON, A.ToJSON) via String
|
|
|
|
newtype Link = Link {unwrap :: Url}
|
|
deriving (Show, Eq, A.FromJSON, A.ToJSON) via Url
|
|
|
|
data LinkOrObject a
|
|
= LLink Link
|
|
| OObject (Object a)
|
|
| CCollection [LinkOrObject a]
|
|
deriving (Show, Eq)
|
|
|
|
instance (A.FromJSON a) => A.FromJSON (LinkOrObject a) where
|
|
parseJSON = \case
|
|
A.String str -> pure $ LLink (Link $ T.unpack str)
|
|
A.Array objs -> CCollection <$> traverse A.parseJSON (toList objs)
|
|
value -> OObject <$> A.parseJSON value
|
|
|
|
getAttributedTo :: LinkOrObject a -> Link
|
|
getAttributedTo = \case
|
|
LLink link -> link
|
|
OObject obj -> Link (fromMaybe (ObjectId "") obj.id).unwrap
|
|
CCollection list ->
|
|
maybe (Link "") getAttributedTo (listToMaybe list)
|
|
|
|
instance (ToObject o) => A.ToJSON (LinkOrObject o) where
|
|
toJSON = \case
|
|
LLink link -> A.toJSON link
|
|
OObject ob -> A.toJSON ob
|
|
CCollection loos -> A.toJSON loos
|
|
|
|
data AnyMedia
|
|
= ImageMedia Image
|
|
deriving (Show, Eq)
|
|
|
|
instance A.ToJSON AnyMedia where
|
|
toJSON = \case
|
|
ImageMedia obj -> A.toJSON obj
|
|
|
|
instance A.FromJSON AnyMedia where
|
|
parseJSON value =
|
|
ImageMedia <$> A.parseJSON value
|
|
|
|
type Image = Object TypeImage
|
|
|
|
data TypeImage = TypeImage deriving (Show, Eq)
|
|
|
|
instance ToObject TypeImage where
|
|
toObject TypeImage =
|
|
["type" A..= ("Image" :: String)]
|
|
|
|
instance A.FromJSON TypeImage where
|
|
parseJSON =
|
|
A.withObject "TypeImage" \value -> do
|
|
(i :: String) <- value A..: "type"
|
|
guard (i == "Image")
|
|
pure TypeImage
|
|
|
|
data Name
|
|
= StringName String
|
|
| ObjectName (LinkOrObject Actor)
|
|
deriving (Show, Eq)
|
|
|
|
instance A.ToJSON Name where
|
|
toJSON = \case
|
|
StringName str -> A.toJSON str
|
|
ObjectName loo -> A.toJSON loo
|
|
|
|
instance A.FromJSON Name where
|
|
parseJSON = \case
|
|
A.String str -> pure $ StringName (T.unpack str)
|
|
value -> ObjectName <$> A.parseJSON value
|
|
|
|
type Content = T.Text
|
|
|
|
type MediaType = String
|
|
|
|
-- | A Note is an object that has the type 'Note'.
|
|
type Note = Object TypeNote
|
|
|
|
data TypeNote
|
|
= TypeNote
|
|
{ likes :: Collection Like
|
|
, shares :: Collection Share
|
|
, replies :: Collection Note
|
|
, sensitive :: Bool
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeNote where
|
|
toObject note =
|
|
[ "type" A..= ("Note" :: String)
|
|
, "likes" A..= note.likes
|
|
, "shares" A..= note.shares
|
|
, "sensitive" A..= note.sensitive
|
|
]
|
|
|
|
instance A.FromJSON TypeNote where
|
|
parseJSON =
|
|
A.withObject "TypeNote" \value -> do
|
|
likes <- value A..: "likes"
|
|
shares <- value A..: "shares"
|
|
replies <- value A..: "replies"
|
|
sensitive <- value A..: "sensitive"
|
|
pure TypeNote {..}
|
|
|
|
type Tag = Object TypeTag
|
|
|
|
data TypeTag
|
|
= TypeTag
|
|
{ href :: Url
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
type Preview = Object TypePreview
|
|
|
|
data TypePreview = TypePreview
|
|
deriving (Show, Eq)
|
|
|
|
type Share = Object TypeShare
|
|
|
|
data TypeShare = TypeShare deriving (Show, Eq)
|
|
|
|
instance ToObject TypeShare where
|
|
toObject TypeShare =
|
|
[ "type" A..= ("Share" :: String)
|
|
]
|
|
|
|
instance A.FromJSON TypeShare where
|
|
parseJSON =
|
|
A.withObject "TypeShare" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Share")
|
|
pure TypeShare
|
|
|
|
-- * Activities
|
|
|
|
-- | An Activity is a superset of an Object with one of the following types,
|
|
-- <https://www.w3.org/TR/activitystreams-vocabulary/#activity-types>
|
|
-- and some additional fields.
|
|
type Activity t = Object (TypeActivity t)
|
|
|
|
data TypeActivity t
|
|
= TypeActivity
|
|
{ actor :: Link
|
|
, atype :: t
|
|
, target :: Maybe AnyActivity
|
|
, origin :: Maybe AnyActivity
|
|
-- , result :: Maybe String
|
|
-- , instrument :: Maybe String
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance (ToObject t) => ToObject (TypeActivity t) where
|
|
toObject activity =
|
|
[ "actor" A..= activity.actor
|
|
]
|
|
<> [ pair
|
|
| Just pair <-
|
|
[ fmap ("target" A..=) activity.target
|
|
, fmap ("origin" A..=) activity.origin
|
|
]
|
|
]
|
|
<> toObject activity.atype
|
|
|
|
instance (A.FromJSON a) => A.FromJSON (TypeActivity a) where
|
|
parseJSON object = do
|
|
atype <- A.parseJSON object
|
|
flip (A.withObject "TypeActivity") object \value -> do
|
|
actor <- value A..: "actor"
|
|
target <- value A..: "target"
|
|
origin <- value A..: "origin"
|
|
pure TypeActivity {..}
|
|
|
|
-- type Announce = Object (TypeActivity TypeAnnounce)
|
|
-- data TypeAnnounce = TypeAnnounce deriving Show
|
|
-- instance ToObject TypeAnnounce where
|
|
-- toObject TypeAnnounce =
|
|
-- [ "type" A..= ("Announce" :: String)
|
|
-- ]
|
|
|
|
type Create = Activity TypeCreate
|
|
|
|
data TypeCreate
|
|
= TypeCreate
|
|
{ object :: Note
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeCreate where
|
|
toObject create =
|
|
[ "type" A..= ("Create" :: String)
|
|
, "object" A..= create.object
|
|
]
|
|
|
|
instance A.FromJSON TypeCreate where
|
|
parseJSON =
|
|
A.withObject "TypeCreate" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Create")
|
|
object <- value A..: "object"
|
|
pure TypeCreate {..}
|
|
|
|
type Follow = Object (TypeActivity TypeFollow)
|
|
|
|
data TypeFollow
|
|
= TypeFollow
|
|
{ object :: LinkOrObject Actor
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeFollow where
|
|
toObject follow =
|
|
[ "type" A..= ("Follow" :: String)
|
|
, "object" A..= follow.object
|
|
]
|
|
|
|
instance A.FromJSON TypeFollow where
|
|
parseJSON =
|
|
A.withObject "TypeFollow" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Follow")
|
|
object <- value A..: "object"
|
|
pure TypeFollow {..}
|
|
|
|
-- | Undo
|
|
type Undo = Activity TypeUndo
|
|
|
|
data TypeUndo
|
|
= TypeUndo
|
|
{ object :: AnyActivity
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeUndo where
|
|
toObject undo =
|
|
[ "type" A..= ("Undo" :: String)
|
|
, "object" A..= undo.object
|
|
]
|
|
|
|
instance A.FromJSON TypeUndo where
|
|
parseJSON =
|
|
A.withObject "TypeUndo" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Undo")
|
|
object <- value A..: "object"
|
|
pure TypeUndo {..}
|
|
|
|
|
|
--
|
|
type Like = Object (TypeActivity TypeLike)
|
|
|
|
data TypeLike = TypeLike deriving (Show, Eq)
|
|
|
|
instance ToObject TypeLike where
|
|
toObject TypeLike =
|
|
[ "type" A..= ("Like" :: String)
|
|
]
|
|
|
|
instance A.FromJSON TypeLike where
|
|
parseJSON =
|
|
A.withObject "TypeLike" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Like")
|
|
pure TypeLike
|
|
|
|
data AnyActivity
|
|
= -- ActivityAnnounce Announce
|
|
ActivityCreate Create
|
|
| ActivityUndo Undo
|
|
| ActivityFollow Follow
|
|
| -- | ActivityLike Like
|
|
ActivityAccept Accept
|
|
| ActivityReject Reject
|
|
deriving (Show, Eq)
|
|
|
|
instance A.ToJSON AnyActivity where
|
|
toJSON = \case
|
|
-- ActivityAnnounce obj -> A.toJSON obj
|
|
ActivityCreate obj -> A.toJSON obj
|
|
ActivityUndo obj -> A.toJSON obj
|
|
ActivityFollow obj -> A.toJSON obj
|
|
-- ActivityLike obj -> A.toJSON obj
|
|
ActivityAccept obj -> A.toJSON obj
|
|
ActivityReject obj -> A.toJSON obj
|
|
|
|
instance A.FromJSON AnyActivity where
|
|
parseJSON value =
|
|
flip (A.withObject "AnyActivity") value \v -> do
|
|
typ :: String <- v A..: "type"
|
|
case typ of
|
|
"Create" -> ActivityCreate <$> A.parseJSON value
|
|
"Undo" -> ActivityUndo <$> A.parseJSON value
|
|
"Follow" -> ActivityFollow <$> A.parseJSON value
|
|
"Accept" -> ActivityAccept <$> A.parseJSON value
|
|
"Reject" -> ActivityReject <$> A.parseJSON value
|
|
_ -> fail ("Parsing '" <> typ <> "' not yet implemented.")
|
|
|
|
-- * Accept Reject Add Remove
|
|
|
|
type Accept = Object (TypeActivity TypeAccept)
|
|
|
|
data TypeAccept
|
|
= TypeAccept
|
|
{ object :: AnyActivity
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeAccept where
|
|
toObject obj =
|
|
[ "type" A..= ("Accept" :: String)
|
|
, "object" A..= obj.object
|
|
]
|
|
|
|
instance A.FromJSON TypeAccept where
|
|
parseJSON =
|
|
A.withObject "TypeAccept" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Accept")
|
|
object <- value A..: "object"
|
|
pure TypeAccept {..}
|
|
|
|
type Reject = Object (TypeActivity TypeReject)
|
|
|
|
data TypeReject
|
|
= TypeReject
|
|
{ object :: AnyActivity
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypeReject where
|
|
toObject obj =
|
|
[ "type" A..= ("Reject" :: String)
|
|
, "object" A..= obj.object
|
|
]
|
|
|
|
instance A.FromJSON TypeReject where
|
|
parseJSON =
|
|
A.withObject "TypeReject" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Reject")
|
|
object <- value A..: "object"
|
|
pure TypeReject {..}
|
|
|
|
-- * Actors
|
|
|
|
-- | An Actor is an object that has one of the following types.
|
|
-- <https://www.w3.org/TR/activitystreams-vocabulary/#actor-types>
|
|
data Actor
|
|
= ActorPerson Person
|
|
deriving (Show, Eq)
|
|
|
|
instance A.FromJSON Actor where
|
|
parseJSON =
|
|
fmap ActorPerson . A.parseJSON
|
|
|
|
instance A.ToJSON Actor where
|
|
toJSON = \case
|
|
ActorPerson obj -> A.toJSON obj
|
|
|
|
instance ToObject Actor where
|
|
toObject = \case
|
|
ActorPerson obj -> toObject obj
|
|
|
|
-- | A Person is an object that has the type 'Person'.
|
|
type Person = Object TypePerson
|
|
|
|
instance A.FromJSON TypePerson where
|
|
parseJSON =
|
|
A.withObject "Person" \value -> do
|
|
typ :: String <- value A..: "type"
|
|
guard (typ == "Person")
|
|
preferredUsername <- value A..: "preferredUsername"
|
|
publicKey <- value A..: "publicKey"
|
|
inbox <- value A..: "inbox"
|
|
outbox <- value A..: "outbox"
|
|
following <- value A..: "following"
|
|
followers <- value A..: "followers"
|
|
pure TypePerson {..}
|
|
|
|
data TypePerson
|
|
= TypePerson
|
|
{ preferredUsername :: String
|
|
, publicKey :: PublicKey
|
|
, inbox :: Link
|
|
, outbox :: Link
|
|
, following :: Link
|
|
, followers :: Link
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance ToObject TypePerson where
|
|
toObject person =
|
|
[ "type" A..= ("Person" :: String)
|
|
, "preferredUsername" A..= person.preferredUsername
|
|
, "publicKey" A..= person.publicKey
|
|
, "inbox" A..= person.inbox
|
|
, "outbox" A..= person.outbox
|
|
, "following" A..= person.following
|
|
, "followers" A..= person.followers
|
|
]
|
|
|
|
data PublicKey
|
|
= PublicKey
|
|
{ pkid :: Url
|
|
, owner :: Url
|
|
, publicKeyPem :: Pem
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance A.ToJSON PublicKey where
|
|
toJSON pk =
|
|
A.object
|
|
[ "id" A..= pk.pkid
|
|
, "owner" A..= pk.owner
|
|
, "publicKeyPem" A..= pk.publicKeyPem
|
|
]
|
|
|
|
instance A.FromJSON PublicKey where
|
|
parseJSON =
|
|
A.withObject "PublicKey" \value -> do
|
|
pkid <- value A..: "id"
|
|
owner <- value A..: "owner"
|
|
publicKeyPem <- value A..: "publicKeyPem"
|
|
pure PublicKey {..}
|
|
|
|
-- * Collections
|
|
|
|
type Collection e = Object (CollectionType (Unordered e))
|
|
|
|
type OrderedCollection e = Object (CollectionType (Ordered e))
|
|
|
|
type OrderedCollectionPage e = Object (CollectionType (OrderedPage e))
|
|
|
|
type Outbox = OrderedCollection AnyActivity
|
|
|
|
type OutboxPage = OrderedCollectionPage AnyActivity
|
|
|
|
type Followers = OrderedCollection Url
|
|
type FollowersPage = OrderedCollectionPage Url
|
|
|
|
data CollectionType t
|
|
= CollectionType
|
|
{ ctype :: t
|
|
, first :: Maybe Url
|
|
, last :: Maybe Url
|
|
, current :: Maybe Url
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance (ToObject t) => ToObject (CollectionType t) where
|
|
toObject collection =
|
|
toObject collection.ctype
|
|
<> [ pair
|
|
| Just pair <-
|
|
[ fmap ("first" A..=) collection.first
|
|
, fmap ("last" A..=) collection.last
|
|
, fmap ("current" A..=) collection.current
|
|
]
|
|
]
|
|
|
|
instance (A.FromJSON t) => A.FromJSON (CollectionType t) where
|
|
parseJSON value = do
|
|
ctype <- A.parseJSON value
|
|
flip (A.withObject "CollectionType") value \v -> do
|
|
first <- v A..:? "first"
|
|
last <- v A..:? "last"
|
|
current <- v A..:? "current"
|
|
pure CollectionType {..}
|
|
|
|
data Unordered e
|
|
= UnorderedCollectionType
|
|
{ items :: [e]
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance (A.ToJSON e) => ToObject (Unordered e) where
|
|
toObject collection =
|
|
[ "type" A..= ("Collection" :: String)
|
|
, "totalItems" A..= length collection.items
|
|
, "items" A..= collection.items
|
|
]
|
|
|
|
instance (A.FromJSON e) => A.FromJSON (Unordered e) where
|
|
parseJSON = do
|
|
A.withObject "Unordered" \v -> do
|
|
typ :: String <- v A..: "type"
|
|
guard (typ == "Collection")
|
|
items <- fromMaybe [] <$> v A..:? "items"
|
|
pure UnorderedCollectionType {..}
|
|
|
|
data Ordered e
|
|
= OrderedCollectionType
|
|
{ orderedItems :: [e]
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance (A.ToJSON e) => ToObject (Ordered e) where
|
|
toObject collection =
|
|
[ "type" A..= ("OrderedCollection" :: String)
|
|
, "totalItems" A..= length collection.orderedItems
|
|
, "orderedItems" A..= collection.orderedItems
|
|
]
|
|
|
|
instance (A.FromJSON e) => A.FromJSON (Ordered e) where
|
|
parseJSON = do
|
|
A.withObject "Ordered" \v -> do
|
|
typ :: String <- v A..: "type"
|
|
guard (typ == "OrderedCollection")
|
|
orderedItems <- fromMaybe [] <$> v A..:? "orderedItems"
|
|
pure OrderedCollectionType {..}
|
|
|
|
data OrderedPage e
|
|
= OrderedCollectionPageType
|
|
{ partOf :: Url
|
|
, prev :: Maybe Url
|
|
, next :: Maybe Url
|
|
, porderedItems :: [e]
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance (A.ToJSON e) => ToObject (OrderedPage e) where
|
|
toObject page =
|
|
[ "type" A..= ("OrderedCollectionPage" :: String)
|
|
, "totalItems" A..= length page.porderedItems
|
|
, "orderedItems" A..= page.porderedItems
|
|
, "partOf" A..= page.partOf
|
|
, "prev" A..= page.prev
|
|
, "next" A..= page.next
|
|
]
|
|
|
|
instance (A.FromJSON e) => A.FromJSON (OrderedPage e) where
|
|
parseJSON = do
|
|
A.withObject "OrderedPage" \v -> do
|
|
typ :: String <- v A..: "type"
|
|
guard (typ == "OrderedCollectionPage")
|
|
partOf <- v A..: "partOf"
|
|
prev <- v A..:? "prev"
|
|
next <- v A..:? "next"
|
|
porderedItems <- fromMaybe [] <$> v A..:? "orderedItems"
|
|
pure OrderedCollectionPageType {..}
|