{-# OPTIONS_GHC -Wno-orphans        #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE ApplicativeDo          #-}
{-# LANGUAGE DuplicateRecordFields  #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE TemplateHaskell        #-}

-- | Querying and manipulating the database.
module Puppy.Database (
  connect,
  Connection,
  -- * Effect
  DB,
  runDB,
  -- * Utils
  transaction,
  -- * Queries
  getActorById,
  getChannelByActorId,
  getActivityById,
  getObjectById,
  getUserByName,
  -- * Actions
  insertNewUser,
  insertNewChannel,
  insertNewActor,
  insertNewActivity,
  insertFollowRequest,
  acceptFollowRequest,
  cancelFollowRequest,
  storeActivity,
) where

import Control.Monad ((>=>))
import Database.SQLite.Simple (Connection, query, Only (..), execute, ToRow (..), withTransaction, open)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.FromRow
import Database.SQLite.Simple.ToField (ToField (..))
import Data.Functor ((<&>), ($>))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Time
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail)
import Effectful.TH (makeEffect)
import Prelude hiding (id)
import Puppy.Protocol.ActivityStreams
import Puppy.Types
import qualified Data.Aeson as JSON
import qualified Data.UUID as UUID
import qualified Puppy.Crypto.RSA as RSA

data DB :: Effect where
  GetActorById        :: Id -> DB m (Maybe Actor)
  GetChannelByActorId :: Id -> DB m (Maybe Channel)
  GetUserByName       :: Text -> DB m (Maybe User)
  GetActivityById     :: Id -> DB m (Maybe (Activity Id))
  InsertNewUser       :: User -> DB m ()
  InsertNewChannel    :: Channel -> DB m ()
  InsertNewActor      :: Actor -> DB m ()
  InsertNewActivity   :: Activity Id -> DB m ()
  InsertNewDocument   :: Document -> DB m ()
  Transaction         :: m a -> DB m a
  InsertFollowRequest :: (Id, Id) -> DB m ()
  AcceptFollowRequest :: (Id, Id) -> DB m ()
  CancelFollowRequest :: (Id, Id) -> DB m ()

makeEffect ''DB

getObjectById :: DB :> es => Id -> Eff es (Maybe Object)
getObjectById objId = getActivityById objId >>= \case
  -- TODO: Add branch for Document
  Just activity -> getObjectById activity.object <&> fmap
    (\(obj :: Object) -> toObject (activity $> obj))
  Nothing -> getActorById objId <&> fmap toObject

-- | Store the object, and then store the activity itself.
storeActivity :: (DB :> es) => Activity Object -> Eff es ()
storeActivity a =
  storeObject a.object >> insertNewActivity (a <&> (.id))
  where 
    storeObject obj
      | Just o <- fromObject obj = insertNewActor o
      | Just o <- fromObject obj = insertNewDocument o
      | Just o <- fromObject obj = storeActivity o
      | otherwise = error "impossible!"

connect :: (IOE :> es) => Eff es Connection
connect = liftIO $ open ".state/db.sqlite"

runDB
  :: (IOE :> es, Fail :> es)
  => Connection
  -> Eff (DB : es) a
  -> Eff es a
runDB conn = interpret $ \env a -> do
  localSeqUnliftIO env $ \unlift -> case a of
    GetActorById actorId -> just <$> query conn
      "select id, inbox, outbox, followers, following, accountName, displayName, bio, keyId, publicKeyPem, locked, type from actors where id = ?"
      (Only actorId)
    GetChannelByActorId actorId -> just <$> query conn
      "select id, linkedActorId, privateKeyPem from channels where linkedActorId = ?"
      (Only actorId)
    GetUserByName userName -> just <$> query conn
      "select id, userName from users where userName = ?"
      (Only userName)
    GetActivityById activityId -> just <$> query conn
      "select id, actor, object, audienceTo, audienceCc, time, type from activities where id = ?"
      (Only activityId)
    InsertNewUser (User { userId, userName, mainChannel }) -> execute conn
      "insert into users (id, userName, mainChannel) values (?, ?, ?)"
      (userId, userName, mainChannel)
    InsertNewChannel (Channel { channelId, linkedActorId, privateKeyPem }) -> execute conn
      "insert into channels (id, linkedActorId, privateKeyPem) values (?, ?, ?)"
      (channelId, linkedActorId, RSA.encodePrivateKey privateKeyPem)
    InsertNewActor actor -> execute conn
      "insert into actors (id, inbox, outbox, followers, following, accountName, displayName, bio, keyId, publicKeyPem, locked, type) values (?,?,?,?,?,?,?,?,?,?,?,?) on conflict do nothing"
      actor
    InsertNewDocument _ -> pure () -- TODO
    InsertNewActivity activity -> execute conn
      "insert into activities (id, actor, object, audienceTo, audienceCc, time, type) values (?, ?, ?, ?, ?, ?, ?) on conflict do nothing"
      activity
    Transaction actions -> withTransaction conn (unlift actions)
    InsertFollowRequest (follower, followee) -> execute conn
      "insert into follows (follower, followee) values (?, ?)"
      (follower, followee)
    AcceptFollowRequest (follower, followee) -> do -- NOTE: Applicative do
      record <- just <$> query conn 
        "select acceptTime, rejectTime, follower, followee from follows where follower = ? and followee = ?"
        (follower, followee)
      now <- getCurrentTime
      case record of
        Just (rec :: FollowRecord) -> execute conn
          "update follows set acceptTime = ? where follower = ? and followee = ?"
          (now, rec.follower, rec.followee)
        Nothing -> execute conn
          "insert into follows (follower, followee, acceptTime) values (?, ?, ?)"
          (follower, followee, now)
    CancelFollowRequest inputs -> execute conn
      "delete from follows where follower = ? and followee = ?"
      inputs
  where
    just [a] = Just a
    just _   = Nothing

instance FromRow Actor where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !id           <- field
    !inbox        <- field
    !outbox       <- field
    !followers    <- field
    !following    <- field
    !accountName  <- field
    !displayName  <- field
    !summary      <- field
    !publicKeyId  <- field
    !publicKeyPem <- field <&> fromJust . RSA.decodePublicKey
    !locked       <- field
    !subtype      <- field
    pure (Actor {
      publicKey = PublicKey {
        id = publicKeyId,
        owner = id,
        publicKeyPem
      },
      ..
    })

instance ToRow Actor where
  toRow a = [
      toField a.id,
      toField a.inbox,
      toField a.outbox,
      toField a.followers,
      toField a.following,
      toField a.accountName,
      toField a.displayName,
      toField a.summary,
      toField a.publicKey.id,
      toField (RSA.encodePublicKey a.publicKey.publicKeyPem),
      toField a.locked,
      toField a.subtype
    ]

instance FromRow Channel where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !channelId     <- field
    !linkedActorId <- field
    !privateKeyPem <- field <&> fromJust . RSA.decodePrivateKey
    let settings = ChannelSettings { autoAcceptFollows = True }
    pure (Channel { .. })

instance FromRow User where
  -- NOTE: Order of `field`s matters here
  fromRow = User <$> field
                 <*> field
                 <*> field

instance FromRow (Activity Id) where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !id      <- field
    !actor   <- field
    !object  <- field
    !to      <- field <&> fromJust . JSON.decode
    !cc      <- field <&> fromJust . JSON.decode
    !time    <- field
    !subtype <- field
    pure (Activity { .. })

instance ToRow (Activity Id) where
  toRow a = [
      toField a.id,
      toField a.actor,
      toField a.object,
      toField (JSON.encode a.to),
      toField (JSON.encode a.cc),
      toField a.time,
      toField a.subtype
    ]

data FollowRecord
  = FollowRecord {
    acceptTime :: Maybe UTCTime,
    rejectTime :: Maybe UTCTime,
    follower   :: Id,
    followee   :: Id
  }

instance FromRow FollowRecord where
  fromRow = do -- NOTE: Applicative do
    -- NOTE: Order of `field`s matters here
    !acceptTime <- field
    !rejectTime <- field
    !follower   <- field
    !followee   <- field
    pure (FollowRecord { .. })

instance ToRow FollowRecord where
  toRow a = [
      toField a.acceptTime,
      toField a.rejectTime,
      toField a.follower,
      toField a.followee
    ]

instance FromField Id where
  fromField = fmap Id . fromField

instance ToField Id where
  toField = toField . (.url)

instance FromField Inbox where
  fromField = fmap Inbox . fromField

instance ToField Inbox where
  toField = toField . (.url)

instance FromField UUID.UUID where
  fromField = fmap (fromJust . UUID.fromByteString)
            . fromField

instance ToField UUID.UUID where
  toField = toField . UUID.toByteString 

instance forall o. FromField (Subtype (Activity o)) where
  fromField = fromField >=> \case
    "Follow"  -> pure Follow
    "Accept"  -> pure Accept
    "Reject"  -> pure Reject
    "Create"  -> pure Create
    "Delete"  -> pure Delete
    "Announce"-> pure Announce
    "Like"    -> pure Like
    "Undo"    -> pure Undo
    (str :: Text) -> fail ("Bad subtype of Activity: " <> show str)

instance forall o. ToField (Subtype (Activity o)) where
  toField Follow   = toField ("Follow"   :: Text)
  toField Accept   = toField ("Accept"   :: Text)
  toField Reject   = toField ("Reject"   :: Text)
  toField Create   = toField ("Create"   :: Text)
  toField Delete   = toField ("Delete"   :: Text)
  toField Announce = toField ("Announce" :: Text)
  toField Like     = toField ("Like"     :: Text)
  toField Undo     = toField ("Undo"     :: Text)


instance FromField (Subtype Actor) where
  fromField = fromField >=> \case
    "Person"       -> pure Person
    "Service"      -> pure Service
    "Application"  -> pure Application
    "Organization" -> pure Organization
    "Group"        -> pure Group
    (str :: Text)  -> fail ("Bad subtype of Actor: " <> show str)

instance ToField (Subtype Actor) where
  toField Person       = toField ("Person"       :: Text)
  toField Service      = toField ("Service"      :: Text)
  toField Application  = toField ("Application"  :: Text)
  toField Organization = toField ("Organization" :: Text)
  toField Group        = toField ("Group"        :: Text)