follows and inbox

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
+      Fedi.handleInbox (handleInbox db detailsFile)
-        handle activity = do
-          liftIO (print activity)
-          pure $ Fedi.jsonLD $ A.encode activity
 
-      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

fedi.cabal

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

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
+          }
+    }

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

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 =

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 =