sqlite-simple-errors (empty) → 0.1.0.0
raw patch · 9 files changed
+336/−0 lines, 9 filesdep +basedep +mtldep +parsecsetup-changed
Dependencies added: base, mtl, parsec, sqlite-simple, sqlite-simple-errors, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- sqlite-simple-errors.cabal +43/−0
- src/Database/SQLite/SimpleErrors.hs +34/−0
- src/Database/SQLite/SimpleErrors/Parser.hs +42/−0
- src/Database/SQLite/SimpleErrors/Types.hs +20/−0
- test/SQLUtils.hs +27/−0
- test/Spec.hs +63/−0
- test/Utils.hs +75/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Joe Canero (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Joe Canero nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sqlite-simple-errors.cabal view
@@ -0,0 +1,43 @@+name: sqlite-simple-errors+version: 0.1.0.0+synopsis: Wrapper around errors from sqlite-simple+description: Wrapper around errors from sqlite-simple+homepage: https://github.com/caneroj1/sqlite-simple-errors+license: BSD3+license-file: LICENSE+author: Joe Canero+maintainer: jmc41493@gmail.com+copyright: Copyright: (c) 2016 Joe Canero+category: Database+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Database.SQLite.SimpleErrors+ , Database.SQLite.SimpleErrors.Parser+ , Database.SQLite.SimpleErrors.Types+ build-depends: base >= 4.7 && < 5+ , sqlite-simple+ , text+ , parsec+ default-language: Haskell2010++test-suite sqlite-simple-errors-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ other-modules: Utils+ , SQLUtils+ main-is: Spec.hs+ build-depends: base+ , sqlite-simple-errors+ , sqlite-simple+ , text+ , mtl+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/caneroj1/sqlite-simple-errors
+ src/Database/SQLite/SimpleErrors.hs view
@@ -0,0 +1,34 @@+module Database.SQLite.SimpleErrors+(+ DatabaseResponse+, runDBAction+) where++import Control.Exception+import Database.SQLite.Simple (FormatError, ResultError, SQLError)+import Database.SQLite.SimpleErrors.Types+import Database.SQLite.SimpleErrors.Parser++type DatabaseResponse a = Either SQLiteResponse a++runDBAction :: IO a -> IO (DatabaseResponse a)+runDBAction sqlAction = do+ res <- try sqlAction+ case res of+ (Left e) -> return . Left $ convertException e+ (Right e) -> return $ Right e++convertException :: SomeException -> SQLiteResponse+convertException se = handleResultError se $ fromException se++handleResultError :: SomeException -> Maybe ResultError -> SQLiteResponse+handleResultError se Nothing = handleFormatError se (fromException se)+handleResultError _ (Just e) = SQLResultError e++handleFormatError :: SomeException -> Maybe FormatError -> SQLiteResponse+handleFormatError se Nothing = handleSQLError se (fromException se)+handleFormatError _ (Just e) = SQLFormatError e++handleSQLError :: SomeException -> Maybe SQLError -> SQLiteResponse+handleSQLError se Nothing = throw se+handleSQLError _ (Just e) = receiveSQLError e
+ src/Database/SQLite/SimpleErrors/Parser.hs view
@@ -0,0 +1,42 @@+module Database.SQLite.SimpleErrors.Parser where++import Control.Monad+import Data.Text (Text)+import qualified Data.Text as Text hiding (Text)+import Database.SQLite.Simple+import Database.SQLite.SimpleErrors.Types+import Text.Parsec+import Text.Parsec.Text++type SQLiteParser = Parser SQLiteResponse++constraintNameOnly :: String -> Parser ()+constraintNameOnly n = void $ string (n ++ " constraint failed")++constraintName :: String -> Parser ()+constraintName n = constraintNameOnly n >> char ':' >> spaces++getRest :: Parser Text+getRest = Text.pack <$> many1 anyChar++parseConstraint :: String -> Constraint -> SQLiteParser+parseConstraint n c = constraintName n >> SQLConstraintError c <$> getRest++parseConstraintNoDetails :: String -> Constraint -> SQLiteParser+parseConstraintNoDetails n c =+ constraintNameOnly n >> return (SQLConstraintError c Text.empty)++constraintParser :: Parsec Text () SQLiteResponse+constraintParser =+ parseConstraintNoDetails "FOREIGN KEY" ForeignKey <|>+ parseConstraint "NOT NULL" NotNull <|>+ parseConstraint "UNIQUE" Unique <|>+ parseConstraint "CHECK" Check++parseError :: SQLError -> SQLiteResponse+parseError e@SQLError{sqlErrorDetails = details} =+ either (\_ -> SQLOtherError e) id $ parse constraintParser "" details++receiveSQLError :: SQLError -> SQLiteResponse+receiveSQLError e@SQLError{sqlError = ErrorConstraint} = parseError e+receiveSQLError e = SQLOtherError e
+ src/Database/SQLite/SimpleErrors/Types.hs view
@@ -0,0 +1,20 @@+module Database.SQLite.SimpleErrors.Types where++import Control.Exception+import Data.Text (Text)+import Data.Typeable+import Database.SQLite.Simple (FormatError, ResultError, SQLError)++data Constraint = NotNull+ | ForeignKey+ | Unique+ | Check+ deriving (Show, Eq)++data SQLiteResponse = SQLConstraintError Constraint Text+ | SQLFormatError FormatError+ | SQLResultError ResultError+ | SQLOtherError SQLError+ deriving (Show, Eq, Typeable)++instance Exception SQLiteResponse
+ test/SQLUtils.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module SQLUtils where++import Database.SQLite.Simple+import Database.SQLite.Simple.ToField+import Data.Text (Text)++createTableSQL :: Query+createTableSQL =+ "CREATE TABLE if not exists Test (name varchar(50) NOT NULL UNIQUE\+ \ ,age int NOT NULL CHECK(age > 0) \+ \ ,id integer PRIMARY KEY NOT NULL); "++createNextTableSQL :: Query+createNextTableSQL =+ "CREATE TABLE if not exists Next (label varchar(10) \+ \ ,test_id int NOT NULL \+ \ ,FOREIGN KEY(test_id) REFERENCES Test(id));"++insertSQL :: Query+insertSQL =+ "INSERT INTO Test (name, age) VALUES (?, ?)"++insertOtherSQL :: Query+insertOtherSQL =+ "INSERT INTO Next (label, test_id) VALUES (?, ?)"
+ test/Spec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Text (Text)+import Database.SQLite.Simple+import Database.SQLite.Simple.ToField+import Database.SQLite.SimpleErrors+import Database.SQLite.SimpleErrors.Types+import SQLUtils+import Utils++main :: IO ()+main = executeTestRunner [checkNotNullConstraintName,+ checkNotNullConstraintAge,+ checkUniqueConstraint,+ checkCheckConstraint,+ checkForeignKeyConstraint]++checkNotNullConstraintName :: Test (DatabaseResponse ())+checkNotNullConstraintName = Test "Not Null Constraint - Name"+ (Left $ SQLConstraintError NotNull "Test.name")+ test+ where test conn = runDBAction $ execute conn insertSQL sqlData+ sqlData :: (Maybe Text, Int)+ sqlData = (Nothing, 10)++checkNotNullConstraintAge :: Test (DatabaseResponse ())+checkNotNullConstraintAge = Test "Not Null Constraint - Age"+ (Left $ SQLConstraintError NotNull "Test.age")+ test+ where test conn = runDBAction $ execute conn insertSQL sqlData+ sqlData :: (Text, Maybe Int)+ sqlData = ("name", Nothing)++checkUniqueConstraint :: Test (DatabaseResponse ())+checkUniqueConstraint = Test "Unique Constraint - Name"+ (Left $ SQLConstraintError Unique "Test.name")+ test+ where+ test conn =+ runDBAction (execute conn insertSQL sqlData) >>+ runDBAction (execute conn insertSQL sqlData)+ sqlData :: (Text, Int)+ sqlData = ("name", 10)++checkCheckConstraint :: Test (DatabaseResponse ())+checkCheckConstraint = Test "Check Constraint - Age"+ (Left $ SQLConstraintError Check "Test")+ test+ where+ test conn = runDBAction $ execute conn insertSQL sqlData+ sqlData :: (Text, Int)+ sqlData = ("name", 0)++checkForeignKeyConstraint :: Test (DatabaseResponse ())+checkForeignKeyConstraint = Test "Check Foreign Key Constraint - TestID"+ (Left $ SQLConstraintError ForeignKey "")+ test+ where+ test conn = runDBAction $ execute conn insertOtherSQL sqlData+ sqlData :: (Text, Int)+ sqlData = ("other", 10)
+ test/Utils.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Utils+(+ Test(..)+, executeTestRunner+)where++import Control.Monad.State+import Database.SQLite.Simple (open, close, execute_, Connection)+import SQLUtils++data Test a = Test {+ testName :: String+, expects :: a+, testAction :: Connection -> IO a+}++data Results = Results {+ passed :: Int+, failed :: Int+}++instance Show Results where+ show Results{..} =+ "\nResults" +++ "\n-------" +++ "\npassed: " ++ show passed ++ "/" ++ show total +++ "\nfailed: " ++ show failed ++ "/" ++ show total+ where total = passed + failed++empty :: Results+empty = Results 0 0++logResult :: Bool -> Results -> Results+logResult True results = results{passed = passed results + 1}+logResult False results = results{failed = failed results + 1}++newtype TestRunner a = TestRunner {+ runSuite :: StateT Results IO a+} deriving (Monad, Functor, Applicative, MonadState Results, MonadIO)++executeTestRunner :: (Eq a, Show a) => [Test a] -> IO ()+executeTestRunner tests = print =<< execStateT (runSuite $ runTests tests) empty++setupDB :: Connection -> IO ()+setupDB conn = execute_ conn createTableSQL >>+ execute_ conn createNextTableSQL >>+ execute_ conn "PRAGMA foreign_keys = ON"++runTests :: (Eq a, Show a) => [Test a] -> TestRunner ()+runTests [] = liftIO $ putStrLn "Done with tests"+runTests (test:tests) = do+ conn <- liftIO $ open ":memory:"+ liftIO $ setupDB conn+ got <- liftIO $ testAction test conn+ liftIO $ close conn+ logResults got test+ runTests tests+ where+ logResults :: (Show a, Eq a) => a -> Test a -> TestRunner ()+ logResults got Test{..} = do+ liftIO $ do+ putStrLn "\n"+ print testName+ unless passed $ do+ putStr "Expected: " >> print expects+ putStr "Got: " >> print got+ putStrLn "----------"+ putStrLn $ "Passed: " ++ show passed+ modify (logResult passed)+ where+ passed = expects == got