----------------------------------------------------------------------------- -- | -- Module : Database.Poseidon -- Copyright : (c) 2019 Florian Grignon -- License : BSD3 -- -- Maintainer : grignon.florian@gmail.com -- Stability : experimental -- -- This library provide a Simple and Extensible access to PostgreSQL. -- -- Simple: Poseidon runs a SQL query and returns a set of custom datatype. -- **It is not an ORM.** -- -- Extensible: As a user of the library, you can map your custom PostgreSQL -- type to your Haskell datatype easily, in a pluggable way (e.g. if you're -- using postgis, you will be most likely interested by poseidon-postgis, -- that maps GeoJSON WKT to GeospatialGeometry). -- ----------------------------------------------------------------------------- {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} module Database.Poseidon where import Prelude import Generics.Eot import Control.Concurrent.Async import Foreign.C.Types import Control.Exception import Data.Maybe (fromMaybe) import Database.Poseidon.Internal import Data.Poseidon() import Data.Binary import Data.Binary.Get import Data.UUID import Data.Time import Data.Aeson as A hiding (Result) import Data.Text hiding (splitAt) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Database.PostgreSQL.LibPQ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as B ( ByteString(..) ) newtype ExceptionText = ExceptionText Text deriving (Show, Eq) instance Exception ExceptionText data ExceptionPostgreSQL = ExceptionPGUniqueViolation | ExceptionPGJWTMalformed | ExceptionPGJWTInvalid | ExceptionPGUnknown deriving (Show, Eq) instance Exception ExceptionPostgreSQL queryFromText :: (HasEot a, EotDeserialize (Eot a)) => Connection -> Text -> [Maybe (Oid, B.ByteString, Format)] -> IO [a] queryFromText conn sqlQuery params = do mresult <- execParams conn (encodeUtf8 sqlQuery) params Binary case mresult of Just result -> do rStatus <- resultStatus result case rStatus of TuplesOk -> do (Row nbRows) <- ntuples result let rows = [0..(nbRows-1)] mapConcurrently (\k -> genericDeserialize result k 0) rows FatalError -> do diagSqlstate <- resultErrorField result DiagSqlstate diagSeverity <- resultErrorField result DiagSeverity putStrLn $ ("DiagSeverity : " <> (show diagSeverity)) diagMessagePrimary <- resultErrorField result DiagMessagePrimary putStrLn $ ("DiagMessagePrimary : " <> (show diagMessagePrimary)) diagMessageDetail <- resultErrorField result DiagMessageDetail putStrLn $ ("DiagMessageDetail : " <> (show diagMessageDetail)) diagMessageHint <- resultErrorField result DiagMessageHint putStrLn $ ("DiagMessageHint : " <> (show diagMessageHint)) diagStatementPosition <- resultErrorField result DiagStatementPosition putStrLn $ ("DiagStatementPosition : " <> (show diagStatementPosition)) diagInternalPosition <- resultErrorField result DiagInternalPosition putStrLn $ ("DiagInternalPosition : " <> (show diagInternalPosition)) diagInternalQuery <- resultErrorField result DiagInternalQuery putStrLn $ ("DiagInternalQuery : " <> (show diagInternalQuery)) diagContext <- resultErrorField result DiagContext putStrLn $ ("DiagContext : " <> (show diagContext)) diagSourceFile <- resultErrorField result DiagSourceFile putStrLn $ ("DiagSourceFile : " <> (show diagSourceFile)) diagSourceLine <- resultErrorField result DiagSourceLine putStrLn $ ("DiagSourceLine : " <> (show diagSourceLine)) diagSourceFunction <- resultErrorField result DiagSourceFunction putStrLn $ ("DiagSourceFunction : " <> (show diagSourceFunction)) putStrLn $ ("DiagSqlstate : " <> (show diagSqlstate)) case diagSqlstate of Just sqlStateBS -> do let sqlState = show sqlStateBS :: [Char] case sqlState of -- https://www.postgresql.org/docs/current/errcodes-appendix.html "\"23505\"" -> throw ExceptionPGUniqueViolation "\"P1002\"" -> throw ExceptionPGJWTMalformed "\"P1003\"" -> throw ExceptionPGJWTInvalid _ -> throw $ ExceptionPGUnknown Nothing -> throw $ ExceptionText "Cant retrieve the PostgreSQL error field SqlState" otherStatus -> do putStrLn $ ("PG Status : " <> (show otherStatus)) throw $ ExceptionText "Wrong PostgreSQL result status, please check" Nothing -> throw $ ExceptionText "Didnt receive a PostgreSQL result" class EotDeserialize eot where eotDeserialize :: Result -> CInt -> CInt -> IO eot instance (EotDeserialize this, EotDeserialize next) => EotDeserialize (Either this next) where eotDeserialize res row _ = Left <$> eotDeserialize res row 0 instance (Deserialize x, EotDeserialize xs) => EotDeserialize (x, xs) where -- eotDeserialize :: (Result, CInt, CInt) -> IO eot eotDeserialize res row col = do firstField <- deserialize res row col nextFields <- eotDeserialize res row (succ col) pure ( firstField, nextFields ) instance EotDeserialize Void where eotDeserialize _ _ _ = error "invalid input" instance EotDeserialize () where eotDeserialize _ _ _ = mempty getBSValue :: Result -> CInt -> CInt -> IO (Maybe BSL.ByteString) getBSValue res row col = do mValueBS <- getvalue res (Row row) (Col col) case mValueBS of Just valueBS' -> pure $ Just (BSL.fromStrict valueBS') Nothing -> pure $ Nothing class Deserialize a where deserialize :: Result -> CInt -> CInt -> IO a -- All base datatype we can deserialize instance Deserialize BSL.ByteString where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ bs instance Deserialize BS.ByteString where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ BSL.toStrict bs instance Deserialize Integer where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ fromIntegral . runGet getInt16be $ bs instance Deserialize Float where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ runGet getFloatbe bs instance Deserialize Double where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ runGet getDoublebe bs instance Deserialize Text where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ decodeUtf8 . BSL.toStrict $ bs instance Deserialize UTCTime where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col let (relDays, relSeconds) = runGet getDate bs pure $ UTCTime (ModifiedJulianDay relDays) (secondsToDiffTime relSeconds) instance Deserialize (Maybe Text) where deserialize res row col = (decodeUtf8 . BSL.toStrict <$>) <$> getBSValue res row col instance Deserialize UUID where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col let mValue = fromByteString bs case mValue of Just value' -> pure value' Nothing -> error "Impossible to decode expected UUID" getPGBool :: Get Bool getPGBool = do w <- getWord8 return $ (fromIntegral w :: Integer) /= 0 instance Deserialize Bool where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col pure $ runGet getPGBool bs instance Deserialize (Maybe Bool) where deserialize res row col = (runGet getPGBool <$>) <$> getBSValue res row col instance Deserialize [Text] where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col let pgArray = runGet getPGArray bs let words8 = fmap pgArrayDataData $ pgArrayData pgArray pure $ (decodeUtf8 . BS.pack) <$> words8 instance Deserialize () where deserialize _ _ _ = pure () genericDeserialize :: (HasEot a, EotDeserialize (Eot a)) => Result -> CInt -> CInt -> IO a genericDeserialize res row col = do resrow <- eotDeserialize res row col pure $ fromEot resrow instance Deserialize A.Value where deserialize res row col = do bs <- (fromMaybe mempty) <$> getBSValue res row col let mValue = A.decode bs :: Maybe A.Value case mValue of Just value' -> pure $ value' Nothing -> error "Impossible to decode JSON"