Create executable and cabal file

.gitignore

@@ -16,4 +16,3 @@ cabal.sandbox.config
 *.hp
 *.eventlog
 .stack-work/
-cabal.project.local

package.yaml

@@ -0,0 +1,25 @@
+name:                postgresql-simple-query-validator
+version:             0.1.0.0
+github:              "assertible/assertible"
+author:              "Jonathan Curran"
+maintainer:          "[email protected]"
+copyright:           "Copyright (c) 2016, Jonathan Curran <[email protected]>"
+
+executables:
+  postgresql-simple-query-validator:
+    main: validateSql.hs
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+      - -Wall
+      - -fno-warn-unused-do-bind
+      - -fwarn-incomplete-uni-patterns
+      - -fwarn-incomplete-record-updates
+    dependencies:
+      - base
+      - bytestring
+      - transformers
+      - megaparsec
+      - parser-combinators
+      - postgresql-libpq

postgresql-simple-query-validator.cabal

@@ -0,0 +1,34 @@
+-- This file has been generated from package.yaml by hpack version 0.28.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: a5ce8b228e275e948784079c5272e0cc3b774e143ce6f4a6ea72a65bcd121f47
+
+name:           postgresql-simple-query-validator
+version:        0.1.0.0
+homepage:       https://github.com/assertible/assertible#readme
+bug-reports:    https://github.com/assertible/assertible/issues
+author:         Jonathan Curran
+maintainer:     [email protected]
+copyright:      Copyright (c) 2016, Jonathan Curran <[email protected]>
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
+
+source-repository head
+  type: git
+  location: https://github.com/assertible/assertible
+
+executable postgresql-simple-query-validator
+  main-is: validateSql.hs
+  other-modules:
+      Paths_postgresql_simple_query_validator
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
+  build-depends:
+      base
+    , bytestring
+    , megaparsec
+    , parser-combinators
+    , postgresql-libpq
+    , transformers
+  default-language: Haskell2010

stack.yaml

@@ -0,0 +1,7 @@
+
+resolver: lts-11.22
+
+extra-deps: []
+
+packages:
+  - '.'

validateSql.hs

@@ -1,33 +1,36 @@
 #!/usr/bin/env stack
 {- stack
-   --resolver lts-6.2
    --install-ghc runghc
    --package bytestring
    --package megaparsec
    --package postgresql-libpq
    --package transformers
 -}
-
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-import           Data.ByteString            (ByteString)
-import qualified Data.ByteString.Char8      as B
-import           Data.Either                (lefts)
-import           Database.PostgreSQL.LibPQ
+module Main where
+
 import           Control.Monad              (forM_, zipWithM)
 import           Control.Monad.IO.Class     (liftIO)
 import           Control.Monad.Trans.Class  (lift)
 import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import           Data.ByteString            (ByteString)
+import qualified Data.ByteString.Char8      as B
+import           Data.Either                (lefts)
+import           Database.PostgreSQL.LibPQ  hiding (fname)
 import           System.Environment         (getArgs, getProgName)
-import           System.Exit                (exitFailure, exitSuccess)
+import           System.Exit                (ExitCode (..), exitFailure,
+                                             exitSuccess, exitWith)
 import           Text.Megaparsec
+import           Text.Megaparsec.Char
+
 
 main :: IO ()
 main =
   runExceptT (getParams >>= processParams) >>= \case
-    Left err -> putStrLn err >> exitFailure
+    Left err -> putStrLn err >> exitWith (ExitFailure 255)
     Right (qs, conn) -> checkAllQueries conn qs
 
 getParams :: ExceptT String IO (FilePath, String)
@@ -47,12 +50,13 @@ processParams (fname, connstr) = do
 
 checkAllQueries :: Connection -> [ByteString] -> IO ()
 checkAllQueries conn queries = do
-  results <- zipWithM fn queries [B.pack $ "stmt" ++ show x | x <- [1..]]
-  forM_ (zip queries results) $ \case
+  results <- zipWithM fn queries [B.pack $ "stmt" ++ show x | x <- [(1::Int)..]]
+  let cleanResults = filter ((/=) (Left "ignore")) results
+  forM_ (zip queries cleanResults) $ \case
     (stmt, Left e) -> B.putStrLn stmt >> putStrLn e
     _ -> return ()
   finish conn
-  case lefts results of
+  case lefts cleanResults of
     [] -> exitSuccess
     _  -> exitFailure
   where
@@ -84,17 +88,23 @@ processResult = \case
       _ ->
         liftIO (resultErrorMessage r) >>= \case
           Nothing -> lift (throwE "server error")
-          Just e  -> lift (throwE $ B.unpack e)
+          Just e  -> if "multiple commands into a prepared statement" `B.isInfixOf` e then
+                         lift (throwE "ignore")
+                     else
+                         lift (throwE $ B.unpack e)
+
+type Parser = Parsec String String
 
 extractSQL :: FilePath -> IO [ByteString]
 extractSQL fname = do
   contents <- B.readFile fname
-  case parse (many $ try extract) fname contents of
+  case parse (many $ try extract) fname (B.unpack contents) of
     Left err -> print err >> exitFailure
     Right qs -> return $ map (swapQs . B.pack) qs
   where
-    -- could this be cleaner?
+    sqlqq :: Parser String
     sqlqq = string "[sql|" >> someTill anyChar (string "|]")
+    extract :: Parser String
     extract = manyTill anyChar (try.lookAhead $ string "[sql|") >> sqlqq
     swapQs stmt =
       let st = B.split '?' stmt in