Something went wrong. Try again.
A Haskell Webserver Template
Something went wrong. Try again.
5.6 kB · 170 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171module Webserver.Control.Sql ( acquirePool, runSession, releasePool, getConnectionSettings, generateTable, generateView, generateType, baseDerives,) where
----------------------------------------------------------------------------------------------------
import Control.Exception (Exception, throwIO)import Data.Aeson (FromJSON, ToJSON)import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Char8 as BS8import GHC.Generics (Generic)import qualified Hasql.Connection as Connectionimport Hasql.Generate (Config (..), ConnectionInfo (..), fromTable, fromType, fromView, generate, withDefaultedCols, withDerivations)import qualified Hasql.Pool as Poolimport qualified Hasql.Pool.Config as PoolConfigimport qualified Hasql.Session as Sessionimport Language.Haskell.TH (Dec, Name, Q, runIO)
import qualified System.Environment as Env
------------------------------------------------------------------------------------------------------ Shared environment reading----------------------------------------------------------------------------------------------------
{- Read PostgreSQL connection info from standard environment variables (PGUSER, PGPASSWORD, PGHOST, PGPORT, PGDATABASE). Returns a PgSimpleInfo with Maybe String fields — Nothing defers to libpq defaults. Used by both compile-time TH and runtime pool acquisition.-}readPgEnv :: IO ConnectionInforeadPgEnv = do pgUser <- Env.lookupEnv "PGUSER" pgPassword <- Env.lookupEnv "PGPASSWORD" pgHost <- Env.lookupEnv "PGHOST" pgPort <- Env.lookupEnv "PGPORT" pgDatabase <- Env.lookupEnv "PGDATABASE" return <| PgSimpleInfo {pgHost, pgPort, pgUser, pgPassword, pgDatabase}
------------------------------------------------------------------------------------------------------ Compile-time TH----------------------------------------------------------------------------------------------------
{- Project-wide compile-time config for hasql-generate. Reads PGUSER, PGPASSWORD, PGHOST, PGPORT, PGDATABASE from the environment at compile time via readPgEnv.-}defaultConfig :: Q ConfigdefaultConfig = runIO <| do connection <- readPgEnv return <| Config { connection , allowDuplicateRecordFields = True , newtypePrimaryKeys = False , globalOverrides = [] }
{- Base derive list applied to every table splice. -}baseDerives :: [Name]baseDerives = [''Show, ''Eq, ''Ord, ''Generic, ''FromJSON, ''ToJSON]
{- Generate a type and CRUD instances for a table using project defaults. Usage: @$(Sql.generateTable "public" "users")@-}generateTable :: String -> String -> Q [Dec]generateTable schema table = do cfg <- defaultConfig generate cfg ( fromTable schema table |> withDerivations baseDerives |> withDefaultedCols ["id"] )
{- Generate a type and select instances for a view using project defaults. Usage: @$(Sql.generateView "public" "users_view")@-}generateView :: String -> String -> Q [Dec]generateView schema view = do cfg <- defaultConfig generate cfg ( fromView schema view |> withDerivations baseDerives )
{- Generate a type and enum instances for a type using project defaults. Usage: @$(Sql.generateType "public" "user_type")@-}generateType :: String -> String -> Q [Dec]generateType schema type_ = do cfg <- defaultConfig generate cfg ( fromType schema type_ |> withDerivations baseDerives )
------------------------------------------------------------------------------------------------------ Runtime pool management----------------------------------------------------------------------------------------------------
{- Build a libpq-format connection settings ByteString from environment variables. Falls back to development defaults for each parameter.-}getConnectionSettings :: IO Connection.SettingsgetConnectionSettings = do PgSimpleInfo {pgHost, pgPort, pgUser, pgPassword, pgDatabase} <- readPgEnv let host = fromMaybe "127.0.0.1" pgHost port = fromMaybe "5433" pgPort user = fromMaybe "admin" pgUser pass = fromMaybe "pass" pgPassword db = fromMaybe "webserver" pgDatabase return <| BS8.pack <| "host=" <> host <> " port=" <> port <> " dbname=" <> db <> " user=" <> user <> " password=" <> pass
{- Create a hasql connection pool for runtime use.-}acquirePool :: IO Pool.PoolacquirePool = do connSettings <- getConnectionSettings Pool.acquire <| PoolConfig.settings [ PoolConfig.size 8 , PoolConfig.acquisitionTimeout 10 , PoolConfig.staticConnectionSettings connSettings ]
{- Release all idle connections in the pool.-}releasePool :: Pool.Pool -> IO ()releasePool = Pool.release
{- Run a hasql Session against the pool, throwing on error.-}runSession :: Pool.Pool -> Session.Session a -> IO arunSession pool session = Pool.use pool session >>= \case Left err -> throwIO <| PoolUsageError err Right a -> return a
----------------------------------------------------------------------------------------------------
newtype PoolUsageError = PoolUsageError Pool.UsageError
instance Show PoolUsageError where show (PoolUsageError err) = "Pool usage error: " <> show err
instance Exception PoolUsageError