diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -243,6 +243,151 @@ In order to use these functions, you need to explicitly import their corresponding modules. +### Unsafe functions, operators and values + +Esqueleto doesn't support every possible function, and it can't - many functions aren't available on every RDBMS platform, and sometimes the same functionality is hidden behind different names. To overcome this problem, Esqueleto exports a number of unsafe functions to call any function, operator or value. These functions can be found in Database.Esqueleto.Internal.Sql module. + +Warning: the functions discussed in this section must always be used with an explicit type signature,and the user must be careful to provide a type signature that corresponds correctly with the underlying code. The functions have extremely general types, and if you allow type inference to figure everything out for you, it may not correspond with the underlying SQL types that you want. This interface is effectively the FFI to SQL database, so take care! + +The most common use of these functions is for calling RDBMS specific or custom functions, +for that end we use `unsafeSqlFunction`. For example, if we wish to consult the postgres +`now` function we could so as follow: + +```haskell +postgresTime :: (MonadIO m, MonadLogger m) => SqlWriteT m UTCTime +postgresTime = + result <- select (pure now) + case result of + [x] -> pure x + _ -> error "now() is guaranteed to return a single result" + where + now :: SqlExpr (Value UTCTime) + now = unsafeSqlFunction "now" () +``` + +which generates this SQL: + +```sql +SELECT now() +``` + +With the `now` function we could now use the current time of the postgres RDBMS on any query. +Do notice that `now` does not use any arguments, so we use `()` that is an instance of +`UnsafeSqlFunctionArgument` to represent no arguments, an empty list cast to a correct value +will yield the same result as `()`. + +We can also use `unsafeSqlFunction` for more complex functions with customs values using +`unsafeSqlValue` which turns any string into a sql value of whatever type we want, disclaimer: +if you use it badly you will cause a runtime error. For example, say we want to try postgres' +`date_part` function and get the day of a timestamp, we could use: + +```haskell +postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int +postgresTimestampDay = + result <- select (return $ dayPart date) + case result of + [x] -> pure x + _ -> error "dayPart is guaranteed to return a single result" + where + dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) + dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) + date :: SqlExpr (Value UTCTime) + date = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\'" +``` + +which generates this SQL: + +```sql +SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40') +``` + +Using `unsafeSqlValue` we were required to also define the type of the value. + +Another useful unsafe function is `unsafeSqlCastAs`, which allows us to cast any type +to another within a query. For example, say we want to use our previews `dayPart` function +on the current system time, we could: + +```haskell +postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int +postgresTimestampDay = do + currentTime <- liftIO getCurrentTime + result <- select (return $ dayPart (toTIMESTAMP $ val currentTime)) + case result of + [x] -> pure x + _ -> error "dayPart is guaranteed to return a single result" + where + dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) + dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) + toTIMESTAMP :: SqlExpr (Value UTCTime) -> SqlExpr (Value UTCTime) + toTIMESTAMP = unsafeSqlCastAs "TIMESTAMP" +``` + +which generates this SQL: + +```sql +SELECT date_part('day', CAST('2019-10-28 23:19:39.400898344Z' AS TIMESTAMP)) +``` + +### SQL injection + +Esqueleto uses parameterization to prevent sql injections on values and arguments +on all queries, for example, if we have: + +```haskell +myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () +myEvilQuery = + select (return $ val ("hi\'; DROP TABLE foo; select \'bye\'" :: String)) >>= liftIO . print +``` + +which generates this SQL(when using postgres): + +```sql +SELECT 'hi''; DROP TABLE foo; select ''bye''' +``` + +And the printed value is `hi\'; DROP TABLE foo; select \'bye\'` and no table is dropped. This is good +and makes the use of strings values safe. Unfortunately this is not the case when using unsafe functions. +Let's see an example of defining a new evil `now` function: + +```haskell +myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () +myEvilQuery = + select (return nowWithInjection) >>= liftIO . print + where + nowWithInjection :: SqlExpr (Value UTCTime) + nowWithInjection = unsafeSqlFunction "0; DROP TABLE bar; select now" ([] :: [SqlExpr (Value Int)]) +``` + +which generates this SQL: + +```sql +SELECT 0; DROP TABLE bar; select now() +``` + +If we were to run the above code we would see the postgres time printed but the table `bar` +will be erased with no indication whatsoever. Another example of this behavior is seen when using +`unsafeSqlValue`: + +```haskell +myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () +myEvilQuery = + select (return $ dayPart dateWithInjection) >>= liftIO . print + where + dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) + dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) + dateWithInjection :: SqlExpr (Value UTCTime) + dateWithInjection = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\');DROP TABLE bar; select (16" +``` + +which generates this SQL: + +```sql +SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40');DROP TABLE bar; select (16) +``` + +This will print 16 and also erase the `bar` table. The main take away of this examples is to +never use any user or third party input inside an unsafe function without first parsing it or +heavily sanitizing the input. ### Tests and Postgres diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,17 @@ +3.2.2 +======== + +- @parsonsmatt + - [#161](https://github.com/bitemyapp/esqueleto/pull/161/): Fix an issue where + nested joins didn't get the right on clause. + +3.2.1 +======== + +- @parsonsmatt + - [#159](https://github.com/bitemyapp/esqueleto/pull/159): Add an instance of `UnsafeSqlFunction ()` for 0-argument SQL + functions. + 3.2.0 ======== diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.2.0 +version: 3.2.2 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -64,6 +64,7 @@ import Data.Typeable (Typeable) import Text.Blaze.Html (Html) + import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) -- | (Internal) Start a 'from' query with an entity. 'from' @@ -470,11 +471,11 @@ -> (SqlExpr (Entity val1) -> SqlExpr (Value a)) -- ^ A function to extract a value from the foreign reference table. -> SqlExpr (Value a) -subSelectForeign expr foreignKey with = +subSelectForeign expr foreignKey k = subSelectUnsafe $ from $ \table -> do where_ $ expr ^. foreignKey ==. table ^. persistIdField - pure (with table) + pure (k table) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe, -- because it can throw runtime exceptions in two cases: @@ -1053,12 +1054,12 @@ instance (FinalResult b) => FinalResult (a -> b) where finalR f = finalR (f undefined) --- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You --- can supply just the constructor itself, or a value of the type - the library is capable of figuring +-- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You +-- can supply just the constructor itself, or a value of the type - the library is capable of figuring -- it out from there. -- -- @since 3.1.3 -toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => +toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => a -> UniqueDef toUniqueDef uniqueConstructor = uniqueDef where @@ -1071,9 +1072,9 @@ uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy -- | Render updates to be use in a SET clause for a given sql backend. --- +-- -- @since 3.1.3 -renderUpdates :: (BackendCompatible SqlBackend backend) => +renderUpdates :: (BackendCompatible SqlBackend backend) => backend -> [SqlExpr (Update val)] -> (TLB.Builder, [PersistValue]) @@ -1125,7 +1126,7 @@ | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@ | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@ | FullOuterJoinKind -- ^ @FULL OUTER JOIN@ - deriving Eq + deriving (Eq, Show) -- | (Internal) Functions that operate on types (that should be) @@ -1538,7 +1539,41 @@ | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) +collectIdents :: FromClause -> Set Ident +collectIdents fc = case fc of + FromStart i _ -> Set.singleton i + FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs + OnClause _ -> mempty +instance Show FromClause where + show fc = case fc of + FromStart i _ -> + "(FromStart " <> show i <> ")" + FromJoin lhs jk rhs mexpr -> + mconcat + [ "(FromJoin " + , show lhs + , " " + , show jk + , " " + , case mexpr of + Nothing -> "(no on clause)" + Just expr -> "(" <> render' expr <> ")" + , " " + , show rhs + , ")" + ] + OnClause expr -> + "(OnClause " <> render' expr <> ")" + + + where + dummy = SqlBackend + { connEscapeName = \(DBName x) -> x + } + render' = T.unpack . renderExpr dummy + + -- | A part of a @SET@ clause. newtype SetClause = SetClause (SqlExpr (Value ())) @@ -1551,6 +1586,7 @@ -> [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses sqlBackend = go Set.empty [] + -- . (\fc -> Debug.trace ("From Clauses: " <> show fc) fc) where go is [] (f@(FromStart i _) : fs) = fmap (f:) (go (Set.insert i is) [] fs) -- fast path @@ -1568,6 +1604,7 @@ -> SqlExpr (Value Bool) -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause]) findMatching idents fromClauses expr = + -- Debug.trace ("From Clause: " <> show fromClauses) $ case fromClauses of f : acc -> let @@ -1605,16 +1642,24 @@ <$> tryMatch idents expr r matchL = fmap (\l' -> FromJoin l' k r onClause) <$> tryMatch idents expr l + matchPartial = do + --Debug.traceM $ "matchPartial" + --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause i1 <- findLeftmostIdent l - i2 <- findRightmostIdent r + i2 <- findLeftmostIdent r + let leftIdents = collectIdents l + -- Debug.traceM $ "matchPartial: i1: " <> show i1 + -- Debug.traceM $ "matchPartial: i2: " <> show i2 + -- Debug.traceM $ "matchPartial: idents: " <> show idents guard $ Set.isSubsetOf identsInOnClause - (Set.fromList [i1, i2]) + (Set.fromList [i1, i2] <> leftIdents) guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause - pure (Set.fromList [] <> idents, FromJoin l k r (Just expr)) + pure (idents, FromJoin l k r (Just expr)) + matchC = case onClause of Nothing @@ -2025,6 +2070,13 @@ class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())] + +-- | Useful for 0-argument functions, like @now@ in Postgresql. +-- +-- @since 3.2.1 +instance UnsafeSqlFunctionArgument () where + toArgList _ = [] + instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where toArgList = (:[]) . veryUnsafeCoerceSqlExprValue instance UnsafeSqlFunctionArgument a => diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -35,7 +35,7 @@ import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.Sql -import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), +import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), UnexpectedCaseError(..), SetClause, Ident(..), uncommas, FinalResult(..), toUniqueDef, KnowResult, renderUpdates) @@ -44,7 +44,7 @@ import Data.Int (Int64) import Data.Proxy (Proxy(..)) import Control.Arrow ((***), first) -import Control.Exception (Exception, throw, throwIO) +import Control.Exception (throw) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import qualified Control.Monad.Trans.Reader as R @@ -169,7 +169,7 @@ chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) -now_ = unsafeSqlValue "NOW()" +now_ = unsafeSqlFunction "NOW" () upsert :: (MonadIO m, PersistEntity record, @@ -200,7 +200,7 @@ upsertBy uniqueKey record updates = do sqlB <- R.ask maybe - (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent + (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent (handler sqlB) (connUpsertSql sqlB) where @@ -230,7 +230,7 @@ -- deriving Eq Show -- |] -- --- insertSelectWithConflict +-- insertSelectWithConflict -- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work -- (from $ \b -> -- return $ Foo <# (b ^. BarNum) @@ -240,18 +240,18 @@ -- ) -- @ -- --- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 insertSelectWithConflict :: forall a m val. ( FinalResult a, - KnowResult a ~ (Unique val), - MonadIO m, - PersistEntity val) => + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => a -- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well. - -> SqlQuery (SqlExpr (Insertion val)) + -> SqlQuery (SqlExpr (Insertion val)) -- ^ Insert query. -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates. @@ -263,11 +263,11 @@ -- @since 3.1.3 insertSelectWithConflictCount :: forall a val m. ( FinalResult a, - KnowResult a ~ (Unique val), - MonadIO m, - PersistEntity val) => + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => a - -> SqlQuery (SqlExpr (Insertion val)) + -> SqlQuery (SqlExpr (Insertion val)) -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -> SqlWriteT m Int64 insertSelectWithConflictCount unique query conflictQuery = do @@ -292,7 +292,7 @@ TLB.fromText "ON CONFLICT ON CONSTRAINT \"", constraint, TLB.fromText "\" DO " - ] ++ if null updates then [TLB.fromText "NOTHING"] else [ + ] ++ if null updates then [TLB.fromText "NOTHING"] else [ TLB.fromText "UPDATE SET ", updatesTLB ]),values) diff --git a/test/Common/Test.hs b/test/Common/Test.hs --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -95,6 +95,19 @@ Bar quux FooId deriving Show Eq Ord + Baz + blargh FooId + deriving Show Eq + Shoop + baz BazId + deriving Show Eq + Asdf + shoop ShoopId + deriving Show Eq + Another + why BazId + YetAnother + argh ShoopId Person name String @@ -110,6 +123,9 @@ body String blog BlogPostId deriving Eq Show + CommentReply + body String + comment CommentId Profile name String person PersonId @@ -2152,7 +2168,82 @@ pure (a, b) listsEqualOn a (map (\(x, y) -> (y, x)) b) id + it "works with joins in subselect" $ do + run $ void $ + select $ + from $ \(p `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + pure . (,) (p ^. PersonName) $ + subSelect $ + from $ \(c `InnerJoin` bp) -> do + on $ bp ^. BlogPostId ==. c ^. CommentBlog + pure (c ^. CommentBody) + describe "works with nested joins" $ do + it "unnested" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + it "leftmost nesting" $ do + run $ void $ + selectRethrowingQuery $ + from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + describe "middle nesting" $ do + it "direct association" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + it "indirect association" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + pure (f ^. FooName) + it "indirect association across" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + on $ another ^. AnotherWhy ==. baz ^. BazId + on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId + pure (f ^. FooName) + + describe "rightmost nesting" $ do + it "direct associations" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + + it "indirect association" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure (f ^. FooName) listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn a b f = map f a `shouldBe` map f b diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -25,7 +25,7 @@ import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) import Database.Esqueleto hiding (random_) import qualified Database.Esqueleto.Internal.Sql as ES import Database.Esqueleto.PostgreSQL (random_) @@ -492,6 +492,14 @@ run $ do [Value (ret :: String)] <- select $ return (EP.chr (val 65)) liftIO $ ret `shouldBe` "A" + + it "allows unit for functions" $ do + vals <- run $ do + let + fn :: SqlExpr (Value UTCTime) + fn = ES.unsafeSqlFunction "now" () + select $ pure fn + vals `shouldSatisfy` ((1 ==) . length) it "works with now" $ run $ do