add insert likes

2024-11-08 20:02:54 +02:00 · 2024-11-08 20:02:54 +02:00 · 22d1ce3764
commit 22d1ce3764
parent c684f52e55
9 changed files with 316 additions and 50 deletions
--- a/app/DB.hs
+++ b/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,
+        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
-      FROM note
-      WHERE inReplyTo IS NULL
      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
--- a/app/Main.hs
+++ b/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 <-
-    A.eitherDecodeFileStrict detailsFile
-      <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
+  details <- Fedi.readUserDetailsFile detailsFile

  db <- mkDB connStr details

--- a/app/Routes.hs
+++ b/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)
--- a/app/Routes/Inbox.hs
+++ b/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)
--- a/app/Routes/Inbox/Like.hs
+++ b/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
+
+-}
--- a/fedi.cabal
+++ b/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
--- a/src/Fedi/Crypto.hs
+++ b/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
+  )
--- a/src/Fedi/Types.hs
+++ b/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
-    ActivityAccept Accept
+  | ActivityLike Like
+  | 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.")
--- a/src/Fedi/Types/Helpers.hs
+++ b/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
+    }