add insert likes

app/DB.hs

@@ -8,13 +8,16 @@ module DB (
   DB.Int64,
 ) where
 
+import Data.Aeson qualified as A
 import Control.Monad.IO.Class (liftIO)
 import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
 import Data.Typeable
 import Database.Sqlite.Easy qualified as DB
 import Fedi
 import GHC.Stack (HasCallStack)
 import Text.RawString.QQ
+import Data.ByteString.Lazy qualified as BSL
 
 -----------------------
 
@@ -25,6 +28,7 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
+  , insertLike :: LikeEntry -> IO DB.Int64
   , insertFollower
       :: forall a
        . (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
@@ -62,6 +66,23 @@ data Follower
   }
   deriving (Show)
 
+data LikeEntry
+  = LikeEntry
+  { likeUrl :: Url
+  , likeActorUrl :: Link
+  , likeNoteUrl :: Link
+  }
+  deriving (Show)
+
+data DbLike
+  = DbLike
+  { likeId :: DB.Int64
+  , likeUrl :: ObjectId
+  , likeActorUrl :: Link
+  , likeNoteUrl :: Link
+  }
+  deriving (Show, Fedi.Generic, A.FromJSON)
+
 -----------------------
 
 -- * Handler smart constructor
@@ -78,6 +99,8 @@ mkDB connstr details = do
           \noteid -> DB.withPool pool (getNoteFromDb noteid)
       , insertNote =
           \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
+      , insertLike =
+          \like -> DB.withPool pool (insertLikeToDb like)
       , insertFollower =
           \follower handle -> DB.withPool pool $ DB.transaction do
             id' <- insertFollowerToDb follower
@@ -101,6 +124,7 @@ migrations :: [DB.MigrationName]
 migrations =
   [ "note"
   , "follower"
+  , "like"
   ]
 
 migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
@@ -129,6 +153,17 @@ migrateUp = \case
         )
       |]
     pure ()
+  "like" -> do
+    [] <-
+      DB.run
+        [r| create table like(
+          id integer primary key autoincrement,
+          like_url text not null unique,
+          actor_url text not null,
+          note_url text not null
+        )
+      |]
+    pure ()
   name -> error $ "unexpected migration: " <> show name
 
 migrateDown :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
@@ -139,6 +174,9 @@ migrateDown = \case
   "follower" -> do
     [] <- DB.run "DROP TABLE follower"
     pure ()
+  "like" -> do
+    [] <- DB.run "DROP TABLE like"
+    pure ()
   name -> error $ "unexpected migration: " <> show name
 
 -----------------------
@@ -159,6 +197,11 @@ insertNoteToDb actor note = do
   [n] <- map decodeNoteRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
 
+insertLikeToDb :: LikeEntry -> DB.SQLite DB.Int64
+insertLikeToDb like = do
+  [n] <- map decodeIntRow <$> uncurry DB.runWith (insertLikeSQL like)
+  pure n
+
 insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
 insertFollowerToDb follower = do
   [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
@@ -179,16 +222,48 @@ getNotesSQL :: (DB.SQL, [DB.SQLData])
 getNotesSQL =
   ( [r|
       SELECT
-        id,
+        id as nid,
         actor || '/notes/' || id,
         published,
         actor,
         content,
         name,
         inReplyTo,
-        url
+        url,
-      FROM note
+        json_group_array(like) FILTER (WHERE like IS NOT NULL) as likes
+      FROM
+      ( SELECT
+          note.*,
+          CASE
+            WHEN like.id IS NOT NULL
+            THEN json_object(
+                   'likeId',
+                   like.id,
+                   'likeUrl',
+                   like.like_url,
+                   'likeActorUrl',
+                   like.actor_url,
+                   'likeNoteUrl',
+                   like.note_url
+                 )
+            ELSE NULL
+            END AS like
+        FROM
+        ( SELECT * FROM note
           WHERE inReplyTo IS NULL
+        ) as note
+        LEFT JOIN like
+        ON note.url = like.note_url
+      )
+      GROUP BY
+        id,
+        actor,
+        published,
+        actor,
+        content,
+        name,
+        inReplyTo,
+        url
       ORDER BY published DESC
     |]
   , []
@@ -205,10 +280,38 @@ getNoteSQL noteid =
         content,
         name,
         inReplyTo,
+        url,
+        json_group_array(like) FILTER (WHERE like IS NOT NULL) as likes
+      FROM
+      ( SELECT
+          note.*,
+          CASE
+            WHEN like.id IS NOT NULL
+            THEN json_object(
+                   'likeId',
+                   like.id,
+                   'likeUrl',
+                   like.like_url,
+                   'likeActorUrl',
+                   like.actor_url,
+                   'likeNoteUrl',
+                   like.note_url
+                 )
+            ELSE NULL
+            END AS like
+        FROM (SELECT * FROM note WHERE id = ?) as note
+        LEFT JOIN like
+        ON note.url = like.note_url
+      )
+      GROUP BY
+        id,
+        actor,
+        published,
+        actor,
+        content,
+        name,
+        inReplyTo,
         url
-      FROM note
-      WHERE note.id = ?
-      ORDER BY published DESC
     |]
   , [DB.SQLInteger noteid]
   )
