beam progress

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

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

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

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

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