tvl-depot/src/App.hs
William Carroll d011616564 Change the name User to Account
Next I'll need to add / remove fields from the Account type.
2020-07-25 18:18:59 +01:00

63 lines
2.2 KiB
Haskell

{-# 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 qualified Types as T
--------------------------------------------------------------------------------
server :: ConnectionPool -> Server API
server pool =
userAddH :<|> userGetH
where
userAddH newUser = liftIO $ userAdd newUser
userGetH name = liftIO $ userGet name
userAdd :: T.Account -> IO (Maybe T.Session)
userAdd newUser = flip runSqlPersistMPool pool $ do
exists <- selectFirst [T.AccountName ==. (T.accountName newUser)] []
case exists of
Nothing -> do
insert newUser
pure $ Just (T.Session { T.username = T.Username "wpcarro"
, T.password = T.Password "testing"
, T.role = T.RegularUser
})
Just _ -> pure Nothing
userGet :: Text -> IO (Maybe T.Account)
userGet name = flip runSqlPersistMPool pool $ do
mUser <- selectFirst [T.AccountName ==. name] []
pure $ 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 T.migrateAll) pool
pure $ app pool
run :: FilePath -> IO ()
run sqliteFile =
Warp.run 3000 =<< mkApp sqliteFile