-- needed because of a compiler bug with OverloadedRecordDot: -- {-# 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) , 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) , 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 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) ] ) 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