fedi/app/DB.hs

-- 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 Control.Monad.IO.Class (liftIO)
import Data.Text qualified as T
import Data.Typeable
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 (DB.Int64, Note)
  , 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)

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

-- * 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)
      , 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"
  ]

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 :: DB.SQLite [Note]
getNotesFromDb =
  map (snd . decodeNoteRow) <$> uncurry DB.runWith getNotesSQL

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

insertNoteToDb :: Url -> NoteEntry -> DB.SQLite (DB.Int64, Note)
insertNoteToDb actor note = do
  [n] <- map decodeNoteRow <$> 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

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
        id,
        actor || '/notes/' || id,
        published,
        actor,
        content,
        name,
        inReplyTo,
        url
      FROM note
      WHERE inReplyTo IS NULL
      ORDER BY published DESC
    |]
  , []
  )

getNoteSQL :: DB.Int64 -> (DB.SQL, [DB.SQLData])
getNoteSQL noteid =
  ( [r|
      SELECT
        id as nid,
        actor || '/notes/' || id,
        published,
        actor,
        content,
        name,
        inReplyTo,
        url
      FROM note
      WHERE note.id = ?
      ORDER BY published DESC
    |]
  , [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
    ]
  )

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
    ] ->
      let
        emptyNote = emptyUserNote $ T.unpack actor
      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 =
                      emptyNote.otype.likes
                        { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
                        }
                  , 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)