112 lines
3.6 KiB
Haskell
112 lines
3.6 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Database.PostgreSQL.Opium
|
|
-- * Queries
|
|
--
|
|
-- Functions for performing queries. @fetch@ retrieves rows, @execute@ doesn't.
|
|
-- The 'Connection' parameter comes last to facilitate currying for implicitly passing in the connection, e.g. from some framework's connection pool.
|
|
--
|
|
-- | TODO: Add @newtype Query = Query Text@ with @IsString@ instance to make constructing query strings at run time harder.
|
|
( fetch
|
|
, fetch_
|
|
, execute
|
|
, execute_
|
|
-- * Classes to Implement
|
|
, FromRow (..)
|
|
, FromField (..)
|
|
, ToParamList (..)
|
|
, ToField (..)
|
|
-- * Utility Stuff
|
|
, Error (..)
|
|
, ErrorPosition (..)
|
|
, RawField (..)
|
|
)
|
|
where
|
|
|
|
import Control.Monad (unless, void)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE)
|
|
import Data.Functor.Identity (Identity (..))
|
|
import Data.Proxy (Proxy (..))
|
|
import Data.Text (Text)
|
|
import Database.PostgreSQL.LibPQ
|
|
( Connection
|
|
, Result
|
|
)
|
|
|
|
import qualified Data.Text.Encoding as Encoding
|
|
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
|
|
|
import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..))
|
|
import Database.PostgreSQL.Opium.FromField (FromField (..), RawField (..))
|
|
import Database.PostgreSQL.Opium.FromRow (FromRow (..), ColumnTable)
|
|
import Database.PostgreSQL.Opium.ToField (ToField (..))
|
|
import Database.PostgreSQL.Opium.ToParamList (ToParamList (..))
|
|
|
|
class RowContainer c where
|
|
extract :: FromRow a => Result -> LibPQ.Row -> ColumnTable -> ExceptT Error IO (c a)
|
|
|
|
instance RowContainer [] where
|
|
extract result nRows columnTable = do
|
|
mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
|
|
|
|
instance RowContainer Maybe where
|
|
extract result nRows columnTable
|
|
| nRows == 0 = pure Nothing
|
|
| nRows == 1 = Just <$> ExceptT (fromRow result columnTable 0)
|
|
| otherwise = throwE ErrorMoreThanOneRow
|
|
|
|
instance RowContainer Identity where
|
|
extract result nRows columnTable = do
|
|
unless (nRows == 1) $ throwE ErrorNotExactlyOneRow
|
|
Identity <$> ExceptT (fromRow result columnTable 0)
|
|
|
|
-- The order of the type parameters is important, because it is more common to use type applications for providing the row type and row container type.
|
|
fetch
|
|
:: forall a b c. (ToParamList c, FromRow a, RowContainer b)
|
|
=> Text
|
|
-> c
|
|
-> Connection
|
|
-> IO (Either Error (b a))
|
|
fetch query params conn = runExceptT $ do
|
|
result <- execParams conn query params
|
|
nRows <- liftIO $ LibPQ.ntuples result
|
|
columnTable <- ExceptT $ getColumnTable @a Proxy result
|
|
extract result nRows columnTable
|
|
|
|
fetch_ :: forall a c. (FromRow a, RowContainer c) => Text -> Connection -> IO (Either Error (c a))
|
|
fetch_ query = fetch query ()
|
|
|
|
execute
|
|
:: forall a. ToParamList a
|
|
=> Text
|
|
-> a
|
|
-> Connection
|
|
-> IO (Either Error ())
|
|
execute query params conn = runExceptT $ void $ execParams conn query params
|
|
|
|
execute_ :: Text -> Connection -> IO (Either Error ())
|
|
execute_ query = execute query ()
|
|
|
|
execParams
|
|
:: ToParamList a
|
|
=> Connection
|
|
-> Text
|
|
-> a
|
|
-> ExceptT Error IO Result
|
|
execParams conn query params = do
|
|
let queryBytes = Encoding.encodeUtf8 query
|
|
liftIO (LibPQ.execParams conn queryBytes (toParamList params) LibPQ.Binary) >>= \case
|
|
Nothing ->
|
|
except $ Left ErrorNoResult
|
|
Just result -> do
|
|
status <- liftIO $ LibPQ.resultStatus result
|
|
mbMessage <- liftIO $ LibPQ.resultErrorMessage result
|
|
case mbMessage of
|
|
Just "" -> pure result
|
|
Nothing -> pure result
|
|
Just message -> except $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message
|