{-# LANGUAGE QuasiQuotes, TemplateHaskell, UndecidableInstances, AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Conduit.Features.Articles.DB
  ( migrateArticleTables
  , createArticleFunctions
  , assumingUserIsOwner
  , mkManyArticles
  , mkOneArticle
  , Article(..)
  , Favorite(..)
  , Comment(..)
  ) where

import Conduit.DB.Core (SqlKey(..), authorizationSqlError, deriveSqlKey, resourceNotFoundSqlError)
import Conduit.DB.Utils (suchThat)
import Conduit.Features.Account.DB (User, UserId, mkProfile)
import Conduit.Features.Account.Types (UserID)
import Conduit.Features.Articles.Types (ArticleID(..), CommentID(..), ManyArticles(..), OneArticle(..), Slug(..))
import Data.FileEmbed (embedFile)
import Data.Time (UTCTime)
import Database.Esqueleto.Experimental (Entity(..), PersistEntity(..), SqlExpr, SqlPersistT, Value(..), from, rawExecute, selectOne, table, val, (==.))
import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings)
import UnliftIO.Exception (throwIO)

share [mkPersist sqlSettings, mkMigrate "migrateArticleTables"] [persistLowerCase|
  Article
    author  UserId  OnDeleteCascade
    slug     Text
    title    Text
    desc     Text
    body     Text
    tags    [Text]
    created UTCTime default=now()
    updated UTCTime default=now()
    UniqueSlug   slug
    UniqueTitle title

  Favorite
    user    UserId    OnDeleteCascade
    article ArticleId OnDeleteCascade
    Primary article user

  Comment
    author  UserId    OnDeleteCascade
    article ArticleId OnDeleteCascade
    body    Text
    created UTCTime default=now()
    updated UTCTime default=now()
|]

createArticleFunctions :: (MonadIO m) => SqlPersistT m ()
createArticleFunctions :: forall (m :: * -> *). MonadIO m => SqlPersistT m ()
createArticleFunctions = Text -> [PersistValue] -> ReaderT SqlBackend m ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
fns [] where
  fns :: Text
fns = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ $(embedFile "sqlbits/articles/slug_id_prepender.sql")
    , $(embedFile "sqlbits/articles/set_timestamps.sql")
    ]

$(deriveSqlKey ''Article ''ArticleID)
$(deriveSqlKey ''Comment ''CommentID)

assumingUserIsOwner :: ∀ table id m a e. (OwnableEntity table, SqlKey table id, MonadIO m, Show e) => e -> UserID -> id -> SqlPersistT m a -> SqlPersistT m a
assumingUserIsOwner :: forall table id (m :: * -> *) a e.
(OwnableEntity table, SqlKey table id, MonadIO m, Show e) =>
e -> UserID -> id -> SqlPersistT m a -> SqlPersistT m a
assumingUserIsOwner e
err UserID
userID id
tableID SqlPersistT m a
action = do
  Maybe (Entity table)
result <- SqlQuery (SqlExpr (Entity table))
-> ReaderT SqlBackend m (Maybe (Entity table))
forall a r (m :: * -> *) backend.
(SqlSelect a r, MonadIO m, SqlBackendCanRead backend) =>
SqlQuery a -> ReaderT backend m (Maybe r)
selectOne (SqlQuery (SqlExpr (Entity table))
 -> ReaderT SqlBackend m (Maybe (Entity table)))
-> SqlQuery (SqlExpr (Entity table))
-> ReaderT SqlBackend m (Maybe (Entity table))
forall a b. (a -> b) -> a -> b
$ From (SqlExpr (Entity table)) -> SqlQuery (SqlExpr (Entity table))
forall a a'. ToFrom a a' => a -> SqlQuery a'
from (forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
table @table)
    SqlQuery (SqlExpr (Entity table))
-> (SqlExpr (Entity table) -> SqlExpr (Value Bool))
-> SqlQuery (SqlExpr (Entity table))
forall a. SqlQuery a -> (a -> SqlExpr (Value Bool)) -> SqlQuery a
`suchThat` \SqlExpr (Entity table)
a ->
      SqlExpr (Entity table) -> SqlExpr (Value (Key table))
forall table.
OwnableEntity table =>
SqlExpr (Entity table) -> SqlExpr (Value (Key table))
getID SqlExpr (Entity table)
a SqlExpr (Value (Key table))
-> SqlExpr (Value (Key table)) -> SqlExpr (Value Bool)
forall typ.
PersistField typ =>
SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)
==. Key table -> SqlExpr (Value (Key table))
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val (id -> Key table
forall t id. SqlKey t id => id -> Key t
id2sqlKey id
tableID)

  case Maybe (Entity table)
result of
    Maybe (Entity table)
Nothing -> SqlError -> SqlPersistT m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SqlError
resourceNotFoundSqlError
    Just Entity table
