From 22d1ce376497b0b5fd94de5923079a7603791e21 Mon Sep 17 00:00:00 2001 From: me Date: Fri, 8 Nov 2024 20:02:54 +0200 Subject: [PATCH] add insert likes --- app/DB.hs | 155 ++++++++++++++++++++++++++++++++++++-- app/Main.hs | 5 +- app/Routes.hs | 36 +-------- app/Routes/Inbox.hs | 45 +++++++++++ app/Routes/Inbox/Like.hs | 72 ++++++++++++++++++ fedi.cabal | 6 ++ src/Fedi/Crypto.hs | 9 +++ src/Fedi/Types.hs | 18 +++-- src/Fedi/Types/Helpers.hs | 20 +++++ 9 files changed, 316 insertions(+), 50 deletions(-) create mode 100644 app/Routes/Inbox.hs create mode 100644 app/Routes/Inbox/Like.hs diff --git a/app/DB.hs b/app/DB.hs index 54ea78b..2c5f8f2 100644 --- 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 diff --git a/app/Main.hs b/app/Main.hs index 8c31b82..6a6a15e 100644 --- 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 diff --git a/app/Routes.hs b/app/Routes.hs index cce58cd..e43f8c5 100644 --- 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) diff --git a/app/Routes/Inbox.hs b/app/Routes/Inbox.hs new file mode 100644 index 0000000..18301fc --- /dev/null +++ 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) diff --git a/app/Routes/Inbox/Like.hs b/app/Routes/Inbox/Like.hs new file mode 100644 index 0000000..a23c8b7 --- /dev/null +++ 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 + +-} diff --git a/fedi.cabal b/fedi.cabal index eedea6c..0e45c19 100644 --- 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 diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index 87a98b2..fcbc341 100644 --- 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 + ) diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 2bac4c8..853f223 100644 --- 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.") diff --git a/src/Fedi/Types/Helpers.hs b/src/Fedi/Types/Helpers.hs index 45f6adf..aaabf4a 100644 --- 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 + }