529 lines
13 KiB
Haskell
529 lines
13 KiB
Haskell
-- needed because of a compiler bug with OverloadedRecordDot:
|
|
-- <https://play.haskell.org/saved/Xq0ZFrQi>
|
|
{-# LANGUAGE FieldSelectors #-}
|
|
|
|
-- | Database interaction
|
|
module DB (
|
|
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
|
|
|
|
-----------------------
|
|
|
|
-- * Database handler API
|
|
|
|
data DB
|
|
= DB
|
|
{ getNotes :: IO [Note]
|
|
, getNote :: DB.Int64 -> IO (Maybe Note)
|
|
, insertNote :: NoteEntry -> IO (DB.Int64, Note)
|
|
, insertLike :: LikeEntry -> IO DB.Int64
|
|
, deleteLike :: LikeEntry -> IO (Maybe DB.Int64)
|
|
-- , deleteLike :: LikeEntry -> IO (Maybe DB.Int64)
|
|
, insertFollower
|
|
:: forall a
|
|
. (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
|
|
-- ^ We use a callback so we can revert if the operation fails.
|
|
, deleteFollower
|
|
:: forall a
|
|
. (Typeable a) => FollowerEntry -> (Maybe DB.Int64 -> IO a) -> IO a
|
|
-- ^ We use a callback so we can revert if the operation fails.
|
|
, getFollowers :: IO [Follower]
|
|
}
|
|
|
|
-- * Data types
|
|
|
|
data NoteEntry
|
|
= NoteEntry
|
|
{ inReplyTo :: Maybe Url
|
|
, content :: T.Text
|
|
, name :: Maybe String
|
|
, url :: Maybe Url
|
|
}
|
|
deriving (Show)
|
|
|
|
data FollowerEntry
|
|
= FollowerEntry
|
|
{ followId :: T.Text
|
|
, actorId :: T.Text
|
|
}
|
|
deriving (Show)
|
|
|
|
data Follower
|
|
= Follower
|
|
{ myid :: T.Text
|
|
, followId :: T.Text
|
|
, actorId :: T.Text
|
|
}
|
|
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
|
|
|
|
mkDB :: DB.ConnectionString -> UserDetails -> IO DB
|
|
mkDB connstr details = do
|
|
pool <- DB.createSqlitePool connstr
|
|
DB.withPool pool runMigrations
|
|
pure
|
|
DB
|
|
{ getNotes =
|
|
DB.withPool pool getNotesFromDb
|
|
, getNote =
|
|
\noteid -> DB.withPool pool (getNoteFromDb noteid)
|
|
, insertNote =
|
|
\note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
|
|
, insertLike =
|
|
\like -> DB.withPool pool (insertLikeToDb like)
|
|
, deleteLike =
|
|
\like -> DB.withPool pool (deleteLikeToDb like)
|
|
, insertFollower =
|
|
\follower handle -> DB.withPool pool $ DB.transaction do
|
|
id' <- insertFollowerToDb follower
|
|
liftIO $ handle id'
|
|
, deleteFollower =
|
|
\follower handle -> DB.withPool pool $ DB.transaction do
|
|
id' <- deleteFollowerFromDb follower
|
|
liftIO $ handle id'
|
|
, getFollowers =
|
|
DB.withPool pool (getFollowersFromDb $ actorUrl details)
|
|
}
|
|
|
|
-----------------------
|
|
|
|
-- * Database migrations
|
|
|
|
runMigrations :: (HasCallStack) => DB.SQLite ()
|
|
runMigrations = DB.migrate migrations migrateUp migrateDown
|
|
|
|
migrations :: [DB.MigrationName]
|
|
migrations =
|
|
[ "note"
|
|
, "follower"
|
|
, "like"
|
|
]
|
|
|
|
migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
|
|
migrateUp = \case
|
|
"note" -> do
|
|
[] <-
|
|
DB.run
|
|
[r| create table note(
|
|
id integer primary key autoincrement,
|
|
published datetime default (datetime('now')),
|
|
actor text not null,
|
|
content text not null,
|
|
name text,
|
|
inReplyTo text,
|
|
url text
|
|
)
|
|
|]
|
|
pure ()
|
|
"follower" -> do
|
|
[] <-
|
|
DB.run
|
|
[r| create table follower(
|
|
id integer primary key autoincrement,
|
|
follow_id text not null unique,
|
|
actor text not null unique
|
|
)
|
|
|]
|
|
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 ()
|
|
migrateDown = \case
|
|
"note" -> do
|
|
[] <- DB.run "DROP TABLE note"
|
|
pure ()
|
|
"follower" -> do
|
|
[] <- DB.run "DROP TABLE follower"
|
|
pure ()
|
|
"like" -> do
|
|
[] <- DB.run "DROP TABLE like"
|
|
pure ()
|
|
name -> error $ "unexpected migration: " <> show name
|
|
|
|
-----------------------
|
|
|
|
-- * Database actions
|
|
|
|
getNotesFromDb :: DB.SQLite [Note]
|
|
getNotesFromDb = do
|
|
result <- uncurry DB.runWith getNotesSQL
|
|
pure $ map (snd . decodeNoteRow) result
|
|
|
|
getNoteFromDb :: DB.Int64 -> DB.SQLite (Maybe Note)
|
|
getNoteFromDb noteid = do
|
|
result <- uncurry DB.runWith (getNoteSQL noteid)
|
|
pure $ listToMaybe $ map (snd . decodeNoteRow) result
|
|
|
|
insertNoteToDb :: Url -> NoteEntry -> DB.SQLite (DB.Int64, Note)
|
|
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
|
|
|
|
deleteLikeToDb :: LikeEntry -> DB.SQLite (Maybe DB.Int64)
|
|
deleteLikeToDb like = do
|
|
ns <- map decodeIntRow <$> uncurry DB.runWith (deleteLikeSQL like)
|
|
pure $ listToMaybe ns
|
|
|
|
insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
|
|
insertFollowerToDb follower = do
|
|
[n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
|
|
pure n
|
|
|
|
deleteFollowerFromDb :: FollowerEntry -> DB.SQLite (Maybe DB.Int64)
|
|
deleteFollowerFromDb follower = do
|
|
ns <- map decodeIntRow <$> uncurry DB.runWith (deleteFollowerSQL follower)
|
|
pure $ listToMaybe ns
|
|
|
|
getFollowersFromDb :: Url -> DB.SQLite [Follower]
|
|
getFollowersFromDb url =
|
|
map decodeFollowerRow <$> uncurry DB.runWith (getFollowersSQL url)
|
|
|
|
-- ** SQL
|
|
|
|
getNotesSQL :: (DB.SQL, [DB.SQLData])
|
|
getNotesSQL =
|
|
( [r|
|
|
SELECT
|
|
note_id,
|
|
note_url_id,
|
|
published,
|
|
note_actor,
|
|
note_content,
|
|
note_name,
|
|
note_inReplyTo,
|
|
note_url,
|
|
|
|
json_group_array(
|
|
json_object(
|
|
'likeId',
|
|
like_id,
|
|
'likeUrl',
|
|
like_url,
|
|
'likeActorUrl',
|
|
like_actor_url,
|
|
'likeNoteUrl',
|
|
like_note_url
|
|
)
|
|
) FILTER (WHERE like_id IS NOT NULL) as likes
|
|
|
|
FROM
|
|
( SELECT
|
|
note.id as note_id,
|
|
note.url_id as note_url_id,
|
|
note.published as published,
|
|
note.actor as note_actor,
|
|
note.content as note_content,
|
|
note.name as note_name,
|
|
note.inReplyTo as note_inReplyTo,
|
|
note.url as note_url,
|
|
|
|
like.id as like_id,
|
|
like.like_url as like_url,
|
|
like.actor_url as like_actor_url,
|
|
like.note_url as like_note_url
|
|
|
|
FROM
|
|
( SELECT
|
|
*,
|
|
actor || '/notes/' || id as url_id
|
|
FROM note
|
|
WHERE inReplyTo IS NULL
|
|
) as note
|
|
LEFT JOIN like
|
|
ON note.url_id = like.note_url
|
|
)
|
|
GROUP BY note_id
|
|
ORDER BY published DESC
|
|
|]
|
|
, []
|
|
)
|
|
|
|
getNoteSQL :: DB.Int64 -> (DB.SQL, [DB.SQLData])
|
|
getNoteSQL noteid =
|
|
( [r|
|
|
SELECT
|
|
note_id,
|
|
note_url_id,
|
|
published,
|
|
note_actor,
|
|
note_content,
|
|
note_name,
|
|
note_inReplyTo,
|
|
note_url,
|
|
|
|
json_group_array(
|
|
json_object(
|
|
'likeId',
|
|
like_id,
|
|
'likeUrl',
|
|
like_url,
|
|
'likeActorUrl',
|
|
like_actor_url,
|
|
'likeNoteUrl',
|
|
like_note_url
|
|
)
|
|
) FILTER (WHERE like_id IS NOT NULL) as likes
|
|
FROM
|
|
( SELECT
|
|
note.id as note_id,
|
|
note.url_id as note_url_id,
|
|
note.published as published,
|
|
note.actor as note_actor,
|
|
note.content as note_content,
|
|
note.name as note_name,
|
|
note.inReplyTo as note_inReplyTo,
|
|
note.url as note_url,
|
|
|
|
like.id as like_id,
|
|
like.like_url as like_url,
|
|
like.actor_url as like_actor_url,
|
|
like.note_url as like_note_url
|
|
|
|
FROM
|
|
( SELECT
|
|
*,
|
|
actor || '/notes/' || id as url_id
|
|
FROM note WHERE id = ?
|
|
) as note
|
|
LEFT JOIN like
|
|
ON note.url_id = like.note_url
|
|
)
|
|
GROUP BY
|
|
note_id
|
|
|
|
|]
|
|
, [DB.SQLInteger noteid]
|
|
)
|
|
|
|
insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
|
|
insertNoteSQL actor note =
|
|
( [r|
|
|
INSERT INTO note(actor, inReplyTo, content, name, url)
|
|
VALUES (?, ?, ?, ?, ?)
|
|
RETURNING
|
|
id as nid,
|
|
actor || '/notes/' || id,
|
|
published,
|
|
actor,
|
|
content,
|
|
name,
|
|
inReplyTo,
|
|
url
|
|
|
|
|]
|
|
,
|
|
[ DB.SQLText (T.pack actor)
|
|
, toNullableString note.inReplyTo
|
|
, DB.SQLText note.content
|
|
, toNullableString note.name
|
|
, toNullableString note.url
|
|
]
|
|
)
|
|
|
|
insertLikeSQL :: LikeEntry -> (DB.SQL, [DB.SQLData])
|
|
insertLikeSQL like =
|
|
( [r|
|
|
INSERT INTO like(like_url, actor_url, note_url)
|
|
VALUES (?, ?, ?)
|
|
RETURNING
|
|
id as id
|
|
|]
|
|
, [ DB.SQLText (T.pack like.likeUrl)
|
|
, DB.SQLText (T.pack like.likeActorUrl.unwrap)
|
|
, DB.SQLText (T.pack like.likeNoteUrl.unwrap)
|
|
]
|
|
)
|
|
|
|
deleteLikeSQL :: LikeEntry -> (DB.SQL, [DB.SQLData])
|
|
deleteLikeSQL like =
|
|
( [r|
|
|
DELETE FROM like
|
|
WHERE like_url = ?
|
|
AND actor_url = ?
|
|
AND note_url = ?
|
|
RETURNING
|
|
id as id
|
|
|]
|
|
, [ 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|
|
|
INSERT INTO follower(follow_id, actor)
|
|
VALUES (?, ?)
|
|
RETURNING id
|
|
|]
|
|
,
|
|
[ DB.SQLText follower.followId
|
|
, DB.SQLText follower.actorId
|
|
]
|
|
)
|
|
|
|
deleteFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
|
|
deleteFollowerSQL follower =
|
|
( [r|
|
|
DELETE FROM follower
|
|
WHERE follow_id = ? AND actor = ?
|
|
RETURNING id
|
|
|]
|
|
,
|
|
[ DB.SQLText follower.followId
|
|
, DB.SQLText follower.actorId
|
|
]
|
|
)
|
|
|
|
getFollowersSQL :: Url -> (DB.SQL, [DB.SQLData])
|
|
getFollowersSQL url =
|
|
( [r|
|
|
SELECT
|
|
? || '/followers/' || id,
|
|
follow_id,
|
|
actor
|
|
FROM follower
|
|
|]
|
|
, [DB.SQLText $ T.pack url]
|
|
)
|
|
|
|
-----------------------
|
|
|
|
-- ** Decode row
|
|
|
|
decodeNoteRow :: [DB.SQLData] -> (DB.Int64, Note)
|
|
decodeNoteRow = \case
|
|
[ DB.SQLInteger noteid
|
|
, DB.SQLText noteidurl
|
|
, DB.SQLText published
|
|
, DB.SQLText actor
|
|
, DB.SQLText content
|
|
, 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
|
|
{ id = Just $ ObjectId $ T.unpack noteidurl
|
|
, published = Just $ read (T.unpack published)
|
|
, attributedTo = Just $ LLink $ Link $ T.unpack actor
|
|
, inReplyTo = LLink . Link <$> inReplyTo
|
|
, content = Just content
|
|
, url = url
|
|
, name = StringName <$> name
|
|
, otype =
|
|
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
|
|
{ id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
|
|
}
|
|
}
|
|
}
|
|
)
|
|
row -> error $ "Couldn't decode row as Note: " <> show row
|
|
|
|
decodeIntRow :: [DB.SQLData] -> DB.Int64
|
|
decodeIntRow = \case
|
|
[DB.SQLInteger fid] -> fid
|
|
row -> error $ "Couldn't decode row as id: " <> show row
|
|
|
|
decodeFollowerRow :: [DB.SQLData] -> Follower
|
|
decodeFollowerRow = \case
|
|
[ DB.SQLText myid
|
|
, DB.SQLText follower_id
|
|
, DB.SQLText actor
|
|
] ->
|
|
Follower
|
|
{ myid = myid
|
|
, followId = follower_id
|
|
, actorId = actor
|
|
}
|
|
row -> error $ "Couldn't decode row as Follower: " <> show row
|
|
|
|
nullableString :: DB.SQLData -> Maybe (Maybe String)
|
|
nullableString = \case
|
|
DB.SQLText text -> Just (Just $ T.unpack text)
|
|
DB.SQLNull -> Just Nothing
|
|
_ -> Nothing
|
|
|
|
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
|