80 lines
2.6 KiB
Haskell
80 lines
2.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DefaultSignatures #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Database.PostgreSQL.Opium
|
|
( FromField (..)
|
|
, FromRow (..)
|
|
, fetch_
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Trans.Maybe (MaybeT (..))
|
|
import Data.ByteString (ByteString)
|
|
import Data.Proxy (Proxy (Proxy))
|
|
import Database.PostgreSQL.LibPQ
|
|
( Connection
|
|
, Result
|
|
, Row
|
|
)
|
|
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
|
|
import GHC.TypeLits (KnownSymbol, symbolVal)
|
|
import Text.Printf (printf)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Encoding
|
|
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
|
|
|
import Database.PostgreSQL.Opium.FromField (FromField (..))
|
|
|
|
fetch_ :: FromRow a => Connection -> ByteString -> IO (Maybe [a])
|
|
fetch_ conn query = runMaybeT $ do
|
|
result <- MaybeT $ LibPQ.execParams conn query [] LibPQ.Text
|
|
MaybeT $ fetchResult result
|
|
|
|
fetchResult :: FromRow a => Result -> IO (Maybe [a])
|
|
fetchResult result = do
|
|
nRows <- LibPQ.ntuples result
|
|
runMaybeT $ mapM (MaybeT . flip fromRow result) [0..nRows - 1]
|
|
|
|
class FromRow a where
|
|
fromRow :: Row -> Result -> IO (Maybe a)
|
|
default fromRow :: (Generic a, FromRow' (Rep a)) => Row -> Result -> IO (Maybe a)
|
|
fromRow row result = fmap to <$> fromRow' row result
|
|
|
|
class FromRow' f where
|
|
fromRow' :: Row -> Result -> IO (Maybe (f p))
|
|
|
|
instance FromRow' f => FromRow' (M1 D c f) where
|
|
fromRow' row result = fmap M1 <$> fromRow' row result
|
|
|
|
instance FromRow' f => FromRow' (M1 C c f) where
|
|
fromRow' row result = fmap M1 <$> fromRow' row result
|
|
|
|
instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where
|
|
fromRow' row result = do
|
|
y <- fromRow' row result
|
|
z <- fromRow' row result
|
|
pure $ (:*:) <$> y <*> z
|
|
|
|
instance (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
|
|
fromRow' row result = do
|
|
mbColumn <- LibPQ.fnumber result name
|
|
case mbColumn of
|
|
Nothing -> pure Nothing
|
|
Just column -> do
|
|
mbField <- LibPQ.getvalue result row column
|
|
ty <- LibPQ.ftype result column
|
|
case fromField ty . Encoding.decodeUtf8 =<< mbField of
|
|
Nothing -> do
|
|
format <- LibPQ.fformat result column
|
|
printf "field %s: %s (oid: %s, format: %s)\n" (show name) (show mbField) (show ty) (show format)
|
|
pure Nothing
|
|
Just value ->
|
|
pure $ Just $ M1 $ K1 value
|
|
where
|
|
name = Encoding.encodeUtf8 $ Text.pack $ symbolVal (Proxy :: Proxy nameSym)
|