Integrate Persistent with Servant

Query my SQLite database from within my Servant handlers. Nothing I've written
is domain-specific to the business logic yet -- I'm just making sure everything
integrates.

4 files changed, 111 insertions, 33 deletions

diff --git a/src/API.hs b/src/API.hs
index b2c7fd57d67f..b46ae5b3560f 100644
--- a/src/API.hs
+++ b/src/API.hs
@@ -1,39 +1,22 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 --------------------------------------------------------------------------------
 module API where
 --------------------------------------------------------------------------------
-import qualified Data.Pool as DP
-import qualified Database.SQLite.Simple as DB
+import Data.Proxy
+import Data.Text
+import Database.Persist
+import Servant.API
 
-import Data.Aeson
-import GHC.Generics
-import GHC.TypeLits
-import Network.Wai.Handler.Warp
-import Servant
-import Control.Monad.IO.Class
+import qualified Types as T
 --------------------------------------------------------------------------------
 
-handlers :: DP.Pool DB.Connection -> Server API
-handlers pool = do
-  getHandler pool :<|> pure 0
-
-getHandler :: DP.Pool DB.Connection -> Handler Int
-getHandler pool =
-  DP.withResource pool $ \conn -> do
-     result <- liftIO $ DB.query_ conn "select 2 + 2"
-     case result of
-       [DB.Only x] -> pure x
-       _  -> pure (-1)
-
-type API = "number" :> Get '[JSON] Int
-      :<|> "other" :> Post '[JSON] Int
-
-main :: IO ()
-main = do
-  pool <- DP.createPool (DB.open "data.db") DB.close 1 0.5 1
-  run 3000 (serve (Proxy @ API) (handlers pool))
+type API = "user"
+           :> ReqBody '[JSON] T.User
+           :> Post '[JSON] (Maybe (Key T.User))
+      :<|> "user"
+           :> Capture "name" Text
+           :> Get  '[JSON] (Maybe T.User)
diff --git a/src/App.hs b/src/App.hs
new file mode 100644
index 000000000000..1f7754517596
--- /dev/null
+++ b/src/App.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+--------------------------------------------------------------------------------
+module App where
+--------------------------------------------------------------------------------
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger (runStderrLoggingT)
+import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool
+                               , runSqlPool, runSqlPersistMPool
+                               , runMigration, selectFirst, (==.)
+                               , insert, entityVal)
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import Network.Wai.Handler.Warp as Warp
+import Servant
+
+import API
+import Types
+--------------------------------------------------------------------------------
+
+server :: ConnectionPool -> Server API
+server pool =
+  userAddH :<|> userGetH
+  where
+    userAddH newUser = liftIO $ userAdd newUser
+    userGetH name    = liftIO $ userGet name
+
+    userAdd :: User -> IO (Maybe (Key User))
+    userAdd newUser = flip runSqlPersistMPool pool $ do
+      exists <- selectFirst [UserName ==. (userName newUser)] []
+      case exists of
+        Nothing -> Just <$> insert newUser
+        Just _ -> return Nothing
+
+    userGet :: Text -> IO (Maybe User)
+    userGet name = flip runSqlPersistMPool pool $ do
+      mUser <- selectFirst [UserName ==. name] []
+      return $ entityVal <$> mUser
+
+app :: ConnectionPool -> Application
+app pool = serve (Proxy @ API) $ server pool
+
+mkApp :: FilePath -> IO Application
+mkApp sqliteFile = do
+  pool <- runStderrLoggingT $ do
+    createSqlitePool (cs sqliteFile) 5
+
+  runSqlPool (runMigration migrateAll) pool
+  return $ app pool
+
+run :: FilePath -> IO ()
+run sqliteFile =
+  Warp.run 3000 =<< mkApp sqliteFile
diff --git a/src/Main.hs b/src/Main.hs
index 7ec8d9f8ca82..ea2ad2621bd9 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,7 @@
 module Main where
+--------------------------------------------------------------------------------
+import qualified App
+--------------------------------------------------------------------------------
 
 main :: IO ()
-main = do
-  putStrLn "Working..."
+main = App.run "sqlite.db"
diff --git a/src/Types.hs b/src/Types.hs
new file mode 100644
index 000000000000..3a410dc4b525
--- /dev/null
+++ b/src/Types.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+--------------------------------------------------------------------------------
+module Types where
+--------------------------------------------------------------------------------
+import Data.Aeson
+import Data.Text
+import Database.Persist.TH
+--------------------------------------------------------------------------------
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+User
+  name Text
+  age  Int
+  UniqueName name
+  deriving Eq Read Show
+|]
+
+instance FromJSON User where
+  parseJSON = withObject "User" $ \ v ->
+    User <$> v .: "name"
+         <*> v .: "age"
+
+instance ToJSON User where
+  toJSON (User name age) =
+    object [ "name" .= name
+           , "age"  .= age
+           ]