me/fedi
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

follows and inbox

Browse Source
This commit is contained in:
me 2024-11-03 13:54:15 +02:00
parent 9b3da936cf
commit 1fde45736d
6 changed files with 147 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
app/Routes.hs
View File

@ -11,6 +11,16 @@ import Html
import Lucid qualified as H
import System.IO.Unsafe (unsafePerformIO)
import Web.Twain qualified as Twain
import Network.HTTP.Req
( runReq
, defaultHttpConfig
, req
, POST(POST)
, ReqBodyJson(ReqBodyJson)
, jsonResponse
, responseBody
, https
)
routes :: DB -> FilePath -> [Twain.Middleware]
routes db detailsFile =
@ -43,12 +53,8 @@ routes db detailsFile =
Fedi.handleCreateNote details notes
, -- Match inbox
Twain.get (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
let
handle activity = do
liftIO (print activity)
pure $ Fedi.jsonLD $ A.encode activity
Fedi.handleInbox (handleInbox db detailsFile)
Fedi.handleInbox handle
, -- Match Create object
Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile
@ -70,10 +76,20 @@ routes db detailsFile =
Nothing -> Twain.next
Just thenote ->
Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
, -- Followers
Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile
Fedi.handleFollowers details
, -- Following
Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do
details <- liftIO $ fetchUserDetails detailsFile
Fedi.handleFollowing details
, -- Match webfinger
Twain.get Fedi.matchWebfinger do
details <- liftIO $ fetchUserDetails detailsFile
Fedi.handleWebfinger details
--------------------------------------------------------------------------------------------
, -- Admin page
Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
details <- liftIO $ fetchUserDetails detailsFile
@ -109,3 +125,48 @@ fetchUserDetails detailsFile =
noteToCreate :: Fedi.Note -> Fedi.Create
noteToCreate note = Fedi.makeCreateNote note
handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
handleInbox db detailsFile activity = do
details <- liftIO $ fetchUserDetails detailsFile
case activity of
Fedi.ActivityFollow follow -> do
let
id' = follow.id
actor = follow.otype.actor
object = follow.otype.atype.object
case id' of
Just id'' -> do
if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
then do
liftIO do
insertId <- db.insertFollower FollowerEntry
{ actorId = fromString actor.unwrap
, followId = fromString id''.unwrap
}
(result :: A.Value) <- sendRequest
(id''.unwrap <> "/inbox")
( Fedi.makeAccept
follow
(Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
)
print result
pure $ Fedi.jsonLD "{}"
else Twain.next
Nothing ->
Twain.next
_ -> do
liftIO (print activity)
Twain.next
sendRequest :: (A.ToJSON input, A.FromJSON output) => Fedi.Url -> input -> IO output
sendRequest url payload = do
runReq defaultHttpConfig do
r <-
req
POST
(https $ fromString url)
(ReqBodyJson payload)
jsonResponse
mempty
pure $ responseBody r

1
fedi.cabal
View File

@ -77,6 +77,7 @@ executable fedi
, raw-strings-qq
, securemem
, lucid2
, req
hs-source-dirs: app
default-language: GHC2021

15
src/Fedi/Helpers.hs
View File

@ -151,3 +151,18 @@ emptyOrderedCollectionPage url =
, current = Nothing
}
}
makeAccept :: Follow -> Url -> Accept
makeAccept theirFollow myfollowId =
emptyObject
{ id = Just $ ObjectId myfollowId
, otype =
TypeActivity
{ actor = theirFollow.otype.actor
, atype = TypeAccept
{ object = ActivityFollow theirFollow
}
, target = Nothing
, origin = Nothing
}
}

34
src/Fedi/Routes.hs
View File

@ -175,6 +175,40 @@ handleInbox handle = do
response <- handle activity
Twain.send response
-- * Followers
matchFollowers :: UserDetails -> Twain.PathPattern
matchFollowers details =
fromString ("/" <> details.username <> "/followers")
handleFollowers :: UserDetails -> Twain.ResponderM b
handleFollowers details = do
let
collection :: Collection ()
collection =
emptyUnorderedCollection
{ id = Just $ ObjectId $ actorUrl details <> "/followers"
, summary = Just $ fromString $ details.username <> "'s followers"
}
Twain.send $ jsonLD (A.encode collection)
-- * Following
matchFollowing :: UserDetails -> Twain.PathPattern
matchFollowing details =
fromString ("/" <> details.username <> "/following")
handleFollowing :: UserDetails -> Twain.ResponderM b
handleFollowing details = do
let
collection :: Collection ()
collection =
emptyUnorderedCollection
{ id = Just $ ObjectId $ actorUrl details <> "/following"
, summary = Just $ fromString $ details.username <> " is following"
}
Twain.send $ jsonLD (A.encode collection)
-- * Other stuff
checkContentTypeAccept :: Twain.Request -> Bool

56
src/Fedi/Types.hs
View File

