From 9dc1a7dca28f0a19e58310b44845d3103d7fe437 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Thu, 2 Aug 2018 23:59:08 +0300
Subject: [PATCH] Selda schema for database

---
 ebook-manager.cabal    |  2 ++
 src/API.hs             | 11 ++++++++++-
 src/Database.hs        | 27 +++++++++++++++++++++++++++
 src/Database/Schema.hs | 15 +++++++++++++++
 src/Main.hs            | 13 ++++++++++++-
 src/Types.hs           |  7 ++++++-
 6 files changed, 72 insertions(+), 3 deletions(-)
 create mode 100644 src/Database.hs
 create mode 100644 src/Database/Schema.hs

diff --git a/ebook-manager.cabal b/ebook-manager.cabal
index 695868d..23c35d1 100644
--- a/ebook-manager.cabal
+++ b/ebook-manager.cabal
@@ -20,6 +20,8 @@ executable ebook-manager
   other-modules:       Devel.Main
                      , API
                      , Configuration
+                     , Database
+                     , Database.Schema
                      , Server
                      , Types
   -- other-extensions:
diff --git a/src/API.hs b/src/API.hs
index 4928c28..cec504a 100644
--- a/src/API.hs
+++ b/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
diff --git a/src/Database.hs b/src/Database.hs
new file mode 100644
index 0000000..4b8b714
--- /dev/null
+++ b/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
diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs
new file mode 100644
index 0000000..b3675c1
--- /dev/null
+++ b/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 ]
diff --git a/src/Main.hs b/src/Main.hs
index edee1ba..3bb73a3 100644
--- a/src/Main.hs
+++ b/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
diff --git a/src/Types.hs b/src/Types.hs
index 4b6ce68..2593c31 100644
--- a/src/Types.hs
+++ b/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)