pasta (empty) → 0.1.0.0

raw patch · 6 files changed

+612/−0 lines, 6 filesdep +basedep +hspecdep +microlenssetup-changed

Dependencies added: base, hspec, microlens, microlens-th, pasta, protolude, semigroups, text, text-show

Files

LICENSE +30/−0
Setup.hs +2/−0
pasta.cabal +46/−0
src/Pasta.hs +189/−0
src/Pasta/Types.hs +279/−0
test/Spec.hs +66/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ pasta.cabal view

@@ -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

+ src/Pasta.hs view

@@ -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+              _ -> ""

+ src/Pasta/Types.hs view

@@ -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')

+ test/Spec.hs view

@@ -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'"