rfc-psql (empty) → 0.0.0.1
raw patch · 6 files changed
+343/−0 lines, 6 filesdep +basedep +bytestringdep +network
Dependencies added: base, bytestring, network, postgresql-typed, resource-pool, rfc-env, rfc-prelude, transformers
Files
- LICENSE +7/−0
- README.md +6/−0
- package.common.yaml +103/−0
- package.yaml +23/−0
- rfc-psql.cabal +59/−0
- src/RFC/Psql.hs +145/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright Robert Fischer (c) 2018++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,6 @@+RFC PostgreSQL Support+=======================++This module provides various utility methods, a monad, and some instances to make operating with `psql` easier.+It specifically leverages [`postgresql-typed`](https://hackage.haskell.org/package/postgresql-typed), because that+provides some reasonable compile-time checking of SQL correctness and parameter/return value type conversions.
+ package.common.yaml view
@@ -0,0 +1,103 @@+- &defaults+ author: Robert Fischer+ maintainer: smokejumperit+rfc@gmail.com+ license: MIT+ license-file: LICENSE++ flags:+ production:+ description: If true, disables failing on warnings and enables aggressive optimizations.+ manual: true+ default: false++ library:+ source-dirs:+ - './src'++ extra-source-files:+ - LICENSE+ - README.md+ - package.yaml+ - package.common.yaml++ default-extensions:+ - ApplicativeDo+ - BangPatterns+ - ConstraintKinds+ - DataKinds+ - DefaultSignatures+ - DeriveFoldable+ - DeriveFunctor+ - DeriveGeneric+ - DeriveLift+ - DeriveTraversable+ - ExistentialQuantification+ - FlexibleContexts+ - FlexibleInstances+ - FunctionalDependencies+ - GADTs+ - GeneralizedNewtypeDeriving+ - InstanceSigs+ - KindSignatures+ - LambdaCase+ - MultiParamTypeClasses+ - MultiWayIf+ - NamedFieldPuns+ - PatternSynonyms+ - RankNTypes+ - ScopedTypeVariables+ - StandaloneDeriving+ - TupleSections+ - TypeApplications+ - TypeFamilies+ - TypeFamilyDependencies+ - TypeOperators + - RebindableSyntax+ - MonadFailDesugaring+ - DisambiguateRecordFields++ ghc-options: + - -Wall+ - -Wcompat + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints + - -fno-max-relevant-binds + - -fprint-potential-instances + - -fprint-explicit-foralls+ - -Wno-missing-monadfail-instances+ - -fno-warn-name-shadowing + - -fno-warn-tabs + - -fno-warn-orphans+ - -Wnoncanonical-monad-instances + - -Wall-missed-specialisations+ - -Wnoncanonical-monadfail-instances + - -Wimplicit-prelude + - -Wmissing-exported-signatures + - -Widentities+ - -j++ when:+ - condition: flag(production)+ then:+ ghc-options:+ - -feager-blackholing + - -funbox-strict-fields + - -fstatic-argument-transformation+ - -flate-dmd-anal + - -fexpose-all-unfoldings + - -fspecialise-aggressively + - -fexcess-precision + - -fmax-simplifier-iterations=15+ - -fsimplifier-phases=4+ - -fstrictness-before=3+ - -funfolding-keeness-factor=1.5+ - -funfolding-use-threshold=150+ else:+ cpp-options:+ - -DDEVELOPMENT+ ghc-options:+ - -freverse-errors+ - -Werror + - -dcore-lint + - -dcmm-lint
+ package.yaml view
@@ -0,0 +1,23 @@+name: rfc-psql+version: 0.0.0.1+synopsis: The PostgreSQL extensions from the Robert Fischer Commons.+description: >+ Provides best-of-breed support for PostgreSQL, currently based on @postgresql-typed@.+category: Database+github: RobertFischer/rfc/rfc-psql+author: Robert Fischer+license: MIT++_common: !include package.common.yaml++<<: *defaults++dependencies:+ - rfc-prelude + - rfc-env+ - base >= 4.10 && < 5+ - postgresql-typed >= 0.5+ - network >= 2.6+ - bytestring >= 0.10+ - resource-pool >= 0.2+ - transformers >= 0.5
+ rfc-psql.cabal view
@@ -0,0 +1,59 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: a736beda20ae1b361d838478aa37d4c9c9c20453ed9504625f99979cd565eb45++name: rfc-psql+version: 0.0.0.1+synopsis: The PostgreSQL extensions from the Robert Fischer Commons.+description: Provides best-of-breed support for PostgreSQL, currently based on @postgresql-typed@.+category: Database+homepage: https://github.com/RobertFischer/rfc#readme+bug-reports: https://github.com/RobertFischer/rfc/issues+author: Robert Fischer+maintainer: smokejumperit+rfc@gmail.com+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ LICENSE+ package.common.yaml+ package.yaml+ README.md++source-repository head+ type: git+ location: https://github.com/RobertFischer/rfc+ subdir: rfc-psql++flag production+ description: If true, disables failing on warnings and enables aggressive optimizations.+ manual: True+ default: False++library+ exposed-modules:+ RFC.Psql+ other-modules:+ Paths_rfc_psql+ hs-source-dirs:+ ./src+ default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators RebindableSyntax MonadFailDesugaring DisambiguateRecordFields+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-max-relevant-binds -fprint-potential-instances -fprint-explicit-foralls -Wno-missing-monadfail-instances -fno-warn-name-shadowing -fno-warn-tabs -fno-warn-orphans -Wnoncanonical-monad-instances -Wall-missed-specialisations -Wnoncanonical-monadfail-instances -Wimplicit-prelude -Wmissing-exported-signatures -Widentities -j+ build-depends:+ base >=4.10 && <5+ , bytestring >=0.10+ , network >=2.6+ , postgresql-typed >=0.5+ , resource-pool >=0.2+ , rfc-env+ , rfc-prelude+ , transformers >=0.5+ if flag(production)+ ghc-options: -feager-blackholing -funbox-strict-fields -fstatic-argument-transformation -flate-dmd-anal -fexpose-all-unfoldings -fspecialise-aggressively -fexcess-precision -fmax-simplifier-iterations=15 -fsimplifier-phases=4 -fstrictness-before=3 -funfolding-keeness-factor=1.5 -funfolding-use-threshold=150+ else+ ghc-options: -freverse-errors -Werror -dcore-lint -dcmm-lint+ cpp-options: -DDEVELOPMENT+ default-language: Haskell2010
+ src/RFC/Psql.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module RFC.Psql+ ( module Database.PostgreSQL.Typed+ , module Database.PostgreSQL.Typed.Array+ , module Database.PostgreSQL.Typed.Query+ , module Database.PostgreSQL.Typed.Types+ , module Database.PostgreSQL.Typed.TH+ , module RFC.Psql+ , module Network+ ) where++import Control.Monad.Trans.Class ( MonadTrans (..) )+import Control.Monad.Trans.Reader ( ask )+import qualified Data.ByteString.Char8 as C8+import Data.Pool+import Database.PostgreSQL.Typed+import Database.PostgreSQL.Typed.Array+import Database.PostgreSQL.Typed.Query+import Database.PostgreSQL.Typed.TH+import Database.PostgreSQL.Typed.Types+import Network ( PortID (PortNumber) )+import qualified RFC.Data.UUID as UUID+import qualified RFC.Env as Env+import RFC.Prelude hiding ( ask )++type PGConnectionPool = Pool PGConnection+type ConnectionPool = PGConnectionPool++class HasPsql m where+ withPsqlConnection :: (PGConnection -> IO a) -> m a++instance {-# OVERLAPPABLE #-} (MonadTrans t, Monad m, HasPsql m) => HasPsql (t m) where+ withPsqlConnection :: (PGConnection -> IO a) -> (t m) a+ withPsqlConnection = lift . withPsqlConnection++instance {-# OVERLAPS #-} (MonadIO m) => HasPsql (ReaderT PGConnectionPool m) where+ withPsqlConnection :: (PGConnection -> IO a) -> ReaderT PGConnectionPool m a+ withPsqlConnection action = do+ pool <- ask+ liftIO $ withResource pool action+ {-# INLINE withPsqlConnection #-}+ {-# SPECIALIZE instance HasPsql (ReaderT PGConnectionPool IO) #-}++instance {-# OVERLAPS #-} (MonadIO m) => HasPsql (ReaderT PGConnection m) where+ withPsqlConnection :: (PGConnection -> IO a) -> ReaderT PGConnection m a+ withPsqlConnection action = do+ conn <- ask+ liftIO $ action conn+ {-# INLINE withPsqlConnection #-}+ {-# SPECIALIZE instance HasPsql (ReaderT PGConnection IO) #-}++liftHasPsql :: (PGConnection -> IO a) -> ReaderT PGConnection IO a+liftHasPsql = ReaderT+{-# INLINE liftHasPsql #-}++withPsqlTransaction :: (HasPsql psql) => (ReaderT PGConnection IO a) -> psql a+withPsqlTransaction action = withPsqlConnection $ \conn ->+ pgTransaction conn $ runReaderT action conn+{-# INLINABLE withPsqlTransaction #-}++instance {-# OVERLAPPING #-} Env.DefConfig PGDatabase where+ defConfig = defaultPGDatabase+ {-# INLINE defConfig #-}++instance Env.FromEnv PGDatabase where+ fromEnv = PGDatabase <$> Env.env "PSQL_HOST"+ <*> Env.env "PSQL_PORT"+ <*> Env.env "PSQL_DATABASE"+ <*> Env.env "PSQL_USERNAME"+ <*> Env.env "PSQL_PASSWORD"+ <*> pure []+ <*> pure Env.isDevelopment+ <*> pure (+ if Env.isDevelopment then+ print . PGError+ else+ const $ return ()+ )+ {-# INLINE fromEnv #-}+++defaultConnectInfo :: (MonadIO m, MonadFail m) => m PGDatabase+defaultConnectInfo = do+ result <- liftIO Env.decodeEnv+ case result of+ Left err -> fail $ "Could not retrieve psql connection info: " <> err+ Right connInfo -> return connInfo+{-# INLINE defaultConnectInfo #-}++createConnectionPool :: (MonadIO m) => PGDatabase -> m PGConnectionPool+createConnectionPool connInfo = liftIO $+ createPool connect close 1 10 100+ where+ connect = pgConnect connInfo+ close = pgDisconnect+{-# INLINE createConnectionPool #-}++query :: (HasPsql m, PGQuery q a) => q -> m [a]+query q = withPsqlConnection $ \conn -> liftIO $ pgQuery conn q+{-# INLINE query #-}++query1 :: (MonadIO m, HasPsql m, PGQuery q a) => q -> m (Maybe a)+query1 qry = safeHead <$> query qry+{-# INLINE query1 #-}++query1Else :: (MonadIO m, HasPsql m, PGQuery q a, Exception e) => q -> e -> m (Maybe a)+query1Else qry e = do+ result <- query1 qry+ case result of+ (Just _) -> return result+ Nothing -> throwIO e+{-# INLINE query1Else #-}++execute :: (HasPsql m, PGQuery q ()) => q -> m Int+execute q = withPsqlConnection $ \conn -> liftIO $ pgExecute conn q+{-# INLINE execute #-}++execute_ :: (MonadIO m, HasPsql m, PGQuery q ()) => q -> m ()+execute_ = void . execute+{-# INLINE execute_ #-}++instance {-# OVERLAPPING #-} PGType "style" where+ type PGVal "style" = StrictText+ pgBinaryColumn _ _ = True++instance {-# OVERLAPPING #-} PGStringType "style"++instance {-# OVERLAPPING #-} PGColumn "uuid[]" [UUID] where+ pgDecode _ sbs =+ let (sbsList::[StrictByteString]) = C8.split (pgArrayDelim pgTypePxy) sbs in+ let strList = catMaybes $ fromUTF8 <$> sbsList in+ let uuidList = catMaybes $ UUID.fromString <$> strList in+ uuidList+ where+ pgTypePxy = PGTypeProxy :: PGTypeID "uuid[]"+