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.
This commit is contained in:
William Carroll 2020-07-24 22:46:54 +01:00
parent 660b8d43e5
commit 1d47e94bbe
6 changed files with 117 additions and 34 deletions

4
.gitignore vendored
View file

@ -1 +1,3 @@
data.db
*.db
*.db-shm
*.db-wal

View file

@ -8,6 +8,9 @@ in pkgs.mkShell {
hpkgs.resource-pool
hpkgs.sqlite-simple
hpkgs.warp
hpkgs.persistent
hpkgs.persistent-sqlite
hpkgs.persistent-template
]))
];
}

View file

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

58
src/App.hs Normal file
View file

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

View file

@ -1,5 +1,7 @@
module Main where
--------------------------------------------------------------------------------
import qualified App
--------------------------------------------------------------------------------
main :: IO ()
main = do
putStrLn "Working..."
main = App.run "sqlite.db"

35
src/Types.hs Normal file
View file

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