|
| 1 | +{-# LANGUAGE DerivingStrategies #-} |
| 2 | +{-# LANGUAGE ExistentialQuantification #-} |
| 3 | +{-# LANGUAGE FlexibleContexts #-} |
| 4 | + |
| 5 | +{- | Introduces named parameters for @postgresql-simple@ library. |
| 6 | +It uses @?@ question mark symbol as the indicator of the named parameter which |
| 7 | +is replaced with the standard syntax with question marks. Check out the example |
| 8 | +of usage: |
| 9 | +
|
| 10 | +@ |
| 11 | +queryNamed [sql| |
| 12 | + SELECT * |
| 13 | + FROM users |
| 14 | + WHERE foo = ?foo |
| 15 | + AND bar = ?bar |
| 16 | + AND baz = ?foo |
| 17 | +|] [ "foo" =? "fooBar" |
| 18 | + , "bar" =? "barVar" |
| 19 | + ] |
| 20 | +@ |
| 21 | +-} |
| 22 | + |
| 23 | +module PgNamed |
| 24 | + ( NamedParam (..) |
| 25 | + , Name (..) |
| 26 | + |
| 27 | + , extractNames |
| 28 | + , namesToRow |
| 29 | + , (=?) |
| 30 | + ) where |
| 31 | + |
| 32 | +import Control.Monad.Except (MonadError (throwError)) |
| 33 | +import Data.Bifunctor (bimap) |
| 34 | +import Data.ByteString (ByteString) |
| 35 | +import Data.Char (isAlphaNum) |
| 36 | +import Data.List (lookup) |
| 37 | +import Data.List.NonEmpty (NonEmpty (..)) |
| 38 | +import Data.Text (Text) |
| 39 | +import Data.Text.Encoding (decodeUtf8) |
| 40 | +import GHC.Exts (IsString) |
| 41 | + |
| 42 | +import qualified Data.ByteString.Char8 as BS |
| 43 | +import qualified Database.PostgreSQL.Simple as PG |
| 44 | +import qualified Database.PostgreSQL.Simple.ToField as PG |
| 45 | +import qualified Database.PostgreSQL.Simple.Types as PG |
| 46 | + |
| 47 | +-- | Wrapper over name of the argument. |
| 48 | +newtype Name = Name |
| 49 | + { unName :: Text |
| 50 | + } deriving newtype (Show, Eq, Ord, IsString) |
| 51 | + |
| 52 | +-- | Data type to represent each named parameter. |
| 53 | +data NamedParam = NamedParam |
| 54 | + { namedParamName :: !Name |
| 55 | + , namedParamParam :: !PG.Action |
| 56 | + } deriving (Show) |
| 57 | + |
| 58 | +-- | @PostgreSQL@ error type for named parameters. |
| 59 | +data PgNamedError |
| 60 | + -- | Named parameter is not specified. |
| 61 | + = PgNamedParam Name |
| 62 | + -- | Query has no names inside but was called with named functions, |
| 63 | + | PgNoNames PG.Query |
| 64 | + -- | Query contains an empty name. |
| 65 | + | PgEmptyName PG.Query |
| 66 | + |
| 67 | + |
| 68 | +-- | Type alias for monads that can throw errors of the 'PgNamedError' type. |
| 69 | +type WithError = MonadError PgNamedError |
| 70 | + |
| 71 | +instance Show PgNamedError where |
| 72 | + show e = "PostgreSQL named parameter error: " ++ case e of |
| 73 | + PgNamedParam n -> "Named parameter '" ++ show n ++ "' is not specified" |
| 74 | + PgNoNames (PG.Query q) -> |
| 75 | + "Query has no names but was called with named functions: " ++ BS.unpack q |
| 76 | + PgEmptyName (PG.Query q) -> |
| 77 | + "Query contains an empty name: " ++ BS.unpack q |
| 78 | + |
| 79 | +-- | Checks whether the 'Name' is in the list and returns its parameter. |
| 80 | +lookupName :: Name -> [NamedParam] -> Maybe PG.Action |
| 81 | +lookupName n = lookup n . map (\NamedParam{..} -> (namedParamName, namedParamParam)) |
| 82 | + |
| 83 | +{- | This function takes query with named parameters specified like this: |
| 84 | +
|
| 85 | +@ |
| 86 | +SELECT name, user FROM users WHERE id = ?id |
| 87 | +@ |
| 88 | +
|
| 89 | +and returns either the error or query with all all names replaced by |
| 90 | +questiosn marks @?@ with list of the names in the order of their appearance. |
| 91 | +
|
| 92 | +For example: |
| 93 | +
|
| 94 | +>>> extractNames "SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo" |
| 95 | +Right ("SELECT * FROM users WHERE foo = ? AND bar = ? AND baz = ?","foo" :| ["bar","foo"]) |
| 96 | +-} |
| 97 | +extractNames |
| 98 | + :: PG.Query |
| 99 | + -> Either PgNamedError (PG.Query, NonEmpty Name) |
| 100 | +extractNames qr = go (PG.fromQuery qr) >>= \case |
| 101 | + (_, []) -> Left $ PgNoNames qr |
| 102 | + (q, name:names) -> Right (PG.Query q, name :| names) |
| 103 | + where |
| 104 | + go :: ByteString -> Either PgNamedError (ByteString, [Name]) |
| 105 | + go str |
| 106 | + | BS.null str = Right ("", []) |
| 107 | + | otherwise = let (before, after) = BS.break (== '?') str in |
| 108 | + case BS.uncons after of |
| 109 | + Nothing -> Right (before, []) |
| 110 | + Just ('?', nameStart) -> |
| 111 | + let (name, remainingQuery) = BS.span isNameChar nameStart |
| 112 | + in if BS.null name |
| 113 | + then Left $ PgEmptyName qr |
| 114 | + else fmap (bimap ((before <> "?") <>) (Name (decodeUtf8 name) :)) |
| 115 | + (go remainingQuery) |
| 116 | + Just _ -> error "'break (== '?')' doesn't return string started with the question mark" |
| 117 | + |
| 118 | + isNameChar :: Char -> Bool |
| 119 | + isNameChar c = isAlphaNum c || c == '_' |
| 120 | + |
| 121 | + |
| 122 | +-- | Returns the list of values to use in query by given list of 'Name's. |
| 123 | +namesToRow |
| 124 | + :: forall m . WithError m |
| 125 | + => NonEmpty Name -- ^ List of the names used in query |
| 126 | + -> [NamedParam] -- ^ List of the named parameters |
| 127 | + -> m (NonEmpty PG.Action) |
| 128 | +namesToRow names params = traverse magicLookup names |
| 129 | + where |
| 130 | + magicLookup :: Name -> m PG.Action |
| 131 | + magicLookup n = case lookupName n params of |
| 132 | + Just x -> pure x |
| 133 | + Nothing -> throwError $ PgNamedParam n |
| 134 | + |
| 135 | +{- | Operator to create 'NamedParam's. |
| 136 | +
|
| 137 | +>>> "foo" =? (1 :: Int) |
| 138 | +NamedParam {namedParamName = "foo", namedParamParam = 1} |
| 139 | +
|
| 140 | +So it can be used in creating the list of the named arguments: |
| 141 | +
|
| 142 | +@ |
| 143 | +queryNamed [sql| |
| 144 | + SELECT * FROM users WHERE foo = ?foo AND bar = ?bar AND baz = ?foo" |
| 145 | +|] [ "foo" =? "fooBar" |
| 146 | + , "bar" =? "barVar" |
| 147 | + ] |
| 148 | +@ |
| 149 | +-} |
| 150 | +infix 7 =? |
| 151 | +(=?) :: (PG.ToField a) => Name -> a -> NamedParam |
| 152 | +n =? a = NamedParam n $ PG.toField a |
| 153 | +{-# INLINE (=?) #-} |
0 commit comments