me/fedi
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add insert likes

Browse source
This commit is contained in:
me 2024-11-08 20:02:54 +02:00
parent c684f52e55
commit 22d1ce3764
9 changed files with 316 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

155
app/DB.hs
View file

@ -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

5
app/Main.hs
View file

@ -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

36
app/Routes.hs
View file

@ -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)

45
app/Routes/Inbox.hs Normal file
View file

@ -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)

72
app/Routes/Inbox/Like.hs Normal file
View file

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

6
fedi.cabal
View file

@ -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

9
src/Fedi/Crypto.hs
View file

@ -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
)

18
src/Fedi/Types.hs
View file

@ -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.")

20
src/Fedi/Types/Helpers.hs
View file

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