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:
parent
660b8d43e5
commit
1d47e94bbe
6 changed files with 117 additions and 34 deletions
4
.gitignore
vendored
4
.gitignore
vendored
|
@ -1 +1,3 @@
|
|||
data.db
|
||||
*.db
|
||||
*.db-shm
|
||||
*.db-wal
|
|
@ -8,6 +8,9 @@ in pkgs.mkShell {
|
|||
hpkgs.resource-pool
|
||||
hpkgs.sqlite-simple
|
||||
hpkgs.warp
|
||||
hpkgs.persistent
|
||||
hpkgs.persistent-sqlite
|
||||
hpkgs.persistent-template
|
||||
]))
|
||||
];
|
||||
}
|
||||
|
|
45
src/API.hs
45
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)
|
||||
|
|
58
src/App.hs
Normal file
58
src/App.hs
Normal 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
|
|
@ -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
35
src/Types.hs
Normal 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
|
||||
]
|
Loading…
Reference in a new issue