@@ -238,6 +341,23 @@ insertNoteSQL actor note =
     ]
   )
 
+insertLikeSQL :: LikeEntry -> (DB.SQL, [DB.SQLData])
+insertLikeSQL like =
+  ( [r|
+      INSERT INTO outer_like(like_url, actor_url, note_url)
+      VALUES (?, ?, ?)
+      RETURNING
+        id as id,
+        like_url,
+        actor_url,
+        note_url
+    |]
+  , [ DB.SQLText (T.pack like.likeUrl)
+    , DB.SQLText (T.pack like.likeActorUrl.unwrap)
+    , DB.SQLText (T.pack like.likeNoteUrl.unwrap)
+    ]
+  )
+
 insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
 insertFollowerSQL follower =
   ( [r|
@@ -290,9 +410,14 @@ decodeNoteRow = \case
     , nullableString -> Just name
     , nullableString -> Just inReplyTo
     , nullableString -> Just url
+    , fromJson -> Just (dblikes :: [DbLike])
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
+        likes =
+          map
+            (\like -> aLike like.likeUrl like.likeActorUrl like.likeNoteUrl)
+            dblikes
       in
         ( noteid
         , emptyNote
@@ -306,8 +431,18 @@ decodeNoteRow = \case
             , otype =
                 emptyNote.otype
                   { likes =
-                      emptyNote.otype.likes
+                      emptyUnorderedCollection
                         { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
+                        , otype =
+                          CollectionType
+                            { ctype =
+                                UnorderedCollectionType
+                                  { items = likes
+                                  }
+                            , first = Nothing
+                            , last = Nothing
+                            , current = Nothing
+                            }
                         }
                   , shares =
                       emptyNote.otype.shares
@@ -346,3 +481,9 @@ toNullableString :: Maybe String -> DB.SQLData
 toNullableString = \case
   Nothing -> DB.SQLNull
   Just str -> DB.SQLText (T.pack str)
+
+fromJson :: A.FromJSON a => DB.SQLData -> Maybe [a]
+fromJson = \case
+  DB.SQLNull -> Just []
+  DB.SQLText str -> A.decode (BSL.fromStrict $ T.encodeUtf8 str)
+  _ -> Nothing

app/Main.hs

@@ -15,6 +15,7 @@ import Network.Wai.Middleware.RequestLogger qualified as Logger
 import Network.Wai.Middleware.RequestSizeLimit qualified as Limit
 import Network.Wai.Middleware.Routed qualified as Wai
 import Routes
+import Fedi qualified as Fedi
 import System.Environment (getArgs, lookupEnv)
 import Web.Twain qualified as Twain
 
@@ -135,9 +136,7 @@ mkFediApp connStr = do
     lookupEnv "FEDI_DETAILS"
       <&> maybe (error "missing FEDI_DETAILS") id
 
-  details <-
+  details <- Fedi.readUserDetailsFile detailsFile
-    A.eitherDecodeFileStrict detailsFile
-      <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
   db <- mkDB connStr details
 

app/Routes.hs

@@ -1,6 +1,5 @@
 module Routes where
 
-import Control.Concurrent.Async qualified as Async
 import Control.Logger.Simple qualified as Log
 import DB
 import Data.Aeson qualified as A
@@ -10,7 +9,7 @@ import Data.Text qualified as T
 import Fedi qualified as Fedi
 import Html
 import Lucid qualified as H
-import Routes.Inbox.Follow
+import Routes.Inbox
 import System.IO.Unsafe (unsafePerformIO)
 import Web.Twain qualified as Twain
 
@@ -125,36 +124,3 @@ 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
-  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
-  case activity of
-    Fedi.ActivityFollow follow ->
-      handleInboxFollow details db activity follow
-    Fedi.ActivityUndo
-      ( Fedi.Object
-          { otype =
-            Fedi.TypeActivity
-              { atype =
-                Fedi.TypeUndo
-                  { object = Fedi.ActivityFollow follow
-                  }
-              }
-          }
-        ) ->
-        handleInboxUnfollow details db activity follow
-    _ -> do
-      Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
-      Twain.next
-
-sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
-sendFollowers details db message = do
-  Log.logDebug $ "Sending to followers: " <> Fedi.pJson message
-  followers <- db.getFollowers
-  Fedi.for_ followers \follower -> do
-    Async.async $ do
-      Log.logDebug $ "Sending to follower: " <> Fedi.pShow follower.actorId
-      bs <- Fedi.sendPost details (T.unpack follower.actorId <> "/inbox") message
-      Log.logDebug $ "Sent to follower: " <> Fedi.pShow (follower.actorId, bs)

app/Routes/Inbox.hs

@@ -0,0 +1,45 @@
+module Routes.Inbox where
+
+import Control.Concurrent.Async qualified as Async
+import Control.Logger.Simple qualified as Log
+import DB
+import Data.Text qualified as T
+import Fedi qualified as Fedi
+import Routes.Inbox.Follow
+import Routes.Inbox.Like
+import Web.Twain qualified as Twain
+
+handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
+handleInbox db detailsFile activity = do
+  details <- liftIO $ Fedi.readUserDetailsFile detailsFile
+  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
+  case activity of
+    Fedi.ActivityFollow follow ->
+      handleInboxFollow details db activity follow
+    Fedi.ActivityLike like ->
+      handleInboxLike db like
+    Fedi.ActivityUndo
+      ( Fedi.Object
+          { otype =
+            Fedi.TypeActivity
+              { atype =
+                Fedi.TypeUndo
+                  { object = Fedi.ActivityFollow follow
+                  }
+              }
+          }
+        ) ->
+        handleInboxUnfollow details db activity follow
+    _ -> do
+      Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
+      Twain.next
+
+sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
+sendFollowers details db message = do
+  Log.logDebug $ "Sending to followers: " <> Fedi.pJson message
+  followers <- db.getFollowers
+  Fedi.for_ followers \follower -> do
+    Async.async $ do
+      Log.logDebug $ "Sending to follower: " <> Fedi.pShow follower.actorId
+      bs <- Fedi.sendPost details (T.unpack follower.actorId <> "/inbox") message
+      Log.logDebug $ "Sent to follower: " <> Fedi.pShow (follower.actorId, bs)

app/Routes/Inbox/Like.hs

@@ -0,0 +1,72 @@
+module Routes.Inbox.Like where
+
+import Control.Logger.Simple qualified as Log
+import DB
+import Fedi qualified as Fedi
+import Web.Twain qualified as Twain
+
+handleInboxLike
+  :: DB
+  -> Fedi.Like
+  -> Twain.ResponderM Twain.Response
+handleInboxLike db like = do
+  let
+    id' = like.id
+    actor = like.otype.actor
+    note = like.otype.atype.object
+  case id' of
+    Just id'' -> do
+      let
+        likeEntry =
+          ( LikeEntry
+              { likeUrl = fromString id''.unwrap
+              , likeActorUrl = actor
+              , likeNoteUrl = note
+              }
+          )
+        operation = do
+          likeid <- db.insertLike likeEntry
+          Log.logInfo ("New like: " <> Fedi.pShow (likeid, likeEntry))
+      liftIO operation
+      pure $ Twain.text ""
+    Nothing ->
+      Twain.next
+
+  {-
+handleInboxUnlike
+  :: DB
+  -> Fedi.Like
+  -> Twain.ResponderM Twain.Response
+handleInboxUnlike db like = do
+  let
+    id' = like.id
+    actor = like.otype.actor
+    note = like.otype.atype.object
+  case id' of
+    Just id'' -> do
+          let
+            followerEntry =
+              ( LikeEntry
+                  { likeUrl = fromString id''.unwrap
+                  , likeActorUrl = actor
+                  , likeNoteUrl = note
+                  }
+              )
+            operation sendAccept = do
+              deleteFollower
+                db
+                LikeEntry
+                ( \deletedId' -> do
+                    let
+                      deletedId = Fedi.fromMaybe 0 deletedId'
+                    sendAccept deletedId
+                      <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
+                )
+
+          liftIO $ acceptRequest details actor activity operation
+
+          pure $ Twain.text ""
+    Nothing ->
+      Twain.next
+
+-}

fedi.cabal

@@ -91,6 +91,8 @@ executable fediserve
     Html
     Css
     Routes
+    Routes.Inbox
+    Routes.Inbox.Like
     Routes.Inbox.Follow
     Routes.Inbox.Accept
   -- other-extensions:
@@ -102,6 +104,7 @@ executable fediserve
     , wai-extra
     , warp
     , twain
+    , bytestring
     , text
     , sqlite-easy
     , raw-strings-qq
@@ -121,6 +124,9 @@ executable fediserve
     ViewPatterns
     DuplicateRecordFields
     NoFieldSelectors
+    GeneralizedNewtypeDeriving
+    DeriveAnyClass
+    DerivingStrategies
   ghc-options: -Wall -O -threaded -rtsopts -with-rtsopts=-N
 
 test-suite fedi-test

src/Fedi/Crypto.hs

@@ -76,3 +76,12 @@ decodeBase64 = Base64.decodeBase64Lenient
 makeDigest :: ByteString -> ByteString
 makeDigest message =
   BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)
+
+sha1short :: Show a => a -> String
+sha1short =
+  ( take 10
+  . show
+  . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1)
+  . fromString
+  . show
+  )

src/Fedi/Types.hs

@@ -350,27 +350,33 @@ instance A.FromJSON TypeUndo where
 --
 type Like = Object (TypeActivity TypeLike)
 
-data TypeLike = TypeLike deriving (Show, Eq)
+data TypeLike
+  = TypeLike
+  { object :: Link
+  }
+  deriving (Show, Eq)
 
 instance ToObject TypeLike where
-  toObject TypeLike =
+  toObject like =
     [ "type" A..= ("Like" :: String)
+    , "object" A..= like.object
     ]
 
 instance A.FromJSON TypeLike where
   parseJSON =
     A.withObject "TypeLike" \value -> do
       typ :: String <- value A..: "type"
+      object <- value A..: "object"
       guard (typ == "Like")
-      pure TypeLike
+      pure TypeLike{..}
 
 data AnyActivity
   = -- ActivityAnnounce Announce
     ActivityCreate Create
   | ActivityUndo Undo
   | ActivityFollow Follow
-  | --  | ActivityLike Like
+  | ActivityLike Like
-    ActivityAccept Accept
+  | ActivityAccept Accept
   | ActivityReject Reject
   deriving (Show, Eq)
 
@@ -380,6 +386,7 @@ instance A.ToJSON AnyActivity where
     ActivityCreate obj -> A.toJSON obj
     ActivityUndo obj -> A.toJSON obj
     ActivityFollow obj -> A.toJSON obj
+    ActivityLike obj -> A.toJSON obj
     --    ActivityLike obj -> A.toJSON obj
     ActivityAccept obj -> A.toJSON obj
     ActivityReject obj -> A.toJSON obj
@@ -392,6 +399,7 @@ instance A.FromJSON AnyActivity where
         "Create" -> ActivityCreate <$> A.parseJSON value
         "Undo" -> ActivityUndo <$> A.parseJSON value
         "Follow" -> ActivityFollow <$> A.parseJSON value
+        "Like" -> ActivityLike <$> A.parseJSON value
         "Accept" -> ActivityAccept <$> A.parseJSON value
         "Reject" -> ActivityReject <$> A.parseJSON value
         _ -> fail ("Parsing '" <> typ <> "' not yet implemented.")

src/Fedi/Types/Helpers.hs

@@ -174,3 +174,23 @@ makeAccept accept =
           , origin = Nothing
           }
     }
+
+-- | Create a 'Like'.
+aLike :: ObjectId -> Link -> Link -> Like
+aLike id' actor object =
+  emptyObject
+    { id = Just id'
+    , otype = typeActivityLike actor object
+    }
+
+-- | A 'TypeLike'.
+typeActivityLike :: Link -> Link -> TypeActivity TypeLike
+typeActivityLike actor object =
+  TypeActivity
+    { actor = actor
+    , atype = TypeLike
+      { object = object
+      }
+    , target = Nothing
+    , origin = Nothing
+    }