@ -37,7 +37,7 @@ data Object typ
mediaType :: Maybe MediaType
-- , duration :: Maybe String
}
deriving (Show)
deriving (Show, Eq)
class ToObject a where
toObject :: a -> [A.Pair]
@ -101,13 +101,13 @@ newtype ObjectId = ObjectId {unwrap :: String}
deriving (Show, Eq, A.FromJSON, A.ToJSON) via String
newtype Link = Link {unwrap :: Url}
deriving (Show, A.FromJSON, A.ToJSON) via Url
deriving (Show, Eq, A.FromJSON, A.ToJSON) via Url
data LinkOrObject a
= LLink Link
| OObject (Object a)
| CCollection [LinkOrObject a]
deriving (Show)
deriving (Show, Eq)
instance (A.FromJSON a) => A.FromJSON (LinkOrObject a) where
parseJSON = \case
@ -130,7 +130,7 @@ instance (ToObject o) => A.ToJSON (LinkOrObject o) where
data AnyMedia
= ImageMedia Image
deriving (Show)
deriving (Show, Eq)
instance A.ToJSON AnyMedia where
toJSON = \case
@ -142,7 +142,7 @@ instance A.FromJSON AnyMedia where
type Image = Object TypeImage
data TypeImage = TypeImage deriving (Show)
data TypeImage = TypeImage deriving (Show, Eq)
instance ToObject TypeImage where
toObject TypeImage =
@ -158,7 +158,7 @@ instance A.FromJSON TypeImage where
data Name
= StringName String
| ObjectName (LinkOrObject Actor)
deriving (Show)
deriving (Show, Eq)
instance A.ToJSON Name where
toJSON = \case
@ -184,7 +184,7 @@ data TypeNote
, replies :: Collection Note
, sensitive :: Bool
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypeNote where
toObject note =
@ -209,16 +209,16 @@ data TypeTag
= TypeTag
{ href :: Url
}
deriving (Show)
deriving (Show, Eq)
type Preview = Object TypePreview
data TypePreview = TypePreview
deriving (Show)
deriving (Show, Eq)
type Share = Object TypeShare
data TypeShare = TypeShare deriving (Show)
data TypeShare = TypeShare deriving (Show, Eq)
instance ToObject TypeShare where
toObject TypeShare =
@ -230,7 +230,7 @@ instance A.FromJSON TypeShare where
A.withObject "TypeShare" \value -> do
typ :: String <- value A..: "type"
guard (typ == "Share")
pure TypeShare {..}
pure TypeShare
-- * Activities
@ -248,7 +248,7 @@ data TypeActivity t
-- , result :: Maybe String
-- , instrument :: Maybe String
}
deriving (Show)
deriving (Show, Eq)
instance (ToObject t) => ToObject (TypeActivity t) where
toObject activity =
@ -284,7 +284,7 @@ data TypeCreate
= TypeCreate
{ object :: Note
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypeCreate where
toObject create =
@ -304,9 +304,9 @@ type Follow = Object (TypeActivity TypeFollow)
data TypeFollow
= TypeFollow
{ object :: Actor
{ object :: LinkOrObject Actor
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypeFollow where
toObject follow =
@ -325,7 +325,7 @@ instance A.FromJSON TypeFollow where
--
type Like = Object (TypeActivity TypeLike)
data TypeLike = TypeLike deriving (Show)
data TypeLike = TypeLike deriving (Show, Eq)
instance ToObject TypeLike where
toObject TypeLike =
@ -337,7 +337,7 @@ instance A.FromJSON TypeLike where
A.withObject "TypeLike" \value -> do
typ :: String <- value A..: "type"
guard (typ == "Like")
pure TypeLike {..}
pure TypeLike
data AnyActivity
= -- ActivityAnnounce Announce
@ -346,7 +346,7 @@ data AnyActivity
| -- | ActivityLike Like
ActivityAccept Accept
| ActivityReject Reject
deriving (Show)
deriving (Show, Eq)
instance A.ToJSON AnyActivity where
toJSON = \case
@ -376,7 +376,7 @@ data TypeAccept
= TypeAccept
{ object :: AnyActivity
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypeAccept where
toObject obj =
@ -398,7 +398,7 @@ data TypeReject
= TypeReject
{ object :: AnyActivity
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypeReject where
toObject obj =
@ -418,7 +418,9 @@ instance A.FromJSON TypeReject where
-- | 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)
data Actor
= ActorPerson Person
deriving (Show, Eq)
instance A.FromJSON Actor where
parseJSON =
@ -457,7 +459,7 @@ data TypePerson
, following :: Link
, followers :: Link
}
deriving (Show)
deriving (Show, Eq)
instance ToObject TypePerson where
toObject person =
@ -476,7 +478,7 @@ data PublicKey
, owner :: Url
, publicKeyPem :: Pem
}
deriving (Show)
deriving (Show, Eq)
instance A.ToJSON PublicKey where
toJSON pk =
@ -513,7 +515,7 @@ data CollectionType t
, last :: Maybe Url
, current :: Maybe Url
}
deriving (Show)
deriving (Show, Eq)
instance (ToObject t) => ToObject (CollectionType t) where
toObject collection =
@ -539,7 +541,7 @@ data Unordered e
= UnorderedCollectionType
{ items :: [e]
}
deriving (Show)
deriving (Show, Eq)
instance (A.ToJSON e) => ToObject (Unordered e) where
toObject collection =
@ -560,7 +562,7 @@ data Ordered e
= OrderedCollectionType
{ orderedItems :: [e]
}
deriving (Show)
deriving (Show, Eq)
instance (A.ToJSON e) => ToObject (Ordered e) where
toObject collection =
@ -584,7 +586,7 @@ data OrderedPage e
, next :: Maybe Url
, porderedItems :: [e]
}
deriving (Show)
deriving (Show, Eq)
instance (A.ToJSON e) => ToObject (OrderedPage e) where
toObject page =

4
src/Fedi/UserDetails.hs
View File

@ -20,7 +20,7 @@ type Domain = String
type Username = String
newtype Pem = Pem T.Text
deriving (Show)
deriving (Show, Eq)
deriving (A.FromJSON) via T.Text
instance A.ToJSON Pem where
@ -37,7 +37,7 @@ data UserDetails
, publicPem :: Pem
, privatePem :: FilePath
}
deriving (Show, Generic, A.FromJSON)
deriving (Show, Eq, Generic, A.FromJSON)
actorUrl :: UserDetails -> Url
actorUrl details =