Selda schema for database

This commit is contained in:
Mats Rauhala 2018-08-02 23:59:08 +03:00
parent 2e5e64feae
commit 9dc1a7dca2
6 changed files with 72 additions and 3 deletions

View File

@ -20,6 +20,8 @@ executable ebook-manager
other-modules: Devel.Main other-modules: Devel.Main
, API , API
, Configuration , Configuration
, Database
, Database.Schema
, Server , Server
, Types , Types
-- other-extensions: -- other-extensions:

View File

@ -18,6 +18,11 @@ import Servant.HTML.Lucid (HTML)
import Lucid (HtmlT, ToHtml(..)) import Lucid (HtmlT, ToHtml(..))
import qualified Lucid.Html5 as H import qualified Lucid.Html5 as H
import Types import Types
import Control.Monad.Logger
-- XXX: Temporary
import Database.Schema
import Database
data Index = Index data Index = Index
@ -41,4 +46,8 @@ instance ToHtml Index where
type API = Get '[HTML] Index type API = Get '[HTML] Index
handler :: ServerT API AppM handler :: ServerT API AppM
handler = return Index handler = do
u <- runDB $
query $ select $ gen users
$logInfo $ "users: " <> (pack . show $ u)
return Index

27
src/Database.hs Normal file
View File

@ -0,0 +1,27 @@
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language FlexibleContexts #-}
{-# Language ConstraintKinds #-}
module Database
( DBLike
, runDB
, query
, select
, gen )
where
import Data.Generics.Product
import Control.Lens (view)
import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select)
import Database.Selda.Generic (gen)
import ClassyPrelude
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))
runDB :: DBLike r m => SeldaT m a -> m a
runDB q = do
pool <- view (field @"database")
withResource pool $ \conn ->
runSeldaT q conn

15
src/Database/Schema.hs Normal file
View File

@ -0,0 +1,15 @@
{-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-}
{-# Language OverloadedStrings #-}
module Database.Schema where
import ClassyPrelude
import Database.Selda.Generic
data User = User { email :: Text
, username :: Text
, password :: ByteString }
deriving (Show, Generic)
users :: GenTable User
users = genTable "users" [ email :- primaryGen ]

View File

@ -3,6 +3,7 @@
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language NoImplicitPrelude #-}
module Main where module Main where
import Server (server) import Server (server)
@ -14,9 +15,19 @@ import System.Process (callProcess)
import ClassyPrelude import ClassyPrelude
import Control.Lens (view) import Control.Lens (view)
import Data.Generics.Product import Data.Generics.Product
import Data.Pool (createPool)
import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
defaultMain :: Config -> IO () defaultMain :: Config -> IO ()
defaultMain c = run 8080 (server (App c)) defaultMain config = do
let pgHost = view (field @"database" . field @"host") config
pgPort = 5432
pgDatabase = view (field @"database" . field @"database") config
pgUsername = Just (view (field @"database" . field @"username") config)
pgPassword = Just (view (field @"database" . field @"password") config)
database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
let app = App{..}
run 8080 (server app)
migrate :: Pg -> IO () migrate :: Pg -> IO ()
migrate Pg{..} = do migrate Pg{..} = do

View File

@ -1,10 +1,15 @@
{-# Language NoImplicitPrelude #-} {-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-}
module Types where module Types where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Logger import Control.Monad.Logger
import Configuration import Configuration
import Data.Pool (Pool)
import Database.Selda.Backend (SeldaConnection)
newtype App = App { config :: Config } data App = App { config :: Config
, database :: Pool SeldaConnection }
deriving (Generic)
type AppM = LoggingT (ReaderT App IO) type AppM = LoggingT (ReaderT App IO)