fedi/app/DB.hs

-- | Database interaction
module DB where

import Data.Text qualified as T
import Database.Sqlite.Easy qualified as DB
import Fedi
import GHC.Stack (HasCallStack)
import Text.RawString.QQ

-----------------------

-- * Database handler API

data DB
  = DB
  { getNotes :: IO [Note]
  , getNote :: DB.Int64 -> IO (Maybe Note)
  , insertNote :: NoteEntry -> IO ObjectId
  , insertFollower :: FollowerEntry -> IO DB.Int64
  }

-- * Data types

data NoteEntry
  = NoteEntry
  { inReplyTo :: Maybe Url
  , content :: T.Text
  , name :: Maybe String
  , url :: Maybe Url
  }

data FollowerEntry
  = FollowerEntry
  { followId :: T.Text
  , actorId :: T.Text
  }

-----------------------

-- * 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 $ actorUrl details)
      , getNote =
          \noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
      , insertNote =
          \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
      , insertFollower =
          \follower -> DB.withPool pool (insertFollowerToDb follower)
      }

-----------------------

-- * Database migrations

runMigrations :: (HasCallStack) => DB.SQLite ()
runMigrations = DB.migrate migrations migrateUp migrateDown

migrations :: [DB.MigrationName]
migrations =
  [ "note"
  , "follower"
  ]

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

  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 ()
  name -> error $ "unexpected migration: " <> show name

-----------------------

-- * Database actions

getNotesFromDb :: Url -> DB.SQLite [Note]
getNotesFromDb url =
  map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)

getNoteFromDb :: DB.Int64 -> Url -> DB.SQLite (Maybe Note)
getNoteFromDb noteid url = do
  n <- map decodeNoteRow <$> uncurry DB.runWith (getNoteSQL noteid url)
  pure (listToMaybe n)

insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ObjectId
insertNoteToDb actor note = do
  [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
  pure n

insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
insertFollowerToDb follower = do
  [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
  pure n

-- ** SQL

getNotesSQL :: Url -> (DB.SQL, [DB.SQLData])
getNotesSQL url =
  ( [r|
      SELECT
        ? || '/notes/' || id,
        published,
        actor,
        content,
        name,
        inReplyTo,
        url
      FROM note
      WHERE inReplyTo IS NULL
      ORDER BY published DESC
    |]
  , [DB.SQLText $ T.pack url]
  )

getNoteSQL :: DB.Int64 -> Url -> (DB.SQL, [DB.SQLData])
getNoteSQL noteid url =
  ( [r|
      SELECT
        ? || '/notes/' || id,
        published,
        actor,
        content,
        name,
        inReplyTo,
        url
      FROM note
      WHERE note.id = ?
      ORDER BY published DESC
    |]
  , [DB.SQLText $ T.pack url, DB.SQLInteger noteid]
  )

insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
insertNoteSQL actor note =
  ( [r|
      INSERT INTO note(actor, inReplyTo, content, name, url)
      VALUES (?, ?, ?, ?, ?)
      RETURNING cast(id as text)
    |]
  ,
    [ DB.SQLText (T.pack actor)
    , toNullableString note.inReplyTo
    , DB.SQLText note.content
    , toNullableString note.name
    , toNullableString note.url
    ]
  )

insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
insertFollowerSQL follower =
  ( [r|
      INSERT INTO note(follow_id, actor)
      VALUES (?, ?)
      RETURNING id
    |]
  ,
    [ DB.SQLText follower.followId
    , DB.SQLText follower.actorId
    ]
  )

-----------------------

-- ** Decode row

decodeNoteRow :: [DB.SQLData] -> Note
decodeNoteRow = \case
  [ DB.SQLText noteid
    , DB.SQLText published
    , DB.SQLText actor
    , DB.SQLText content
    , nullableString -> Just name
    , nullableString -> Just inReplyTo
    , nullableString -> Just url
    ] ->
      let
        emptyNote = emptyUserNote $ T.unpack actor
      in
        emptyNote
          { id = Just $ ObjectId $ T.unpack noteid
          , 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 =
                    emptyNote.otype.likes
                      { id = Just $ ObjectId $ T.unpack noteid <> "/likes"
                      }
                , shares =
                    emptyNote.otype.shares
                      { id = Just $ ObjectId $ T.unpack noteid <> "/shares"
                      }
                }
          }
  row -> error $ "Couldn't decode row as Note: " <> show row

decodeNoteIdRow :: [DB.SQLData] -> ObjectId
decodeNoteIdRow = \case
  [DB.SQLText noteid] -> ObjectId $ T.unpack noteid
  row -> error $ "Couldn't decode row as NoteId: " <> show row

decodeIntRow :: [DB.SQLData] -> DB.Int64
decodeIntRow = \case
  [DB.SQLInteger fid] -> fid
  row -> error $ "Couldn't decode row as NoteId: " <> 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)