├── .gitignore ├── LICENSE ├── README.md └── validateSql.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Jonathan Curran 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # postgresql-simple-query-validator 2 | Validate SQL statements embedded in postgresql-simple's quasiquoter against a PostgreSQL server. 3 | 4 | # Why this exists 5 | 6 | So I don't have to wait till an integration test or run-time to figure out 7 | whether a query I wrote or modified is valid (syntax and structure). 8 | 9 | Also, swapping '?'s and actual data is a pain. 10 | 11 | **No more SQL syntax errors or incorrect column/table names in source code :)** 12 | 13 | # Requirements 14 | 15 | - [stack](http://docs.haskellstack.org/en/stable/README/) 16 | 17 | # Usage 18 | 19 | `./validateSql.hs src/App/Queries.hs postgresql://user:password@host/dbname` 20 | 21 | Errors, if any, will be printed to stdout and the exit code will be non-zero. 22 | 23 | # Other usage 24 | 25 | - integrate this into your build so that it fails if there is a bad query 26 | - watch for source changes with [entr](http://entrproject.org/), run this 27 | script, and send a notification accordingly with `notify-send` 28 | -------------------------------------------------------------------------------- /validateSql.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | {- stack 3 | --resolver lts-6.2 4 | --install-ghc runghc 5 | --package bytestring 6 | --package megaparsec 7 | --package postgresql-libpq 8 | --package transformers 9 | -} 10 | 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | import Data.ByteString (ByteString) 15 | import qualified Data.ByteString.Char8 as B 16 | import Data.Either (lefts) 17 | import Database.PostgreSQL.LibPQ 18 | import Control.Monad (forM_, zipWithM) 19 | import Control.Monad.IO.Class (liftIO) 20 | import Control.Monad.Trans.Class (lift) 21 | import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) 22 | import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) 23 | import System.Environment (getArgs, getProgName) 24 | import System.Exit (exitFailure, exitSuccess) 25 | import Text.Megaparsec 26 | 27 | main :: IO () 28 | main = 29 | runExceptT (getParams >>= processParams) >>= \case 30 | Left err -> putStrLn err >> exitFailure 31 | Right (qs, conn) -> checkAllQueries conn qs 32 | 33 | getParams :: ExceptT String IO (FilePath, String) 34 | getParams = do 35 | progName <- liftIO getProgName 36 | liftIO getArgs >>= \case 37 | [fname, connstr] -> return (fname, connstr) 38 | _ -> throwE ("Usage: " ++ progName ++ " ") 39 | 40 | processParams :: (FilePath, String) -> ExceptT String IO ([ByteString], Connection) 41 | processParams (fname, connstr) = do 42 | queries <- liftIO $ extractSQL fname 43 | conn <- liftIO $ connectdb (B.pack connstr) 44 | liftIO (status conn) >>= \case 45 | ConnectionOk -> return (queries, conn) 46 | _ -> throwE =<< liftIO (getError conn "Failed to establish connection") 47 | 48 | checkAllQueries :: Connection -> [ByteString] -> IO () 49 | checkAllQueries conn queries = do 50 | results <- zipWithM fn queries [B.pack $ "stmt" ++ show x | x <- [1..]] 51 | forM_ (zip queries results) $ \case 52 | (stmt, Left e) -> B.putStrLn stmt >> putStrLn e 53 | _ -> return () 54 | finish conn 55 | case lefts results of 56 | [] -> exitSuccess 57 | _ -> exitFailure 58 | where 59 | fn stmt stmtName = runExceptT (runReaderT (checkQuery stmt) (conn, stmtName)) 60 | 61 | getError :: Connection -> String -> IO String 62 | getError conn defmsg = 63 | errorMessage conn >>= \case 64 | Just e -> return . B.unpack $ e 65 | Nothing -> return defmsg 66 | 67 | type App = ReaderT (Connection, ByteString) (ExceptT String IO) 68 | 69 | checkQuery :: ByteString -> App () 70 | checkQuery stmt = do 71 | (conn, stmtName) <- ask 72 | liftIO (prepare conn stmtName stmt Nothing) 73 | >>= processResult 74 | >> do (conn, stmtName) <- ask 75 | liftIO (describePrepared conn stmtName) 76 | >>= processResult 77 | 78 | processResult :: Maybe Result -> App () 79 | processResult = \case 80 | Nothing -> lift (throwE "server error") 81 | Just r -> 82 | liftIO (resultStatus r) >>= \case 83 | CommandOk -> return () 84 | _ -> 85 | liftIO (resultErrorMessage r) >>= \case 86 | Nothing -> lift (throwE "server error") 87 | Just e -> lift (throwE $ B.unpack e) 88 | 89 | extractSQL :: FilePath -> IO [ByteString] 90 | extractSQL fname = do 91 | contents <- B.readFile fname 92 | case parse (many $ try extract) fname contents of 93 | Left err -> print err >> exitFailure 94 | Right qs -> return $ map (swapQs . B.pack) qs 95 | where 96 | -- could this be cleaner? 97 | sqlqq = string "[sql|" >> someTill anyChar (string "|]") 98 | extract = manyTill anyChar (try.lookAhead $ string "[sql|") >> sqlqq 99 | swapQs stmt = 100 | let st = B.split '?' stmt in 101 | let ds = [B.pack $ "$" ++ show x | x <- [1..(length st - 1)]] ++ [""] in 102 | B.concat $ zipWith B.append st ds 103 | --------------------------------------------------------------------------------