diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 + +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 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pasta.cabal b/pasta.cabal new file mode 100644 --- /dev/null +++ b/pasta.cabal @@ -0,0 +1,46 @@ +name: pasta +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/githubuser/pasta#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2015 Author Here +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Pasta + other-modules: Pasta.Types + build-depends: base >= 4.7 && < 5 + , microlens >= 0.4 && < 0.5 + , microlens-th >= 0.3 && < 0.5 + , text >= 1.2 && < 1.3 + , text-show >= 2.1 && < 2.2 + , semigroups >= 0.18 + , protolude >= 0.1 + default-language: Haskell2010 + default-extensions: OverloadedStrings, ScopedTypeVariables, TemplateHaskell, NoImplicitPrelude + +test-suite pasta-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base >= 4.7 && < 5 + , pasta + , hspec >= 2.2 + , microlens + , protolude >= 0.1 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude + +source-repository head + type: git + location: https://github.com/diogob/pasta diff --git a/src/Pasta.hs b/src/Pasta.hs new file mode 100644 --- /dev/null +++ b/src/Pasta.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-| +Module : Pasta +Description : Assembles SQL statements +-} +module Pasta + ( target + , assignments + , conditions + , insert + , columns + , values + , update + , delete + , returning + , onConflict + , doNothing + , doUpdate + , (.=) + , (//) + , select + , selectExp + , selectFrom + , selectFunction + , t + , f + , relations + , toSQL + , NonEmpty (..) + , fromList + , Expression(Null) + , BooleanExpression(Not, In) + , (.|) + , (.&) + , (.!) + , cmp + , eq + , gt + , lt + , gte + , lte + , fn + , now + , age + ) where + +import Protolude hiding ((&)) +import Pasta.Types +import Lens.Micro +import Lens.Micro.TH +import Data.List.NonEmpty (NonEmpty(..), fromList) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + +makeFields ''Select +makeFields ''Update +makeFields ''Delete +makeFields ''Insert + +-- | Builds a SELECT null with neither FROM nor WHERE clauses. +select :: Select +select = Select (Column Null :| []) [] t + +-- | Builds a SELECT * FROM table statement. +selectFrom :: Name -> Select +selectFrom table = select & columns .~ ("*" :| []) & relations .~ [FromRelation (NameExp table) table] + +-- | Builds a SELECT expression with neither FROM nor WHERE clauses +selectExp :: Expression -> Select +selectExp expr = select & columns .~ (Column expr :| []) + +-- | Builds a SELECT fn(parameters) with neither FROM nor WHERE clauses +selectFunction :: Identifier -> [Expression] -> Select +selectFunction fnId parameters = selectExp $ fn fnId parameters + +-- | Builds an INSERT statement using a target, a non-empty list of column names and a non-empty list of values +insert :: T.Text -> NonEmpty T.Text -> NonEmpty T.Text -> Insert +insert trg cols vals = Insert (Identifier schema table) colNames valExps Nothing + where + (schema, table) = splitTarget trg + colNames = Name <$> cols + valExps = (LitExp . Literal) <$> vals + +-- | Builds an UPDATE statement using a target, a non-empty list of column names and a non-empty list of values +update :: T.Text -> NonEmpty T.Text -> NonEmpty Expression -> Update +update trg cols vals = Update (Identifier schema table) assigns t [] + where + (schema, table) = splitTarget trg + assigns = NE.zipWith Assignment (Name <$> cols) vals + +-- | Builds a DELETE statement using a target +delete :: T.Text -> Delete +delete trg = Delete (schema//table) t [] + where + (schema, table) = splitTarget trg + +-- | Builds a BooleanExpression out of an operator and 2 expressions +cmp :: (IsExpression lexp, IsExpression rexp) => Text -> lexp -> rexp -> BooleanExpression +cmp op lexp rexp = Comparison (Operator op) (toExp lexp) (toExp rexp) + +-- | Builds a equality comparison out of two expressions +eq :: (IsExpression lexp, IsExpression rexp) => lexp -> rexp -> BooleanExpression +eq = cmp "=" + +-- | Builds a greater than comparison out of two expressions +gt :: (IsExpression lexp, IsExpression rexp) => lexp -> rexp -> BooleanExpression +gt = cmp ">" + +-- | Builds a lesser than comparison out of two expressions +lt :: (IsExpression lexp, IsExpression rexp) => lexp -> rexp -> BooleanExpression +lt = cmp "<" + +-- | Builds a greater than or equal comparison out of two expressions +gte :: (IsExpression lexp, IsExpression rexp) => lexp -> rexp -> BooleanExpression +gte = cmp ">=" + +-- | Builds a lesser than or equal comparison out of two expressions +lte :: (IsExpression lexp, IsExpression rexp) => lexp -> rexp -> BooleanExpression +lte = cmp "<=" + +-- | Builds a function +fn :: Identifier -> [Expression] -> Expression +fn = FunctionExp + +-- | Builds a now() function +now :: Expression +now = fn ("pg_catalog"//"now") [] + +-- | Builds an age(t) function +age :: IsExpression exp => exp -> Expression +age time = fn ("pg_catalog"//"age") [toExp time] + + +-- | Just a convenient way to write a BoolLiteral True +t :: BooleanExpression +t = BoolLiteral True + +-- | Just a convenient way to write a BoolLiteral False +f :: BooleanExpression +f = BoolLiteral False + +-- | Used for conflict resolution when we don't want the conflict to trigger any exception +doNothing :: Maybe Conflict +doNothing = Just $ Conflict Nothing DoNothing + +-- | Used for conflict resolution when we want the conflict to update some column +doUpdate :: ConflictTarget -> [Assignment] -> Maybe Conflict +doUpdate _ [] = Nothing +doUpdate trg assigns = + Just $ + Conflict (Just trg) $ + DoUpdate (fromList assigns) t + +-- | Assignment operator creates SQL assignments like in conflict resolution rules +(.=) :: IsExpression exp => Name -> exp -> Assignment +(.=) e ex = Assignment e $ toExp ex + +-- | Identifier builder, takes two names and builds a qualified identifier (e.g. "information_schema"."tables") +(//) :: Name -> Name -> Identifier +(//) = Identifier + +-- | Boolean OR +(.|) :: BooleanExpression -> BooleanExpression -> BooleanExpression +(.|) = Or + +-- | Boolean AND +(.&) :: BooleanExpression -> BooleanExpression -> BooleanExpression +(.&) = And + +-- | Boolean NOT +infixr 0 .! +(.!) :: BooleanExpression -> BooleanExpression +(.!) = Not + +-- private functions + +splitTarget :: T.Text -> (Name, Name) +splitTarget trg = (schema, table) + where + qId = Name <$> T.split (=='.') trg + schema = case qId of + [s, _] -> s + _ -> "public" + table = case qId of + [_, tbl] -> tbl + [tbl] -> tbl + _ -> "" diff --git a/src/Pasta/Types.hs b/src/Pasta/Types.hs new file mode 100644 --- /dev/null +++ b/src/Pasta/Types.hs @@ -0,0 +1,279 @@ +module Pasta.Types + ( BooleanExpression (..) + , Expression (..) + , Select (..) + , FromRelation (..) + , Column (..) + , Update (..) + , Delete (..) + , Insert (..) + , Name (..) + , Identifier (..) + , Literal (..) + , Conflict (..) + , ConflictTarget (..) + , ConflictAction (..) + , Assignment (..) + , Operator (..) + , IsExpression (..) + , IsSQL (..) + ) where + +import Protolude hiding (toList) +import Data.Function (id) +import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.String (fromString) +import qualified Data.Text as T +import TextShow (TextShow, fromText, showb, showt) + +-- Base types +newtype Operator = Operator T.Text deriving (Eq, Show) +newtype Literal = Literal T.Text deriving (Eq, Show) +newtype Name = Name T.Text deriving (Eq, Show) + +class IsSQL a where + toSQL :: a -> Text + +instance IsSQL Select where + toSQL = showt +instance IsSQL Update where + toSQL = showt +instance IsSQL Delete where + toSQL = showt +instance IsSQL Insert where + toSQL = showt + +class IsExpression a where + toExp :: a -> Expression + +instance IsExpression Expression where + toExp = id + +instance IsExpression Identifier where + toExp = IdentifierExp + +instance IsExpression Literal where + toExp = LitExp + +instance IsExpression Text where + toExp = LitExp . Literal + +data Identifier = Identifier + { _qualifier :: Name + , _identifier :: Name + } deriving (Eq, Show) + +instance TextShow Literal where + showb (Literal e) = fromText (pgFmtLit e) + +instance IsString Literal where + fromString = Literal . fromString + +instance TextShow Name where + showb (Name "*") = "*" + showb (Name "EXCLUDED") = "EXCLUDED" + showb (Name c) = fromText $ pgFmtIdent c + +instance TextShow Operator where + showb (Operator op) = fromText op + +instance IsString Name where + fromString = Name . fromString + +instance TextShow Identifier where + showb (Identifier e1 e2) = showb e1 <> "." <> showb e2 + +-- Select Types +data BooleanExpression = Or BooleanExpression BooleanExpression + | And BooleanExpression BooleanExpression + | Not BooleanExpression + | BoolLiteral Bool + | Exists Select + | In Identifier Select + | Comparison Operator Expression Expression + deriving (Eq, Show) + +data Expression = IdentifierExp Identifier + | BoolExp BooleanExpression + | OperatorExp Expression Operator Expression + | FunctionExp Identifier [Expression] + | QueryExp Select + | LitExp Literal + | NameExp Name + | Null + deriving (Eq, Show) + +data Column = Column Expression + | AliasedColumn + { _expression :: Expression + , _alias :: Name + } deriving (Eq, Show) + +data FromRelation = FromRelation + { _relationExpression :: Expression + , _relationAlias :: Name + } deriving (Eq, Show) + +data Select = Select + { _selectColumns :: NonEmpty Column + , _selectRelations :: [FromRelation] + , _selectConditions :: BooleanExpression + } deriving (Eq, Show) + +instance TextShow Expression where + showb (IdentifierExp e) = showb e + showb (BoolExp e) = showb e + showb (OperatorExp e1 (Operator operator) e2) = showb e1 <> " " <> fromText operator <> " " <> showb e2 + showb (FunctionExp i parameters) = showb i <> "(" <> fromText (withCommas parameters) <> ")" + showb (QueryExp e) = showb e + showb (LitExp e) = showb e + showb (NameExp e) = showb e + showb Null = "NULL" + +instance TextShow FromRelation where + showb (FromRelation e a) = showb e <> " " <> showb a + +instance TextShow Column where + showb (Column c) = showb c + showb (AliasedColumn c a) = showb c <> " AS " <> showb a + +instance TextShow Select where + showb (Select c fr w) = + sel <> " WHERE " <> showb w + where sel = "SELECT " <> fromText (neWithCommas c) <> + if null fr + then "" + else " FROM " + <> fromText (withCommas fr) + +instance TextShow BooleanExpression where + showb (Or e1 e2) = showb e1 <> " OR " <> showb e2 + showb (And e1 e2) = showb e1 <> " AND " <> showb e2 + showb (Not e) = "NOT " <> showb e + showb (BoolLiteral True) = "true" + showb (BoolLiteral False) = "false" + showb (Exists e) = "EXISTS (" <> showb e <> ")" + showb (In e s) = showb e <> " IN (" <> showb s <> ")" + showb (Comparison op e1 e2) = showb e1 <> " " <> showb op <> " " <> showb e2 + +instance IsString Expression where + fromString = LitExp . Literal . fromString + +instance IsString Column where + fromString = Column . NameExp . fromString + +instance IsString FromRelation where + fromString e = FromRelation (NameExp $ fromString e) (fromString e) + +-- Update types +data Assignment = Assignment + { _targetColumn :: Name + , _assignmentValue :: Expression + } deriving (Eq, Show) + +data Update = Update + { _updateTarget :: Identifier + , _updateAssignments :: NonEmpty Assignment + , _updateConditions :: BooleanExpression + , _updateReturning :: [Column] + } deriving (Eq, Show) + +data Delete = Delete + { _deleteTarget :: Identifier + , _deleteConditions :: BooleanExpression + , _deleteReturning :: [Column] + } deriving (Eq, Show) + +instance TextShow Assignment where + showb (Assignment e1 e2) = showb e1 <> " = " <> showb e2 + +-- Insert types +data ConflictTarget = OnConstraint Name + deriving (Eq, Show) + +data Conflict = Conflict + { _conflictTarget :: Maybe ConflictTarget + , _conflictAction :: ConflictAction + } deriving (Eq, Show) + +data ConflictAction = DoNothing + | DoUpdate (NonEmpty Assignment) BooleanExpression + deriving (Eq, Show) + +data Insert = Insert + { _insertTarget :: Identifier + , _insertColumns :: NonEmpty Name + , _insertValues :: NonEmpty Expression + , _insertOnConflict :: Maybe Conflict + } deriving (Eq, Show) + +instance IsString ConflictTarget where + fromString = OnConstraint . fromString + +instance TextShow ConflictTarget where + showb (OnConstraint e1) = fromText $ "ON CONSTRAINT " <> showt e1 + +instance TextShow Conflict where + showb (Conflict Nothing e1) = fromText $ " ON CONFLICT " <> showt e1 + showb (Conflict (Just e1) e2) = fromText $ " ON CONFLICT " <> showt e1 <> " " <> showt e2 + +instance TextShow ConflictAction where + showb DoNothing = "DO NOTHING" + showb (DoUpdate e1 e2) = "DO UPDATE SET " <> fromText (neWithCommas e1) <> " WHERE " <> showb e2 + +instance TextShow Insert where + showb (Insert e1 e2 e3 e4) = + fromText $ + "INSERT INTO " + <> showt e1 + <> " (" + <> neWithCommas e2 + <> ") VALUES (" + <> neWithCommas e3 + <> ")" + <> fromMaybe "" (showt <$> e4) + +instance TextShow Update where + showb (Update e1 e2 e3 e4) = + fromText $ + "UPDATE " + <> showt e1 + <> " SET " + <> neWithCommas e2 + <> " WHERE " <> showt e3 + <> if null e4 + then "" + else " RETURNING " + <> withCommas e4 + +instance TextShow Delete where + showb (Delete e1 e3 e4) = + fromText $ + "DELETE FROM " + <> showt e1 + <> " WHERE " <> showt e3 + <> if null e4 + then "" + else " RETURNING " + <> withCommas e4 + +withCommas :: TextShow a => [a] -> T.Text +withCommas = T.intercalate ", " . map showt + +neWithCommas :: TextShow a => NonEmpty a -> T.Text +neWithCommas = withCommas . toList + +pgFmtIdent :: T.Text -> T.Text +pgFmtIdent x = "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\"" + +pgFmtLit :: T.Text -> T.Text +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> T.replace "'" "''" trimmed <> "'" + slashed = T.replace "\\" "\\\\" escaped in + if "\\" `T.isInfixOf` escaped + then "E" <> slashed + else slashed + +trimNullChars :: T.Text -> T.Text +trimNullChars = T.takeWhile (/= '\x0') diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,66 @@ +import Test.Hspec + +import Pasta +import Protolude hiding ((&)) +import Lens.Micro + +main :: IO () +main = hspec $ do + describe "selectFrom" $ + it "should build select command" $ + toSQL (selectFrom "some_table") `shouldBe` + "SELECT * FROM \"some_table\" \"some_table\" WHERE true" + + describe "select" $ do + it "should build select null command" $ + toSQL select `shouldBe` + "SELECT NULL WHERE true" + it "should build select command using relations setter" $ + toSQL + (select & columns .~ ("*" :| []) & relations .~ ["table1", "table2"]) + `shouldBe` "SELECT * FROM \"table1\" \"table1\", \"table2\" \"table2\" WHERE true" + it "should build select command using relations and where setters" $ + toSQL + (select & columns .~ ("*" :| []) & relations .~ ["table1"] & conditions .~ f) + `shouldBe` "SELECT * FROM \"table1\" \"table1\" WHERE false" + it "should build select command using NOT IN" $ + toSQL + (select & columns .~ ("*" :| []) & relations .~ ["table1"] & conditions .~ (Not $ ("table1"//"c") `In` selectFrom "sub")) + `shouldBe` "SELECT * FROM \"table1\" \"table1\" WHERE NOT \"table1\".\"c\" IN (SELECT * FROM \"sub\" \"sub\" WHERE true)" + + describe "selectFunction" $ + it "should build select version()" $ + toSQL (selectFunction ("public"//"version") []) `shouldBe` "SELECT \"public\".\"version\"() WHERE true" + + describe "insert" $ do + it "should build insert command" $ + toSQL (insert "foo" ("bar" :| []) ("qux" :| [])) + `shouldBe` "INSERT INTO \"public\".\"foo\" (\"bar\") VALUES ('qux')" + it "should build insert command with on conflict" $ + toSQL (insert "foo" ("bar" :| []) ("qux" :| []) & onConflict .~ doNothing) + `shouldBe` "INSERT INTO \"public\".\"foo\" (\"bar\") VALUES ('qux') ON CONFLICT DO NOTHING" + it "should build insert command with on conflict update using identifiers" $ + toSQL (insert "foo" ("bar" :| []) ("qux" :| []) & onConflict .~ doUpdate "pkey" ["bar" .= ("EXCLUDED"//"qux")]) + `shouldBe` "INSERT INTO \"public\".\"foo\" (\"bar\") VALUES ('qux') ON CONFLICT ON CONSTRAINT \"pkey\" DO UPDATE SET \"bar\" = EXCLUDED.\"qux\" WHERE true" + it "should build insert command with on conflict update using literals" $ + toSQL (insert "foo" ("bar" :| []) ("qux" :| []) & onConflict .~ doUpdate "pkey" ["bar" .= ("qux" :: Text)]) + `shouldBe` "INSERT INTO \"public\".\"foo\" (\"bar\") VALUES ('qux') ON CONFLICT ON CONSTRAINT \"pkey\" DO UPDATE SET \"bar\" = 'qux' WHERE true" + + describe "update" $ do + it "should build update" $ + toSQL (update "foo" ("bar" :| []) ("qux" :| [])) + `shouldBe` "UPDATE \"public\".\"foo\" SET \"bar\" = 'qux' WHERE true" + it "should build update with returning *" $ + toSQL (update "foo" ("bar" :| []) ("qux" :| []) & returning .~ ["*"]) + `shouldBe` "UPDATE \"public\".\"foo\" SET \"bar\" = 'qux' WHERE true RETURNING *" + it "should build update with condition" $ + toSQL (update "foo" ("bar" :| []) ("qux" :| []) & conditions .~ ("foo"//"bar" `eq` ("baz" :: Text))) + `shouldBe` "UPDATE \"public\".\"foo\" SET \"bar\" = 'qux' WHERE \"foo\".\"bar\" = 'baz'" + + describe "delete" $ do + it "should build delete" $ + toSQL (delete "foo") + `shouldBe` "DELETE FROM \"public\".\"foo\" WHERE true" + it "should build delete with condition" $ + toSQL (delete "foo" & conditions .~ ("foo"//"bar" `eq` ("baz" :: Text))) + `shouldBe` "DELETE FROM \"public\".\"foo\" WHERE \"foo\".\"bar\" = 'baz'"