From 4e3888ae129072f0ccf9496c38955b281e389194 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Fri, 14 Jun 2019 00:19:28 +0200 Subject: [PATCH] right track --- src/Aggreact/Comments/StoreService.hs | 30 +++++++++++++-------------- src/Aggreact/Comments/Types.hs | 18 ++++++++-------- src/Aggreact/Users/Types.hs | 24 +++++++++++---------- src/Database/Store.hs | 1 + 4 files changed, 37 insertions(+), 36 deletions(-) diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index 8c37bff..56305e3 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -48,12 +48,11 @@ import qualified Aggreact.Users as User -------------------------------------------------------------------------------- import Data.Time.Format () -import Database.SQLite.Simple (Only (..), query, query_) +import Database.SQLite.Simple (Connection,query_) -import Database.Beam (references_, (&&.), (==?.)) +import Database.Beam (references_) import qualified Database.Beam as Beam -import qualified Database.Beam.Query as BeamQ import qualified Database.Beam.Sqlite as BeamSqlite import Database.Store (DefaultMetas (..), Id (..), Store (..)) @@ -109,10 +108,16 @@ getLatestComments' SQLiteState{..} = liftIO . query_ conn . conv $ "SELECT * FROM " <> stTablename <> " ORDER BY created DESC LIMIT 20" -- commentsView' :: _ -> AggreactDB f -> Slug -> IO [_res] -commentsView' conn db sl = do +commentsView' :: Beam.Database BeamSqlite.Sqlite db + => Connection + -> AggreactDB (Beam.DatabaseEntity BeamSqlite.Sqlite db) + -> Slug + -> IO [CommentView] +commentsView' conn db (Slug sl) = do res <- BeamSqlite.runBeamSqliteDebug putStrLn conn $ Beam.runSelectReturningList $ Beam.select $ do comment <- Beam.all_ (_aggreactComments db) + Beam.guard_ ((_slug comment) Beam.==. Beam.val_ sl) muser <- Beam.leftJoin_ (Beam.all_ (_aggreactUsers db)) (\u -> (Beam.maybe_ @@ -120,18 +125,10 @@ commentsView' conn db sl = do (`references_` u) (_userid comment))) pure (comment,muser) - pure res - -- traverse (\(c,mu) -> pure $ - -- CommentView - -- (bCommentToCommentNoUser c) - -- (fmap User.bUserToUser mu)) res - - -instance Beam.HasSqlEqualityCheck BeamSqlite.Sqlite Id -instance Beam.FromBackendRow BeamSqlite.Sqlite ParentId -instance Beam.FromBackendRow BeamSqlite.Sqlite Slug -instance Beam.FromBackendRow BeamSqlite.Sqlite Content -instance Beam.FromBackendRow BeamSqlite.Sqlite Id + traverse (\(c,mu) -> pure $ + CommentView + (bCommentToCommentNoUser c) + (fmap User.bUserToUser mu)) res -- | A comment handler, handle all impure operations needed to Comments data CommentHandler = CommentHandler @@ -150,6 +147,7 @@ data CommentHandler = CommentHandler -- | Init a new comment handler -- newCommentHandler :: AggreactDB e -> User.DBStore -> CommentDBConf -> IO CommentHandler +newCommentHandler :: Beam.Database BeamSqlite.Sqlite db => AggreactDB (Beam.DatabaseEntity BeamSqlite.Sqlite db) -> p -> CommentDBConf -> IO CommentHandler newCommentHandler db userStore conf = do dbstore <- initDBComments conf pure CommentHandler { createComment = createComment' dbstore diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index c493756..b026091 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -139,11 +139,11 @@ data NewComment = bCommentToCommentNoUser :: BComment -> Comment bCommentToCommentNoUser bc = Entity - (_id bc) + (Id (toS (_id bc))) (NewComment - { parent = _parent bc - , slug = _slug bc - , content = _content bc + { parent = ParentId (fmap toS (_parent bc)) + , slug = Slug (_slug bc) + , content = Content (_content bc) , userid = MUserId Nothing }) (DefaultMetas @@ -152,12 +152,12 @@ bCommentToCommentNoUser bc = data BCommentT f = BComment - { _parent :: Beam.Columnar f ParentId -- ^ UUID - , _slug :: Beam.Columnar f Slug -- ^ Text (URL) - , _content :: Beam.Columnar f Content -- ^ Text + { _parent :: Beam.Columnar (Beam.Nullable f) Text -- ^ UUID + , _slug :: Beam.Columnar f Text -- ^ Text (URL) + , _content :: Beam.Columnar f Text -- ^ Text , _created :: Beam.Columnar f UTCTime , _updated :: Beam.Columnar f (Maybe UTCTime) - , _id :: Beam.Columnar f Id + , _id :: Beam.Columnar f Text , _userid :: Beam.PrimaryKey BUserT (Beam.Nullable f) -- ^ UUID } deriving (Generic) type BComment = BCommentT Identity @@ -167,7 +167,7 @@ deriving instance Eq BComment instance Beam.Beamable BCommentT instance Beam.Table BCommentT where data PrimaryKey BCommentT f = - BCommentId (Beam.Columnar f Id) deriving (Generic, Beam.Beamable) + BCommentId (Beam.Columnar f Text) deriving (Generic, Beam.Beamable) primaryKey = BCommentId . _id -- Web diff --git a/src/Aggreact/Users/Types.hs b/src/Aggreact/Users/Types.hs index fa80239..6f0a8b5 100644 --- a/src/Aggreact/Users/Types.hs +++ b/src/Aggreact/Users/Types.hs @@ -84,12 +84,14 @@ instance Form.FromForm NewUser where bUserToUser :: BUser -> User bUserToUser bc = Entity - (_id bc) + (Id (toS (_id bc))) NewUser - { nick = _nick bc - , email = _email bc - , password = _password bc - , role = _role bc + { nick = Nick (_nick bc) + , email = Email (_email bc) + , password = HashedPassword (_password bc) + , role = (case _role bc of + "Admin" -> Admin + _ -> User) , trust = _trust bc } DefaultMetas @@ -98,14 +100,14 @@ bUserToUser bc = data BUserT f = BUser - { _nick :: Beam.Columnar f Nick - , _email :: Beam.Columnar f Email - , _password :: Beam.Columnar f HashedPassword - , _role :: Beam.Columnar f Role + { _nick :: Beam.Columnar f Text + , _email :: Beam.Columnar f Text + , _password :: Beam.Columnar f Text + , _role :: Beam.Columnar f Text , _trust :: Beam.Columnar f Int , _created :: Beam.Columnar f UTCTime , _updated :: Beam.Columnar (Beam.Nullable f) UTCTime - , _id :: Beam.Columnar f Id + , _id :: Beam.Columnar f Text } deriving (Generic) type BUser = BUserT Identity type BUserId = Beam.PrimaryKey BUserT Identity @@ -119,7 +121,7 @@ deriving instance Eq BMUserId instance Beam.Beamable BUserT instance Beam.Table BUserT where data PrimaryKey BUserT f = - BUserId (Beam.Columnar f Id) deriving (Generic, Beam.Beamable) + BUserId (Beam.Columnar f Text) deriving (Generic, Beam.Beamable) primaryKey = BUserId . _id newtype Nick = Nick Text diff --git a/src/Database/Store.hs b/src/Database/Store.hs index 767c5ad..4b1de3a 100644 --- a/src/Database/Store.hs +++ b/src/Database/Store.hs @@ -74,6 +74,7 @@ instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString instance StringConv UUID Text where strConv l = strConv l . UUID.toText instance StringConv UUID UUID where strConv _ x = x instance StringConv UUID Id where strConv l uuid = Id (strConv l uuid) +instance StringConv Text UUID where strConv l = fromString . strConv l instance IsString UUID where fromString = fromMaybe UUID.nil . UUID.fromString