resource -> if Entity table -> UserID
forall table. OwnableEntity table => Entity table -> UserID
getOwner Entity table
resource UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
userID
      then SqlPersistT m a
action
      else SqlError -> SqlPersistT m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SqlError -> SqlPersistT m a) -> SqlError -> SqlPersistT m a
forall a b. (a -> b) -> a -> b
$ e -> SqlError
forall e. Show e => e -> SqlError
authorizationSqlError e
err

class (PersistEntity table) => OwnableEntity table where
  getID :: SqlExpr (Entity table) -> SqlExpr (Value (Key table))
  getOwner :: Entity table -> UserID

instance OwnableEntity Article where
  getOwner :: Entity Article -> UserID
getOwner (Entity Key Article
_ Article
a) = UserId -> UserID
forall t id. SqlKey t id => Key t -> id
sqlKey2ID Article
a.articleAuthor
  getID :: SqlExpr (Entity Article) -> SqlExpr (Value (Key Article))
getID SqlExpr (Entity Article)
a = SqlExpr (Entity Article)
a.id

instance OwnableEntity Comment where
  getOwner :: Entity Comment -> UserID
getOwner (Entity Key Comment
_ Comment
c) = UserId -> UserID
forall t id. SqlKey t id => Key t -> id
sqlKey2ID Comment
c.commentAuthor
  getID :: SqlExpr (Entity Comment) -> SqlExpr (Value (Key Comment))
getID SqlExpr (Entity Comment)
a = SqlExpr (Entity Comment)
a.id

mkManyArticles :: [(Entity Article, Entity User, Value Bool, Value Bool, Value Int)] -> ManyArticles
mkManyArticles :: [(Entity Article, Entity User, Value Bool, Value Bool, Value Int)]
-> ManyArticles
mkManyArticles = [OneArticle] -> ManyArticles
ManyArticles ([OneArticle] -> ManyArticles)
-> ([(Entity Article, Entity User, Value Bool, Value Bool,
      Value Int)]
    -> [OneArticle])
-> [(Entity Article, Entity User, Value Bool, Value Bool,
     Value Int)]
-> ManyArticles
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Entity Article, Entity User, Value Bool, Value Bool, Value Int)
 -> OneArticle)
-> [(Entity Article, Entity User, Value Bool, Value Bool,
     Value Int)]
-> [OneArticle]
forall a b. (a -> b) -> [a] -> [b]
map (Entity Article, Entity User, Value Bool, Value Bool, Value Int)
-> OneArticle
mkOneArticle

mkOneArticle :: (Entity Article, Entity User, Value Bool, Value Bool, Value Int) -> OneArticle
mkOneArticle :: (Entity Article, Entity User, Value Bool, Value Bool, Value Int)
-> OneArticle
mkOneArticle (Entity Key Article
_ Article {[Text]
Text
UTCTime
UserId
$sel:articleAuthor:Article :: Article -> UserId
$sel:articleSlug:Article :: Article -> Text
$sel:articleTitle:Article :: Article -> Text
$sel:articleDesc:Article :: Article -> Text
$sel:articleBody:Article :: Article -> Text
$sel:articleTags:Article :: Article -> [Text]
$sel:articleCreated:Article :: Article -> UTCTime
$sel:articleUpdated:Article :: Article -> UTCTime
articleAuthor :: UserId
articleSlug :: Text
articleTitle :: Text
articleDesc :: Text
articleBody :: Text
articleTags :: [Text]
articleCreated :: UTCTime
articleUpdated :: UTCTime
..}, Entity User
user, Value Bool
follows, Value Bool
faved, Value Int
numFavs) = OneArticle
  { $sel:slug:OneArticle :: Slug
slug      = Text
articleSlug Text -> (Text -> Slug) -> Slug
forall a b. a -> (a -> b) -> b
& Text -> Slug
Slug
  , $sel:title:OneArticle :: Text
title     = Text
articleTitle
  , $sel:tags:OneArticle :: [Text]
tags      = [Text]
articleTags [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [Text] -> [Text]
forall a. [a] -> [a]
reverse
  , $sel:body:OneArticle :: Text
body      = Text
articleBody
  , $sel:created:OneArticle :: UTCTime
created   = UTCTime
articleCreated
  , $sel:updated:OneArticle :: UTCTime
updated   = UTCTime
articleUpdated
  , $sel:favorited:OneArticle :: Bool
favorited = Bool
faved
  , $sel:numFavs:OneArticle :: Int
numFavs   = Int
numFavs
  , $sel:desc:OneArticle :: Text
desc      = Text
articleDesc
  , $sel:author:OneArticle :: UserProfile
author    = Entity User -> Value Bool -> UserProfile
mkProfile Entity User
user Value Bool
follows
  }