-- 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,
        '[]' as likes

    |]
  ,
    [ 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