From 194adb8913b30059652c73ac799f32fa43952872 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Sun, 28 Apr 2019 23:40:45 +0200 Subject: [PATCH] beam progress --- aggreact.cabal | 3 +- src/Aggreact/Comments/StoreService.hs | 1 - src/Aggreact/Comments/Types.hs | 26 +++++++++++- src/Aggreact/DB.hs | 57 +++++++++++++++++++++++++++ src/Aggreact/Users/Types.hs | 32 ++++++++++++--- 5 files changed, 110 insertions(+), 9 deletions(-) create mode 100644 src/Aggreact/DB.hs diff --git a/aggreact.cabal b/aggreact.cabal index 2e0614f..156316b 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4f6fabeda91d58ac0756a616b4bf8e77949104a3d23a2930e156a42863c457e5 +-- hash: 7697e107fa7eeea373c454c40543eeaf710a518e5b990e99e90983d8d665f561 name: aggreact version: 0.1.0.0 @@ -37,6 +37,7 @@ library Aggreact.Comments.Types Aggreact.Comments.Views Aggreact.Css + Aggreact.DB Aggreact.Homepage Aggreact.Html Aggreact.Scopes diff --git a/src/Aggreact/Comments/StoreService.hs b/src/Aggreact/Comments/StoreService.hs index 26a093f..ed59f1a 100644 --- a/src/Aggreact/Comments/StoreService.hs +++ b/src/Aggreact/Comments/StoreService.hs @@ -57,7 +57,6 @@ import Database.Store.Backend.SQLite as SQL import qualified Database.Store.CRUD as CRUD import qualified Database.Store.Search as Search - type CommentSQLiteStore = SQLiteStore IO DefaultMetas NewComment type DBStore = StartedStore CommentSQLiteStore type CommentDBConf = DBConf CommentSQLiteStore diff --git a/src/Aggreact/Comments/Types.hs b/src/Aggreact/Comments/Types.hs index ec09f75..805aaf9 100644 --- a/src/Aggreact/Comments/Types.hs +++ b/src/Aggreact/Comments/Types.hs @@ -52,7 +52,7 @@ where import Protolude -import Aggreact.Users (User, UserId(..)) +import Aggreact.Users (User, UserId (..)) import qualified Control.Exception as Ex import Data.Aeson (FromJSON (..), ToJSON (..), @@ -64,10 +64,12 @@ import Data.Data (Data (..)) import Data.IxSet.OrphanInstances () import qualified Data.IxSet.Typed as IxSet import qualified Data.Text as Text +import Data.Time (UTCTime (..)) import Data.Time.Format () import Data.Typeable (Typeable) import Data.UUID (UUID) import qualified Data.UUID as UUID +import qualified Database.Beam as Beam import Database.SQLite.Simple (SQLData (..)) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.FromRow (FromRow (..), field) @@ -80,7 +82,6 @@ import qualified Generics.SOP as SOP import qualified Web.FormUrlEncoded as Form import qualified Web.HttpApiData as FormI - -- * Comment -- | A Comment is a NewComment with metas @@ -134,6 +135,27 @@ data NewComment = , userid :: MUserId -- ^ UUID } deriving (Generic,Typeable,Data,Eq,Ord,Show) +-- ** Beam +data BCommentT f = + BComment + { _parent :: Beam.Columnar f ParentId -- ^ UUID + , _slug :: Beam.Columnar f Slug -- ^ Text (URL) + , _content :: Beam.Columnar f Content -- ^ Text + , _userid :: Beam.Columnar f MUserId -- ^ UUID + , _created :: Beam.Columnar f UTCTime + , _updated :: Beam.Columnar f (Maybe UTCTime) + , _id :: Beam.Columnar f Id + } deriving (Generic) +type BComment = BCommentT Identity +type BCommentId = Beam.PrimaryKey BCommentT Identity +deriving instance Show BComment +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) + primaryKey = BCommentId . _id + -- Web instance FromJSON NewComment where parseJSON = genericParseJSON defaultOptions instance ToJSON NewComment where toJSON = genericToJSON defaultOptions diff --git a/src/Aggreact/DB.hs b/src/Aggreact/DB.hs new file mode 100644 index 0000000..6b27f91 --- /dev/null +++ b/src/Aggreact/DB.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{- | +Module : Aggreact.DB +Description : DB declration +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide a Store abstraction. + +-} + +module Aggreact.DB + +where + +import Protolude + +import Aggreact.Comments +import Aggreact.Users + +import qualified Database.Beam as Beam + +data AggreactDB f = AggreactDB + { _aggreactUsers :: f (Beam.TableEntity BUserT) + , _aggreactComments :: f (Beam.TableEntity BCommentT) + } deriving (Generic, Beam.Database be) + +aggreactDB :: Beam.DatabaseSettings be AggreactDB +aggreactDB = Beam.defaultDbSettings diff --git a/src/Aggreact/Users/Types.hs b/src/Aggreact/Users/Types.hs index 84aad03..2aec37a 100644 --- a/src/Aggreact/Users/Types.hs +++ b/src/Aggreact/Users/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -45,8 +46,10 @@ import Protolude import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Data (Data (..)) import qualified Data.Text as Text +import Data.Time (UTCTime (..)) +import qualified Database.Beam as Beam +import qualified Database.Beam.Sqlite () import Database.SQLite.Simple (SQLData (..)) - import Database.SQLite.Simple.FromField (FromField (..), ResultError (..), fieldData, returnError) @@ -56,14 +59,10 @@ import Database.SQLite.Simple.ToRow (ToRow (..)) import Database.Store import Database.Store.Backend.SQLite (SQLiteSchemas, ToSQLiteFieldTypeList (..)) - - - import qualified Database.Store.Backend.SQLite as SQL import qualified Generics.SOP as SOP import Servant import Servant.Auth.Server (FromJWT (..), ToJWT (..)) - import qualified Web.FormUrlEncoded as Form import qualified Web.HttpApiData as FormI @@ -78,6 +77,29 @@ data NewUser = instance Form.FromForm NewUser where fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} + +-- ** Beam +data BUserT f = + BUser + { _nick :: Beam.Columnar f Nick + , _email :: Beam.Columnar f Email + , _password :: Beam.Columnar f HashedPassword + , _role :: Beam.Columnar f Role + , _trust :: Beam.Columnar f Int + , _created :: Beam.Columnar f UTCTime + , _updated :: Beam.Columnar f (Maybe UTCTime) + , _id :: Beam.Columnar f Id + } deriving (Generic) +type BUser = BUserT Identity +type BUserId = Beam.PrimaryKey BUserT Identity +deriving instance Show BUser +deriving instance Eq BUser +instance Beam.Beamable BUserT +instance Beam.Table BUserT where + data PrimaryKey BUserT f = + BUserId (Beam.Columnar f Id) deriving (Generic, Beam.Beamable) + primaryKey = BUserId . _id + newtype Nick = Nick Text deriving (Eq,Ord,Data,Typeable,Generic,Show) deriving anyclass instance FromJSON Nick