diff --git a/app/Routes.hs b/app/Routes.hs
index 6084ab4..9b43bda 100644
--- a/app/Routes.hs
+++ b/app/Routes.hs
@@ -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
diff --git a/fedi.cabal b/fedi.cabal
index 9798bbd..96b7b47 100644
--- a/fedi.cabal
+++ b/fedi.cabal
@@ -77,6 +77,7 @@ executable fedi
, raw-strings-qq
, securemem
, lucid2
+ , req
hs-source-dirs: app
default-language: GHC2021
diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs
index 7c3fd66..643a7fe 100644
--- a/src/Fedi/Helpers.hs
+++ b/src/Fedi/Helpers.hs
@@ -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
+ }
+ }
diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs
index 8290807..caa315e 100644
--- a/src/Fedi/Routes.hs
+++ b/src/Fedi/Routes.hs
@@ -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
diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs
index 217bf01..f65ed18 100644
--- a/src/Fedi/Types.hs
+++ b/src/Fedi/Types.hs
@@ -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 =
diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs
index b62b7b4..9c74808 100644
--- a/src/Fedi/UserDetails.hs
+++ b/src/Fedi/UserDetails.hs
@@ -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 =