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.

1 files changed, 58 insertions, 0 deletions

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