diff --git a/.gitignore b/.gitignore index b2a2af5..80bd4ac 100644 --- a/.gitignore +++ b/.gitignore @@ -23,6 +23,7 @@ cabal.project.local .HTF/ # Stack .stack-work/ +stack.yaml.lock ### IDE/support # Vim diff --git a/.travis.yml b/.travis.yml index 0024b60..e94d03c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,9 +14,9 @@ cache: matrix: include: - - ghc: 8.6.4 - - - ghc: 8.6.4 + - ghc: 8.6.5 + + - ghc: 8.6.5 env: STACK_YAML="$TRAVIS_BUILD_DIR/stack.yaml" install: diff --git a/postgresql-simple-named.cabal b/postgresql-simple-named.cabal index 4e87f98..316d065 100644 --- a/postgresql-simple-named.cabal +++ b/postgresql-simple-named.cabal @@ -1,8 +1,22 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: postgresql-simple-named version: 0.0.0.0 synopsis: Implementation of named parameters for `postgresql-simple` library -description: Implementation of named parameters for `postgresql-simple` library +description: + Implementation of named parameters for `postgresql-simple` library. + . + Here is an exaple of how it could be used in your code: + . + > queryNamed [sql| + > SELECT * + > FROM table + > WHERE foo = ?foo + > AND bar = ?bar + > AND baz = ?foo + > |] [ "foo" =? "fooBar" + > , "bar" =? "barVar" + > ] + homepage: https://github.com/Holmusk/postgresql-simple-named bug-reports: https://github.com/Holmusk/postgresql-simple-named/issues license: MPL-2.0 @@ -14,19 +28,14 @@ category: Database build-type: Simple extra-doc-files: README.md , CHANGELOG.md -tested-with: GHC == 8.6.4 +tested-with: GHC == 8.6.5 source-repository head type: git location: https://github.com/Holmusk/postgresql-simple-named.git -library - hs-source-dirs: src - exposed-modules: PostgresqlSimpleNamed - - +common common-options build-depends: base ^>= 4.12.0.0 - ghc-options: -Wall -Wincomplete-uni-patterns @@ -53,39 +62,21 @@ library TypeApplications ViewPatterns +library + import: common-options + hs-source-dirs: src + exposed-modules: PgNamed + build-depends: bytestring ^>= 0.10.8 + , mtl ^>= 2.2 + , postgresql-simple ^>= 0.6.2 + , text ^>= 1.2 + test-suite postgresql-simple-named-test + import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-depends: base ^>= 4.12.0.0 - , postgresql-simple-named - - - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields + build-depends: postgresql-simple-named - default-language: Haskell2010 - default-extensions: ConstraintKinds - DeriveGeneric - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/PgNamed.hs b/src/PgNamed.hs new file mode 100644 index 0000000..4b7d2e1 --- /dev/null +++ b/src/PgNamed.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | Introduces named parameters for @postgresql-simple@ library. +It uses @?@ question mark symbol as the indicator of the named parameter which +is replaced with the standard syntax with question marks. Check out the example +of usage: + +@ +queryNamed [sql| + SELECT * + FROM users + WHERE foo = ?foo + AND bar = ?bar + AND baz = ?foo +|] [ "foo" =? "fooBar" + , "bar" =? "barVar" + ] +@ +-} + +module PgNamed + ( NamedParam (..) + , Name (..) + + , extractNames + , namesToRow + , (=?) + ) where + +import Control.Monad.Except (MonadError (throwError)) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import Data.Char (isAlphaNum) +import Data.List (lookup) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import GHC.Exts (IsString) + +import qualified Data.ByteString.Char8 as BS +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.ToField as PG +import qualified Database.PostgreSQL.Simple.Types as PG + +-- | Wrapper over name of the argument. +newtype Name = Name + { unName :: Text + } deriving newtype (Show, Eq, Ord, IsString) + +-- | Data type to represent each named parameter. +data NamedParam = NamedParam + { namedParamName :: !Name + , namedParamParam :: !PG.Action + } deriving (Show) + +-- | @PostgreSQL@ error type for named parameters. +data PgNamedError + -- | Named parameter is not specified. + = PgNamedParam Name + -- | Query has no names inside but was called with named functions, + | PgNoNames PG.Query + -- | Query contains an empty name. + | PgEmptyName PG.Query + + +-- | Type alias for monads that can throw errors of the 'PgNamedError' type. +type WithError = MonadError PgNamedError + +instance Show PgNamedError where + show e = "PostgreSQL named parameter error: " ++ case e of + PgNamedParam n -> "Named parameter '" ++ show n ++ "' is not specified" + PgNoNames (PG.Query q) -> + "Query has no names but was called with named functions: " ++ BS.unpack q + PgEmptyName (PG.Query q) -> + "Query contains an empty name: " ++ BS.unpack q + +-- | Checks whether the 'Name' is in the list and returns its parameter. +lookupName :: Name -> [NamedParam] -> Maybe PG.Action +lookupName n = lookup n . map (\NamedParam{..} -> (namedParamName, namedParamParam)) + +{- | This function takes query with named parameters specified like this: + +@ +SELECT name, user FROM users WHERE id = ?id +@ + +and returns either the error or query with all all names replaced by +questiosn marks @?@ with list of the names in the order of their appearance. + +For example: + +>>> extractNames "SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo" +Right ("SELECT * FROM users WHERE foo = ? AND bar = ? AND baz = ?","foo" :| ["bar","foo"]) +-} +extractNames + :: PG.Query + -> Either PgNamedError (PG.Query, NonEmpty Name) +extractNames qr = go (PG.fromQuery qr) >>= \case + (_, []) -> Left $ PgNoNames qr + (q, name:names) -> Right (PG.Query q, name :| names) + where + go :: ByteString -> Either PgNamedError (ByteString, [Name]) + go str + | BS.null str = Right ("", []) + | otherwise = let (before, after) = BS.break (== '?') str in + case BS.uncons after of + Nothing -> Right (before, []) + Just ('?', nameStart) -> + let (name, remainingQuery) = BS.span isNameChar nameStart + in if BS.null name + then Left $ PgEmptyName qr + else fmap (bimap ((before <> "?") <>) (Name (decodeUtf8 name) :)) + (go remainingQuery) + Just _ -> error "'break (== '?')' doesn't return string started with the question mark" + + isNameChar :: Char -> Bool + isNameChar c = isAlphaNum c || c == '_' + + +-- | Returns the list of values to use in query by given list of 'Name's. +namesToRow + :: forall m . WithError m + => NonEmpty Name -- ^ List of the names used in query + -> [NamedParam] -- ^ List of the named parameters + -> m (NonEmpty PG.Action) +namesToRow names params = traverse magicLookup names + where + magicLookup :: Name -> m PG.Action + magicLookup n = case lookupName n params of + Just x -> pure x + Nothing -> throwError $ PgNamedParam n + +{- | Operator to create 'NamedParam's. + +>>> "foo" =? (1 :: Int) +NamedParam {namedParamName = "foo", namedParamParam = 1} + +So it can be used in creating the list of the named arguments: + +@ +queryNamed [sql| + SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo" +|] [ "foo" =? "fooBar" + , "bar" =? "barVar" + ] +@ +-} +infix 7 =? +(=?) :: (PG.ToField a) => Name -> a -> NamedParam +n =? a = NamedParam n $ PG.toField a +{-# INLINE (=?) #-} diff --git a/src/PostgresqlSimpleNamed.hs b/src/PostgresqlSimpleNamed.hs deleted file mode 100644 index 53e40f5..0000000 --- a/src/PostgresqlSimpleNamed.hs +++ /dev/null @@ -1,6 +0,0 @@ -module PostgresqlSimpleNamed - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn ("someFunc" :: String) diff --git a/stack.yaml b/stack.yaml index 186bebe..a51fcad 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1 @@ -resolver: lts-13.16 - -ghc-options: - "$locals": -fhide-source-paths +resolver: lts-13.27