Selda schema for database

ebook-manager.cabal

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

src/API.hs

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

src/Database.hs

@@ -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

src/Database/Schema.hs

@@ -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 ]

src/Main.hs

@@ -3,6 +3,7 @@
 {-# Language DuplicateRecordFields #-}
 {-# Language TypeApplications #-}
 {-# Language DataKinds #-}
+{-# Language NoImplicitPrelude #-}
 module Main where
 
 import Server (server)
@@ -14,9 +15,19 @@ import System.Process (callProcess)
 import ClassyPrelude
 import Control.Lens (view)
 import Data.Generics.Product
+import Data.Pool (createPool)
+import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
 
 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{..} = do

src/Types.hs

@@ -1,10 +1,15 @@
 {-# Language NoImplicitPrelude #-}
+{-# Language DeriveGeneric #-}
 module Types where
 
 import ClassyPrelude
 import Control.Monad.Logger
 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)