├── selda.pdf ├── .env-ci ├── test ├── Guide │ ├── Custom.purs │ └── SimpleE2E.purs ├── Main.purs ├── UnitTests.purs ├── Types.purs ├── PG │ └── Config.purs ├── SQLite3.purs ├── Utils.purs ├── PG.purs └── Common.purs ├── .tidyrc.json ├── docker-compose.yml ├── .gitignore ├── src ├── Selda │ ├── SQLite3 │ │ ├── Aff.purs │ │ └── Class.purs │ ├── Inner.purs │ ├── SQLite3.purs │ ├── Query │ │ ├── ShowQuery.purs │ │ ├── Class.purs │ │ ├── ShowStatement.purs │ │ ├── Type.purs │ │ ├── PrettyPrint.purs │ │ └── Utils.purs │ ├── Expr │ │ └── Ord.purs │ ├── Lit.purs │ ├── Aggr.purs │ ├── PG.purs │ ├── Col.purs │ ├── PG │ │ ├── Aff.purs │ │ └── Class.purs │ ├── Table │ │ └── Constraint.purs │ ├── Table.purs │ ├── Expr.purs │ └── Query.purs └── Selda.purs ├── .github └── workflows │ └── ci.yml ├── package.json ├── LICENSE ├── spago.dhall ├── flake.nix ├── flake.lock ├── bower.json ├── README.md ├── packages.dhall └── guide ├── Custom.md └── SimpleE2E.md /selda.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Kamirus/purescript-selda/HEAD/selda.pdf -------------------------------------------------------------------------------- /.env-ci: -------------------------------------------------------------------------------- 1 | PG_DB=purspg 2 | PG_PORT=5432 3 | PG_IDLE_TIMEOUT_MILLISECONDS=1000 4 | PG_USER=init 5 | PG_PASSWORD=qwerty 6 | -------------------------------------------------------------------------------- /test/Guide/Custom.purs: -------------------------------------------------------------------------------- 1 | module Test.Guide.Custom where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Guide.Custom as Guide.Custom 7 | 8 | main ∷ Effect Unit 9 | main = Guide.Custom.main 10 | -------------------------------------------------------------------------------- /test/Guide/SimpleE2E.purs: -------------------------------------------------------------------------------- 1 | module Test.Guide.SimpleE2E where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Guide.SimpleE2E as Guide.SimpleE2E 7 | 8 | main ∷ Effect Unit 9 | main = Guide.SimpleE2E.main 10 | -------------------------------------------------------------------------------- /.tidyrc.json: -------------------------------------------------------------------------------- 1 | { 2 | "importSort": "source", 3 | "importWrap": "source", 4 | "indent": 2, 5 | "operatorsFile": null, 6 | "ribbon": 1, 7 | "typeArrowPlacement": "first", 8 | "unicode": "never", 9 | "width": null 10 | } 11 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: "3" 2 | 3 | services: 4 | db: 5 | image: postgres:14.6 6 | environment: 7 | POSTGRES_DB: $PG_DB 8 | POSTGRES_USER: $PG_USER 9 | POSTGRES_PASSWORD: $PG_PASSWORD 10 | ports: 11 | - $PG_PORT:5432 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago/ 11 | 12 | .env 13 | 14 | package-lock.json 15 | 16 | test/db.sqlite3 17 | 18 | # generated literate files 19 | guide/src/* 20 | -------------------------------------------------------------------------------- /src/Selda/SQLite3/Aff.purs: -------------------------------------------------------------------------------- 1 | module Selda.SQLite3.Aff where 2 | 3 | import Prelude 4 | 5 | import Effect.Aff (Aff) 6 | import SQLite3 (DBConnection) 7 | import Selda.Col (class GetCols) 8 | import Selda.Query.Class (runSelda) 9 | import Selda.Query.Type (FullQuery) 10 | import Selda.Query.Utils (class MapR, UnCol_) 11 | import Selda.SQLite3.Class (BackendSQLite3Class) 12 | import Selda.SQLite3.Class as S 13 | import Simple.JSON (class ReadForeign, E) 14 | 15 | query 16 | :: forall i o 17 | . GetCols i 18 | => MapR UnCol_ i o 19 | => ReadForeign { | o } 20 | => DBConnection 21 | -> FullQuery BackendSQLite3Class { | i } 22 | -> Aff (E (Array { | o })) 23 | query conn q = runSelda conn $ S.query q 24 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Cont (ContT(..), runContT) 6 | import Effect (Effect) 7 | import Effect.Aff (launchAff_) 8 | import Effect.Class (liftEffect) 9 | import Test.PG as PG 10 | import Test.SQLite3 as SQLIte3 11 | import Test.Unit (suite) 12 | import Test.Unit.Main (runTest) 13 | import Test.UnitTests as Unit 14 | 15 | main ∷ Effect Unit 16 | main = do 17 | -- integration tests 18 | launchAff_ $ flip runContT pure do 19 | pg ← ContT PG.main 20 | sqlite3 ← ContT SQLIte3.main 21 | 22 | -- run test suites 23 | liftEffect $ runTest do 24 | Unit.testSuite 25 | suite "Selda" do 26 | pg 27 | sqlite3 28 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: master 6 | pull_request: 7 | 8 | jobs: 9 | test: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | 14 | - uses: actions/setup-node@v2 15 | with: 16 | node-version: "18.x" 17 | 18 | - name: Cache PureScript dependencies 19 | uses: actions/cache@v2 20 | with: 21 | key: ${{ runner.os }}-spago-${{ hashFiles('**/*.dhall') }} 22 | path: | 23 | .spago 24 | output 25 | 26 | - name: Setup env 27 | run: cp .env-ci .env 28 | 29 | - name: Start postgres db for PG test 30 | run: docker-compose up -d 31 | 32 | - run: npm install 33 | - run: npm run-script lit 34 | - run: npm run-script build 35 | - run: npm run-script test 36 | -------------------------------------------------------------------------------- /src/Selda/Inner.purs: -------------------------------------------------------------------------------- 1 | module Selda.Inner 2 | ( Inner 3 | , OuterCols(..) 4 | ) where 5 | 6 | import Heterogeneous.Mapping (class MappingWithIndex) 7 | import Prim.TypeError (class Fail, Beside, Text) 8 | import Selda.Aggr (Aggr) 9 | import Selda.Col (Col(..)) 10 | import Type.Proxy (Proxy) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | 13 | data Inner :: forall k. k -> Type 14 | data Inner s 15 | 16 | data OuterCols = OuterCols 17 | 18 | instance failOuterCols :: 19 | Fail 20 | ( Text "Error in the nested query: column \"" 21 | <:> Text sym 22 | <:> Text "\" has type `Aggr`, but `Col` was expected." 23 | ) => 24 | MappingWithIndex OuterCols (Proxy sym) (Aggr s a) c 25 | where 26 | mappingWithIndex _ _ _ = unsafeCoerce "failed with error message" 27 | else instance outercolsInstance :: MappingWithIndex OuterCols (Proxy sym) (Col (Inner s) a) (Col s a) 28 | where 29 | mappingWithIndex _ _ (Col e) = Col e 30 | 31 | infixl 4 type Beside as <:> 32 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "selda", 3 | "version": "0.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "directories": { 7 | "test": "test" 8 | }, 9 | "scripts": { 10 | "lit": "rm -rf guide/src/ && paluh-litps --input guide/ --output guide/src/", 11 | "build": "npm run-script lit && spago build", 12 | "test:guide:simpleE2E": "npm run-script lit && spago test --main Test.Guide.SimpleE2E", 13 | "test:guide:custom": "npm run-script lit && spago test --main Test.Guide.Custom", 14 | "test:guide": "npm-run-all --sequential test:guide:*", 15 | "test:main": "spago test", 16 | "test": "npm-run-all --sequential test:*" 17 | }, 18 | "author": "", 19 | "license": "ISC", 20 | "dependencies": { 21 | "decimal.js": "^10.0.1", 22 | "pg": "^8.9.0", 23 | "pg-native": "^3.0.1", 24 | "sqlite3": "^5.0.2" 25 | }, 26 | "devDependencies": { 27 | "npm-run-all": "^4.1.5", 28 | "paluh-litps": "^0.1.4", 29 | "spago": "0.20.9", 30 | "purescript": "0.15.7" 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /test/UnitTests.purs: -------------------------------------------------------------------------------- 1 | module Test.UnitTests where 2 | 3 | import Prelude 4 | 5 | import Selda (Table(..)) 6 | import Selda.Query.ShowStatement (genericShowInsert, mkPlaceholders) 7 | import Test.Unit (TestSuite, suite, test) 8 | import Test.Utils (assertEq) 9 | 10 | testTable ∷ Table ( c ∷ Int, a ∷ String, z ∷ Int ) 11 | testTable = Table { name: "testTable" } 12 | 13 | testSuite ∷ TestSuite 14 | testSuite = suite "Unit" do 15 | 16 | test "mkPlaceholders" do 17 | assertEq 18 | (mkPlaceholders "$" 1 3 2) 19 | "($1, $2, $3), ($4, $5, $6)" 20 | assertEq 21 | (mkPlaceholders "$" 1 3 0) 22 | "" 23 | 24 | test "genericShowInsert" do 25 | let ctx = { ph: "$" } 26 | assertEq 27 | (genericShowInsert ctx testTable [{ c: 1, a: "a1", z: 11}]) 28 | """INSERT INTO testTable ("z", "c", "a") VALUES ($1, $2, $3);""" 29 | assertEq 30 | (genericShowInsert ctx testTable 31 | [ { c: 1, a: "a1", z: 11} 32 | , { c: 2, a: "a2", z: 22} 33 | ]) 34 | """INSERT INTO testTable ("z", "c", "a") VALUES ($1, $2, $3), ($4, $5, $6);""" 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Kamil Listopad 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/Selda/SQLite3.purs: -------------------------------------------------------------------------------- 1 | module Selda.SQLite3 where 2 | 3 | import Prelude 4 | 5 | import Foreign (Foreign) 6 | import Selda.Col (Col(..)) 7 | import Selda.Aggr (class Coerce, unsafeFromCol) 8 | import Selda.Expr (Expr(..), ShowM, showM) 9 | import Simple.JSON (class WriteForeign, write) 10 | 11 | -- | Lift a value `a` to a column expression using `WriteForeign a`. 12 | -- | Please note that the value will be passed as a query parameter meaning it 13 | -- | won't appear in the SQL query string as a serialized string, but as a 14 | -- | placeholder with an index corresponding to the array of foreign parameters. 15 | litSQLite3 :: forall col s a. WriteForeign a => Coerce col => a -> col s a 16 | litSQLite3 = unsafeFromCol <<< Col <<< EForeign <<< write 17 | 18 | showSQLite3Query 19 | :: ShowM 20 | -> String 21 | showSQLite3Query = showSQLite3 >>> _.strQuery 22 | 23 | showSQLite3 24 | :: ShowM 25 | -> { params :: Array Foreign, nextIndex :: Int, strQuery :: String } 26 | showSQLite3 = showM "?" 1 27 | 28 | showSQLite3_ :: forall a. ShowM -> (String -> Array Foreign -> a) -> a 29 | showSQLite3_ m k = k strQuery params 30 | where 31 | { strQuery, params } = showSQLite3 m 32 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "selda" 6 | , license = "MIT" 7 | , repository = "https://github.com/Kamirus/purescript-selda.git" 8 | , dependencies = 9 | [ "aff" 10 | , "arrays" 11 | , "bifunctors" 12 | , "console" 13 | , "datetime" 14 | , "dodo-printer" 15 | , "dotenv" 16 | , "effect" 17 | , "either" 18 | , "enums" 19 | , "exceptions" 20 | , "exists" 21 | , "foldable-traversable" 22 | , "foreign" 23 | , "foreign-object" 24 | , "heterogeneous" 25 | , "js-unsafe-stringify" 26 | , "leibniz" 27 | , "lists" 28 | , "maybe" 29 | , "newtype" 30 | , "node-process" 31 | , "node-sqlite3" 32 | , "ordered-collections" 33 | , "partial" 34 | , "polyform" 35 | , "polyform-batteries-core" 36 | , "polyform-batteries-env" 37 | , "postgresql-client" 38 | , "prelude" 39 | , "record" 40 | , "simple-json" 41 | , "strings" 42 | , "test-unit" 43 | , "transformers" 44 | , "tuples" 45 | , "typelevel-prelude" 46 | , "unsafe-coerce" 47 | , "validation" 48 | , "variant" 49 | ] 50 | , packages = ./packages.dhall 51 | , sources = [ "src/**/*.purs", "test/**/*.purs", "guide/src/**/*.purs" ] 52 | } 53 | -------------------------------------------------------------------------------- /src/Selda/Query/ShowQuery.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query.ShowQuery where 2 | 3 | import Prelude 4 | 5 | import Data.Exists (Exists, runExists) 6 | import Data.Maybe (Maybe(..), maybe) 7 | import Data.Tuple (Tuple(..)) 8 | import Selda.Expr (Expr, ShowM, showExpr) 9 | import Selda.Query.Type (JoinType(..), Order(..), QBinOp(..)) 10 | import Selda.Table (Alias) 11 | 12 | ishowJoinType :: JoinType -> String 13 | ishowJoinType = case _ of 14 | LeftJoin -> "LEFT JOIN " 15 | InnerJoin -> "JOIN " 16 | 17 | ishowCompoundOp :: QBinOp -> String 18 | ishowCompoundOp = case _ of 19 | Union -> "UNION" 20 | UnionAll -> "UNION ALL" 21 | Intersect -> "INTERSECT" 22 | Except -> "EXCEPT" 23 | 24 | ishowOrder :: Tuple Order (Exists Expr) -> ShowM 25 | ishowOrder (Tuple order e) = do 26 | s <- runExists showExpr e 27 | pure $ s <> " " 28 | <> case order of 29 | Asc -> "ASC" 30 | Desc -> "DESC" 31 | 32 | ishowLimitOffset :: Maybe Int -> Maybe Int -> String 33 | ishowLimitOffset limit offset = case offset of 34 | Just o | o > 0 -> 35 | let 36 | l = maybe (top :: Int) (max 0) limit 37 | in 38 | "LIMIT " <> show l <> " OFFSET " <> show o 39 | _ -> case limit of 40 | Nothing -> "" 41 | Just l -> "LIMIT " <> show (max 0 l) 42 | 43 | ishowAliasedCol :: Tuple Alias (Exists Expr) -> ShowM 44 | ishowAliasedCol (Tuple alias ee) = do 45 | s <- runExists showExpr ee 46 | pure $ s <> " AS " <> alias 47 | -------------------------------------------------------------------------------- /src/Selda/Expr/Ord.purs: -------------------------------------------------------------------------------- 1 | module Selda.Expr.Ord where 2 | 3 | import Prelude 4 | 5 | import Selda.Aggr (Aggr(..)) 6 | import Selda.Col (Col, binOp) 7 | import Selda.Expr (BinOp(..)) 8 | 9 | infix 4 exprEq as .== 10 | infix 4 exprNeq as ./= 11 | infix 4 exprGt as .> 12 | infix 4 exprLt as .< 13 | infix 4 exprGe as .>= 14 | infix 4 exprLe as .<= 15 | 16 | exprNeq 17 | :: forall expr a 18 | . ExprEq expr 19 | => HeytingAlgebra (expr Boolean) 20 | => expr a 21 | -> expr a 22 | -> expr Boolean 23 | exprNeq a b = not $ a .== b 24 | 25 | -- | Represents types that can model expressions with equality. 26 | class ExprEq expr where 27 | exprEq :: forall a. expr a -> expr a -> expr Boolean 28 | 29 | instance exprEqCol :: ExprEq (Col s) where 30 | exprEq = binOp (Eq identity) 31 | 32 | instance exprEqAggr :: ExprEq (Aggr s) where 33 | exprEq (Aggr a) (Aggr b) = Aggr $ a .== b 34 | 35 | -- | Represents types that model expressions with ordering. 36 | class ExprEq expr <= ExprOrd expr where 37 | exprGt :: forall a. expr a -> expr a -> expr Boolean 38 | exprGe :: forall a. expr a -> expr a -> expr Boolean 39 | exprLt :: forall a. expr a -> expr a -> expr Boolean 40 | exprLe :: forall a. expr a -> expr a -> expr Boolean 41 | 42 | instance exprOrdCol :: ExprOrd (Col s) where 43 | exprGt = binOp (Gt identity) 44 | exprGe = binOp (Ge identity) 45 | exprLt = binOp (Lt identity) 46 | exprLe = binOp (Le identity) 47 | 48 | instance exprOrdAggr :: ExprOrd (Aggr s) where 49 | exprGt (Aggr a) (Aggr b) = Aggr $ exprGt a b 50 | exprGe (Aggr a) (Aggr b) = Aggr $ exprGe a b 51 | exprLt (Aggr a) (Aggr b) = Aggr $ exprLt a b 52 | exprLe (Aggr a) (Aggr b) = Aggr $ exprLe a b 53 | -------------------------------------------------------------------------------- /test/Types.purs: -------------------------------------------------------------------------------- 1 | module Test.Types where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (except, runExcept) 6 | import Data.Bifunctor (lmap) 7 | import Data.Either (Either(..)) 8 | import Data.Generic.Rep (class Generic) 9 | import Data.Show.Generic (genericShow) 10 | import Data.List.NonEmpty (singleton) 11 | import Database.PostgreSQL (class FromSQLValue, class ToSQLValue) 12 | import Foreign (ForeignError(..), F, readString, unsafeToForeign) 13 | import Simple.JSON (class ReadForeign, class WriteForeign, write) 14 | 15 | data AccountType 16 | = Business 17 | | Personal 18 | derive instance eqAccountType ∷ Eq AccountType 19 | derive instance genericAccountType ∷ Generic AccountType _ 20 | instance showAccountType ∷ Show AccountType where 21 | show = genericShow 22 | 23 | readAccountType ∷ String → Either String AccountType 24 | readAccountType "business" = Right Business 25 | readAccountType "personal" = Right Personal 26 | readAccountType other = Left $ "Incorrect account type: " <> other 27 | 28 | printAccountType ∷ AccountType → String 29 | printAccountType Business = "business" 30 | printAccountType Personal = "personal" 31 | 32 | instance fromSqlValueAccountType ∷ FromSQLValue AccountType where 33 | fromSQLValue = readAccountType <=< lmap show <<< runExcept <<< readString 34 | 35 | instance toSQLValueProductType ∷ ToSQLValue AccountType where 36 | toSQLValue = printAccountType >>> unsafeToForeign 37 | 38 | readAccountTypeF ∷ String → F AccountType 39 | readAccountTypeF = 40 | except <<< lmap (singleton <<< ForeignError) <<< readAccountType 41 | 42 | instance readForeignAccountType ∷ ReadForeign AccountType where 43 | readImpl = readString >=> readAccountTypeF 44 | 45 | instance writeForeignAccountType ∷ WriteForeign AccountType where 46 | writeImpl = printAccountType >>> write 47 | -------------------------------------------------------------------------------- /src/Selda/Lit.purs: -------------------------------------------------------------------------------- 1 | module Selda.Lit where 2 | 3 | import Prelude 4 | 5 | import Data.Exists (mkExists) 6 | import Data.Maybe (Maybe(..)) 7 | import Database.PostgreSQL (class ToSQLValue) 8 | import Selda.Aggr (class Coerce, unsafeFromCol) 9 | import Selda.Col (Col(..)) 10 | import Selda.Expr (Expr(..), Literal(..), None(..)) 11 | import Selda.Inner (Inner) 12 | import Selda.PG (litPG) 13 | import Selda.PG.Class (BackendPGClass) 14 | import Selda.SQLite3 (litSQLite3) 15 | import Selda.SQLite3.Class (BackendSQLite3Class) 16 | import Simple.JSON (class WriteForeign) 17 | import Unsafe.Coerce (unsafeCoerce) 18 | 19 | -- | Lift a value `a` to a column expression using `Lit s a` typeclass. 20 | lit 21 | :: forall col s a 22 | . Lit s a 23 | => Coerce col 24 | => a 25 | -> col s a 26 | lit = unsafeFromCol <<< litImpl 27 | 28 | class Lit :: forall k. k -> Type -> Constraint 29 | class Lit s a where 30 | litImpl :: a -> Col s a 31 | 32 | instance litBoolean :: Lit b Boolean where 33 | litImpl x = Col $ ELit $ LBoolean x identity 34 | 35 | else instance litString :: Lit b String where 36 | litImpl x = Col $ ELit $ LString x identity 37 | 38 | else instance litInt :: Lit b Int where 39 | litImpl x = Col $ ELit $ LInt x identity 40 | 41 | else instance litMaybe :: Lit b a => Lit b (Maybe a) where 42 | litImpl = case _ of 43 | Nothing -> Col $ ELit $ LNull $ mkExists $ None identity 44 | Just l -> liftJust $ litImpl l 45 | where 46 | liftJust :: Col b a -> Col b (Maybe a) 47 | liftJust = unsafeCoerce 48 | 49 | else instance ilitPG :: ToSQLValue a => Lit BackendPGClass a where 50 | litImpl = litPG 51 | 52 | else instance ilitSQLite3 :: WriteForeign a => Lit BackendSQLite3Class a where 53 | litImpl = litSQLite3 54 | 55 | else instance litInner :: Lit s a => Lit (Inner s) a where 56 | litImpl a = case (litImpl a :: Col s a) of Col e -> Col e 57 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | # nixConfig = { 3 | # bash-prompt-suffix = "[dev]"; 4 | # }; 5 | inputs = { 6 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 7 | flakeUtils.url = "github:gytis-ivaskevicius/flake-utils-plus"; 8 | easyPSSrc = { 9 | flake = false; 10 | url = "github:justinwoo/easy-purescript-nix"; 11 | }; 12 | }; 13 | 14 | outputs = { self, nixpkgs, flakeUtils, easyPSSrc }: 15 | flakeUtils.lib.eachSystem ["x86_64-linux"] (system: 16 | let 17 | pkgs = nixpkgs.legacyPackages.${system}; 18 | easyPS = pkgs.callPackage easyPSSrc { inherit pkgs; }; 19 | nodejs-16 = pkgs.writeShellScriptBin "nodejs-16" '' 20 | ${ pkgs.nodejs-16_x.out}/bin/node $@ 21 | ''; 22 | in { 23 | devShell = pkgs.mkShell { 24 | buildInputs = [ 25 | 26 | # Please update spago and purescript in `package.json` `scripts` section 27 | easyPS."purs-0_15_7" 28 | easyPS.purescript-language-server 29 | easyPS.pscid 30 | easyPS.purs-tidy 31 | easyPS.pulp 32 | easyPS.spago 33 | 34 | pkgs.jq 35 | pkgs.docker 36 | pkgs.nodePackages.bower 37 | pkgs.nodePackages.jshint 38 | pkgs.nodePackages.nodemon 39 | pkgs.nodePackages.yarn 40 | pkgs.nodePackages.webpack 41 | pkgs.nodePackages.webpack-cli 42 | pkgs.nodePackages.webpack-dev-server 43 | pkgs.dhall 44 | pkgs.nodejs-18_x 45 | nodejs-16 46 | pkgs.pkgconfig 47 | pkgs.postgresql 48 | pkgs.python27 49 | pkgs.python37 50 | pkgs.unzip 51 | pkgs.nixpacks 52 | ]; 53 | shellHook = '' 54 | npm install 55 | NODE_OPTIONS=--experimental-fetch --trace-warnings 56 | export PATH=$PATH:./node_modules/.bin/:./bin 57 | export PS1="\n\[\033[1;32m\][nix develop:\w]\$\[\033[0m\] "; 58 | ''; 59 | }; 60 | } 61 | ); 62 | } 63 | -------------------------------------------------------------------------------- /src/Selda/Aggr.purs: -------------------------------------------------------------------------------- 1 | module Selda.Aggr 2 | ( Aggr(..) 3 | , WrapWithAggr(..) 4 | , UnAggr(..) 5 | , class Coerce 6 | , unsafeFromCol 7 | ) where 8 | 9 | import Data.HeytingAlgebra (class HeytingAlgebra, ff, implies, not, tt, (&&), (||)) 10 | import Heterogeneous.Mapping (class Mapping, class MappingWithIndex) 11 | import Prim.TypeError (class Fail, Text, Beside) 12 | import Selda.Col (Col) 13 | import Type.Proxy (Proxy) 14 | import Unsafe.Coerce (unsafeCoerce) 15 | 16 | newtype Aggr :: forall k. k -> Type -> Type 17 | newtype Aggr s a = Aggr (Col s a) 18 | 19 | instance heytingAlgebraAggr :: HeytingAlgebra (Aggr s Boolean) where 20 | ff = Aggr ff 21 | tt = Aggr tt 22 | implies (Aggr a) (Aggr b) = Aggr (a `implies` b) 23 | conj (Aggr a) (Aggr b) = Aggr (a && b) 24 | disj (Aggr a) (Aggr b) = Aggr (a || b) 25 | not (Aggr e) = Aggr (not e) 26 | 27 | -- | Overloading utility for common operations on `Col` and `Aggr` 28 | class Coerce :: forall k. (k -> Type -> Type) -> Constraint 29 | class Coerce col where 30 | -- | Either an identity or `Aggr` constructor. 31 | -- | Can be used when it's safe to operate on both `Col` and `Aggr`. 32 | -- | Not every `Col` can be safely coerced to `Aggr`. 33 | unsafeFromCol :: forall s a. Col s a -> col s a 34 | 35 | instance coerceCol :: Coerce Col where 36 | unsafeFromCol x = x 37 | 38 | instance coerceAggr :: Coerce Aggr where 39 | unsafeFromCol = Aggr 40 | 41 | data WrapWithAggr = WrapWithAggr 42 | 43 | instance wrapWithAggrInstance :: Mapping WrapWithAggr (Col s a) (Aggr s a) 44 | where 45 | mapping _ = Aggr 46 | 47 | infixl 4 type Beside as <:> 48 | 49 | data UnAggr = UnAggr 50 | 51 | instance failUnAggr :: 52 | Fail 53 | ( Text "field '" 54 | <:> Text sym 55 | <:> Text "' is not aggregated. Its type should be 'Aggr _ _'" 56 | ) => 57 | MappingWithIndex UnAggr (Proxy sym) (Col s a) c 58 | where 59 | mappingWithIndex _ _ _ = unsafeCoerce "failed with error message" 60 | else instance unAggrInstance :: MappingWithIndex UnAggr (Proxy sym) (Aggr s a) (Col s a) 61 | where 62 | mappingWithIndex _ _ (Aggr col) = col 63 | -------------------------------------------------------------------------------- /test/PG/Config.purs: -------------------------------------------------------------------------------- 1 | module Test.Selda.PG.Config where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (throwError) 6 | import Data.Either (Either(..)) 7 | import Data.Map (fromFoldable) as Map 8 | import Data.Newtype (un) 9 | import Data.Validation.Semigroup (V(..)) 10 | import Database.PostgreSQL (Configuration) as PG 11 | import Database.PostgreSQL (Pool) 12 | import Database.PostgreSQL.Pool (new) as Pool 13 | import Dotenv (loadFile) as DotEnv 14 | import Effect.Aff (Aff) 15 | import Effect.Class (class MonadEffect, liftEffect) 16 | import Effect.Exception (error) 17 | import Foreign.Object (toUnfoldable) as Object 18 | import JS.Unsafe.Stringify (unsafeStringify) 19 | import Node.Process (getEnv) 20 | import Polyform.Batteries.Env (Env, Validator) as Env 21 | import Polyform.Batteries.Env (MissingValue) 22 | import Polyform.Batteries.Env.Validators (optional, required) as Env 23 | import Polyform.Batteries.Int (IntExpected) 24 | import Polyform.Batteries.Int (validator) as Int 25 | import Polyform.Validator (liftFnM, runValidator) 26 | import Type.Row (type (+)) 27 | 28 | poolConfiguration ∷ 29 | ∀ err m. 30 | Monad m ⇒ 31 | Env.Validator m (IntExpected + MissingValue + err) Env.Env PG.Configuration 32 | poolConfiguration = 33 | { database: _, host: _, idleTimeoutMillis: _, max: _, password: _, port: _, user: _ } 34 | <$> Env.required "PG_DB" identity 35 | <*> Env.optional "PG_HOST" identity 36 | <*> Env.optional "PG_IDLE_TIMEOUT_MILLISECONDS" Int.validator 37 | <*> Env.optional "PG_MAX" Int.validator 38 | <*> Env.optional "PG_PASSWORD" identity 39 | <*> Env.optional "PG_PORT" Int.validator 40 | <*> Env.optional "PG_USER" identity 41 | 42 | pool ∷ ∀ err m. MonadEffect m ⇒ Env.Validator m (IntExpected + MissingValue + err) Env.Env Pool 43 | pool = poolConfiguration >>> liftFnM (Pool.new >>> liftEffect) 44 | 45 | load ∷ Aff Pool 46 | load = do 47 | void $ DotEnv.loadFile 48 | env ← liftEffect $ getEnv <#> (Object.toUnfoldable ∷ _ → Array _) >>> Map.fromFoldable 49 | runValidator pool env >>= un V 50 | >>> case _ of 51 | Left err → do 52 | throwError $ error $ "Configuration error. Please verify your environment and .env file.\nRaw error: " <> unsafeStringify err 53 | Right p → pure p 54 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "easyPSSrc": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1671011575, 7 | "narHash": "sha256-tESal32bcqqdZO+aKnBzc1GoL2mtnaDtj2y7ociCRGA=", 8 | "owner": "justinwoo", 9 | "repo": "easy-purescript-nix", 10 | "rev": "11d3bd58ce6e32703bf69cec04dc7c38eabe14ba", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "justinwoo", 15 | "repo": "easy-purescript-nix", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "locked": { 21 | "lastModified": 1644229661, 22 | "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", 23 | "owner": "numtide", 24 | "repo": "flake-utils", 25 | "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", 26 | "type": "github" 27 | }, 28 | "original": { 29 | "owner": "numtide", 30 | "repo": "flake-utils", 31 | "type": "github" 32 | } 33 | }, 34 | "flakeUtils": { 35 | "inputs": { 36 | "flake-utils": "flake-utils" 37 | }, 38 | "locked": { 39 | "lastModified": 1657226504, 40 | "narHash": "sha256-GIYNjuq4mJlFgqKsZ+YrgzWm0IpA4axA3MCrdKYj7gs=", 41 | "owner": "gytis-ivaskevicius", 42 | "repo": "flake-utils-plus", 43 | "rev": "2bf0f91643c2e5ae38c1b26893ac2927ac9bd82a", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "gytis-ivaskevicius", 48 | "repo": "flake-utils-plus", 49 | "type": "github" 50 | } 51 | }, 52 | "nixpkgs": { 53 | "locked": { 54 | "lastModified": 1669809720, 55 | "narHash": "sha256-RMT77f6CPOYtLLQ2esj+EJ1BPVWxf4RDidjrSvA5OhI=", 56 | "owner": "nixos", 57 | "repo": "nixpkgs", 58 | "rev": "227de2b3bbec142f912c09d5e8a1b4e778aa54fb", 59 | "type": "github" 60 | }, 61 | "original": { 62 | "owner": "nixos", 63 | "ref": "nixpkgs-unstable", 64 | "repo": "nixpkgs", 65 | "type": "github" 66 | } 67 | }, 68 | "root": { 69 | "inputs": { 70 | "easyPSSrc": "easyPSSrc", 71 | "flakeUtils": "flakeUtils", 72 | "nixpkgs": "nixpkgs" 73 | } 74 | } 75 | }, 76 | "root": "root", 77 | "version": 7 78 | } 79 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-selda", 3 | "license": [ 4 | "MIT" 5 | ], 6 | "repository": { 7 | "type": "git", 8 | "url": "https://github.com/Kamirus/purescript-selda.git" 9 | }, 10 | "ignore": [ 11 | "**/.*", 12 | "node_modules", 13 | "bower_components", 14 | "output" 15 | ], 16 | "dependencies": { 17 | "purescript-aff": "^v6.0.0", 18 | "purescript-arrays": "^v6.0.1", 19 | "purescript-bifunctors": "^v5.0.0", 20 | "purescript-console": "^v5.0.0", 21 | "purescript-datetime": "^v5.0.2", 22 | "purescript-dodo-printer": "https://github.com/natefaubion/purescript-dodo-printer.git#v2.0.0", 23 | "purescript-dotenv": "^v2.0.0", 24 | "purescript-effect": "^v3.0.0", 25 | "purescript-either": "^v5.0.0", 26 | "purescript-enums": "^v5.0.0", 27 | "purescript-exceptions": "^v5.0.0", 28 | "purescript-exists": "^v5.0.0", 29 | "purescript-foldable-traversable": "^v5.0.1", 30 | "purescript-foreign": "^v6.0.1", 31 | "purescript-foreign-object": "^v3.0.0", 32 | "purescript-heterogeneous": "^v0.5.0", 33 | "purescript-leibniz": "^v5.0.0", 34 | "purescript-lists": "^v6.0.1", 35 | "purescript-maybe": "^v5.0.0", 36 | "purescript-newtype": "^v4.0.0", 37 | "purescript-node-process": "^v8.2.0", 38 | "purescript-node-sqlite3": "^v6.0.0", 39 | "purescript-ordered-collections": "^v2.0.1", 40 | "purescript-partial": "^v3.0.0", 41 | "purescript-polyform": "^v0.9.0", 42 | "purescript-polyform-batteries-core": "https://github.com/purescript-polyform/batteries-core.git#v0.2.0", 43 | "purescript-polyform-batteries-env": "https://github.com/purescript-polyform/batteries-env.git#v0.1.0", 44 | "purescript-postgresql-client": "^v3.3.0", 45 | "purescript-prelude": "^v5.0.0", 46 | "purescript-record": "^v3.0.0", 47 | "purescript-simple-json": "^v8.0.0", 48 | "purescript-strings": "^v5.0.0", 49 | "purescript-test-unit": "^v16.0.0", 50 | "purescript-transformers": "^v5.1.0", 51 | "purescript-tuples": "^v6.0.1", 52 | "purescript-typelevel-prelude": "^v6.0.0", 53 | "purescript-unsafe-coerce": "^v5.0.0", 54 | "purescript-validation": "^v5.0.0", 55 | "purescript-variant": "^v7.0.2" 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /src/Selda/PG.purs: -------------------------------------------------------------------------------- 1 | module Selda.PG where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Data.Maybe (maybe) 7 | import Data.String (joinWith) 8 | import Database.PostgreSQL (class ToSQLValue, toSQLValue) 9 | import Foreign (Foreign) 10 | import Selda.Aggr (class Coerce, unsafeFromCol) 11 | import Selda.Col (Col(..), showCol) 12 | import Selda.Expr (Expr(..), ShowM, showM) 13 | import Selda.Query.Utils (class RowListLength, rowListLength) 14 | import Selda.Table (class TableColumnNames, Table(..), tableColumnNames, tableName) 15 | import Selda.Table.Constraint (class CanInsertColumnsIntoTable) 16 | 17 | -- | Lift a value `a` to a column expression using `ToSQLValue a`. 18 | -- | Please note that the value will be passed as a query parameter meaning it 19 | -- | won't appear in the SQL query string as a serialized string, but as a 20 | -- | placeholder with an index corresponding to the array of foreign parameters. 21 | litPG :: forall col s a. ToSQLValue a => Coerce col => a -> col s a 22 | litPG = unsafeFromCol <<< Col <<< EForeign <<< toSQLValue 23 | 24 | showPGQuery 25 | :: ShowM 26 | -> String 27 | showPGQuery = showPG >>> _.strQuery 28 | 29 | showPG 30 | :: ShowM 31 | -> { params :: Array Foreign, nextIndex :: Int, strQuery :: String } 32 | showPG = showM "$" 1 33 | 34 | showInsert1 35 | :: forall t insRLcols retRLcols proxy1 proxy2 36 | . CanInsertColumnsIntoTable insRLcols t 37 | => TableColumnNames insRLcols 38 | => TableColumnNames retRLcols 39 | => RowListLength insRLcols 40 | => Table t 41 | -> proxy1 insRLcols 42 | -> proxy2 retRLcols 43 | -> String 44 | showInsert1 table colsToinsert colsToRet = 45 | let 46 | cols = joinWith ", " $ tableColumnNames colsToinsert 47 | rets = joinWith ", " $ tableColumnNames colsToRet 48 | len = rowListLength colsToinsert 49 | placeholders = 50 | Array.range 1 len # map (\i -> "$" <> show i) # joinWith ", " 51 | in 52 | "INSERT INTO " <> tableName table <> " (" <> cols <> ") " 53 | <> "VALUES " 54 | <> "(" 55 | <> placeholders 56 | <> ") " 57 | <> "RETURNING " 58 | <> rets 59 | 60 | -- | **PG specific** - The extract function retrieves subfields 61 | -- | such as year or hour from date/time values. 62 | -- | e.g. extract "year" (d ∷ Col s JSDate) 63 | extract :: forall a s. String -> Col s a -> Col s String 64 | extract field srcCol = Col $ Any do 65 | s <- showCol srcCol 66 | pure $ "extract(" <> field <> " from " <> s <> ")" 67 | 68 | -- | **PG specific** `generate_series(start, stop)` set returning function 69 | -- | modeled as a Table-like source. It should be used only for querying. 70 | generateSeries :: Int -> Int -> Table (i :: Int) 71 | generateSeries start stop = Source "gs" \maybeAlias -> 72 | let 73 | alias = maybe "" identity maybeAlias 74 | in 75 | "generate_series(" <> show start <> ", " <> show stop <> ") " <> alias <> " (i)" 76 | -------------------------------------------------------------------------------- /test/SQLite3.purs: -------------------------------------------------------------------------------- 1 | module Test.SQLite3 where 2 | 3 | import Prelude 4 | 5 | import Data.Foldable (for_) 6 | import Data.Maybe (Maybe(..)) 7 | import Effect.Aff (Aff) 8 | import SQLite3 (newDB, queryDB) 9 | import Selda (lit, (.==), (.>)) 10 | import Selda.SQLite3.Class (deleteFrom, insert_, update) 11 | import Test.Common (bankAccounts, descriptions, legacySuite, people) 12 | import Test.Types (AccountType(..)) 13 | import Test.Unit (TestSuite, suite) 14 | import Test.Utils (runSeldaAff, testWithSQLite3) 15 | 16 | main ∷ (TestSuite → Aff Unit) → Aff Unit 17 | main cont = do 18 | let dbPath = "./test/db.sqlite3" 19 | conn ← newDB dbPath 20 | 21 | -- recreate tables 22 | for_ strsCreateTables \s → queryDB conn s [] 23 | 24 | -- inserts 25 | runSeldaAff conn do 26 | insert_ people 27 | [ { id: 1, name: "name1", age: Just 11 } 28 | , { id: 2, name: "name2", age: Just 22 } 29 | , { id: 3, name: "name3", age: Just 33 } 30 | ] 31 | insert_ bankAccounts 32 | [ { id: 1, personId: 1, balance: 100, accountType: Business } 33 | , { id: 2, personId: 1, balance: 150, accountType: Personal } 34 | , { id: 3, personId: 3, balance: 300, accountType: Personal } 35 | ] 36 | insert_ descriptions 37 | [ { id: 1, text: Just "text1" } 38 | , { id: 3, text: Nothing } 39 | ] 40 | 41 | -- simple test delete 42 | runSeldaAff conn do 43 | insert_ people [{ id: 4, name: "delete", age: Just 999 }] 44 | deleteFrom people \r → r.id .== lit 4 45 | 46 | -- simple test update 47 | runSeldaAff conn do 48 | insert_ people [{ id: 5, name: "update", age: Just 999 }] 49 | update people 50 | (\r → r.name .== lit "update") 51 | (\r → r { age = lit $ Just 1000 }) 52 | deleteFrom people \r → r.age .> lit (Just 999) 53 | 54 | -- test empty insert,update won't break 55 | runSeldaAff conn do 56 | insert_ people ([] ∷ Array { id ∷ Int, name ∷ String, age ∷ Maybe Int }) 57 | update people (\r → r.id .== r.id) identity 58 | 59 | cont do 60 | suite "SQLite3" $ testWithSQLite3 conn legacySuite 61 | 62 | strsCreateTables ∷ Array String 63 | strsCreateTables = 64 | [ "DROP TABLE IF EXISTS people;" 65 | , """ 66 | CREATE TABLE people ( 67 | id INTEGER PRIMARY KEY, 68 | name TEXT NOT NULL, 69 | age INTEGER 70 | ); 71 | """ 72 | , "DROP TABLE IF EXISTS bank_accounts;" 73 | , """ 74 | CREATE TABLE bank_accounts ( 75 | id INTEGER PRIMARY KEY, 76 | personId INTEGER NOT NULL, 77 | balance INTEGER NOT NULL, 78 | accountType TEXT NOT NULL 79 | ); 80 | """ 81 | , "DROP TABLE IF EXISTS descriptions;" 82 | , """ 83 | CREATE TABLE descriptions ( 84 | id INTEGER PRIMARY KEY, 85 | text TEXT 86 | ); 87 | """ 88 | , "DROP TABLE IF EXISTS emptyTable;" 89 | , """ 90 | CREATE TABLE emptyTable ( 91 | id INTEGER PRIMARY KEY 92 | ); 93 | """ 94 | ] 95 | -------------------------------------------------------------------------------- /src/Selda/Col.purs: -------------------------------------------------------------------------------- 1 | module Selda.Col where 2 | 3 | import Prelude 4 | 5 | import Data.Array ((:)) 6 | import Data.Exists (Exists, mkExists) 7 | import Data.Newtype (class Newtype, unwrap) 8 | import Data.Symbol (class IsSymbol, reflectSymbol) 9 | import Data.Tuple (Tuple(..)) 10 | import Heterogeneous.Folding (class FoldingWithIndex, class HFoldlWithIndex, hfoldlWithIndex) 11 | import Heterogeneous.Mapping (class HMap, class Mapping, hmap) 12 | import Selda.Expr (BinExp(..), BinOp(..), Expr(..), Literal(..), ShowM, UnExp(..), UnOp(..), showExpr) 13 | import Selda.Table (Alias, Column) 14 | import Type.Proxy (Proxy(..)) 15 | 16 | newtype Col :: forall k. k -> Type -> Type 17 | newtype Col s a = Col (Expr a) 18 | 19 | derive instance newtypeCol :: Newtype (Col s a) _ 20 | 21 | instance heytingAlgebraCol :: HeytingAlgebra (Col s Boolean) where 22 | ff = Col $ ELit $ LBoolean false identity 23 | tt = Col $ ELit $ LBoolean true identity 24 | implies a b = not a || b 25 | conj = binOp (And identity identity) 26 | disj = binOp (Or identity identity) 27 | not (Col e) = Col $ EUnOp $ mkExists $ UnExp (Not identity identity) e 28 | 29 | showCol :: forall s a. Col s a -> ShowM 30 | showCol = unwrap >>> showExpr 31 | 32 | -- | ```purescript 33 | -- | { name ∷ Column String, id ∷ Column Int } 34 | -- | → 35 | -- | { name ∷ Col s String, id ∷ Col s Int } 36 | -- | ``` 37 | class ToCols :: forall k. k -> Row Type -> Row Type -> Constraint 38 | class ToCols s i o | s i -> o where 39 | toCols :: forall proxy. proxy s -> { | i } -> { | o } 40 | 41 | instance toColsI :: HMap (ToCols_ s) { | i } { | o } => ToCols s i o where 42 | toCols _ = hmap (ToCols_ :: ToCols_ s) 43 | 44 | data ToCols_ :: forall k. k -> Type 45 | data ToCols_ s = ToCols_ 46 | 47 | instance toColsMapping :: Mapping (ToCols_ s) (Column a) (Col s a) where 48 | mapping _ col = Col $ EColumn col 49 | 50 | -- | For record { n1 ∷ Col s String, n2 ∷ Col s String, id ∷ Col s Int } 51 | -- | → [(id, Expr Int), (n1, Expr String), (n2, Expr String)] 52 | -- | → [(id, Exists Expr), (n1, Exists Expr), (n2, Exists Expr)] 53 | class GetCols r where 54 | getCols :: { | r } -> Array (Tuple Alias (Exists Expr)) 55 | 56 | instance getcols :: 57 | HFoldlWithIndex ExtractCols 58 | (Array (Tuple String (Exists Expr))) 59 | { | r } 60 | (Array (Tuple String (Exists Expr))) => 61 | GetCols r 62 | where 63 | getCols r = hfoldlWithIndex ExtractCols ([] :: Array (Tuple String (Exists Expr))) r 64 | 65 | data ExtractCols = ExtractCols 66 | 67 | instance extractcols :: 68 | IsSymbol sym => 69 | FoldingWithIndex ExtractCols 70 | (Proxy sym) 71 | (Array (Tuple String (Exists Expr))) 72 | (Col s a) 73 | (Array (Tuple String (Exists Expr))) 74 | where 75 | foldingWithIndex ExtractCols _ acc (Col e) = 76 | Tuple (reflectSymbol (Proxy :: Proxy sym)) (mkExists e) : acc 77 | 78 | binOp :: forall s o i. BinOp i o -> Col s i -> Col s i -> Col s o 79 | binOp op (Col e1) (Col e2) = Col $ EBinOp $ mkExists $ BinExp op e1 e2 80 | 81 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-selda 2 | 3 | [![CI](https://github.com/Kamirus/purescript-selda/workflows/CI/badge.svg)](https://github.com/Kamirus/purescript-selda/actions) 4 | 5 | ## About 6 | 7 | **purescript-selda** is an **SQL library** (*eDSL*) which allows a user to write **type-safe queries**. 8 | - Generated SQL is guaranteed to be correct by the type system. 9 | - It supports **arbitrarily nested queries** with capabilities of **filtering**, **joins** and **aggregation**. 10 | - We used **standard monadic abstraction** which supports writing queries in a linear, natural style. 11 | - Our main target is **PostgreSQL** though in the upcoming release (already on master) we add **SQLite3** support (with ability to support other db backends). 12 | 13 | 14 | ## Example Query 15 | 16 | To declare a type for a SQL table (already created in the db) 17 | we write the following table definition: 18 | ```purescript 19 | people ∷ Table (id ∷ Int, name ∷ String, age ∷ Maybe Int) 20 | people = Table { name: "people" } 21 | ``` 22 | 23 | Once we've defined the tables, we can write queries, e.g. 24 | 25 | ```purescript 26 | selectFrom people \{ id, name, age } → do 27 | { balance } ← leftJoin bankAccounts \b → id .== b.personId 28 | restrict $ id .> lit 1 29 | pure { id, balance } 30 | ``` 31 | 32 | Generated SQL for the above query: 33 | ```sql 34 | SELECT people_0.id AS id, bank_accounts_1.balance AS balance 35 | FROM people people_0 36 | LEFT JOIN bank_accounts bank_accounts_1 ON ((people_0.id = bank_accounts_1.personId)) 37 | WHERE ((people_0.id > 1)) 38 | ``` 39 | 40 | For a more gentle introduction and more examples please refer to the [Step-by-Step Guide](guide/SimpleE2E.md). 41 | 42 | ## More Help 43 | 44 | **If you have any questions please don't hesitate to ask**. 45 |
I'll be happy to help and provide any guidance if necessary. 46 |
Open an issue or hit me up directly (either on [slack](https://functionalprogramming.slack.com/), [forum](https://discourse.purescript.org/) or directly via email). 47 | 48 | ## Install 49 | 50 | Install [postgresql-client's dependencies](https://github.com/rightfold/purescript-postgresql-client#install) 51 | > npm install pg decimal.js 52 | 53 | ## Info 54 | 55 | - [**Introductory Guide**](guide/SimpleE2E.md): End-to-End example: how to setup, write queries, use aggregation, deal with type errors and execute queries and inserts. 56 | - [**Advanced Guide**](guide/Custom.md): Custom Types and Expressions (`litPG`, `Any`, `EForeign`, custom PG functions), more flexible table definitions (`Source`, db schemas, set-returning functions) - unsafe escape hatches 57 | - **Test Suite**: For information about features, examples, usage, etc. refer to the test suite: [`Test.Common`](test/Common.purs), [`Test.PG`](test/PG.purs), [`Test.SQLite3`](test/SQLite3.purs). To run the tests, `docker-compose up -d` helps to prepare postgres database. 58 | - **Documentation**: [Pursuit docs](https://pursuit.purescript.org/packages/purescript-selda/) 59 | - [**My thesis**](./selda.pdf) 60 | 61 | ## Credits 62 | 63 | Supported by [Lambda Terms](https://github.com/lambdaterms/) 64 | 65 | Inspired by [selda](https://github.com/valderman/selda) 66 | -------------------------------------------------------------------------------- /src/Selda/PG/Aff.purs: -------------------------------------------------------------------------------- 1 | module Selda.PG.Aff 2 | ( insert_ 3 | , insert 4 | , insert1 5 | , insert1_ 6 | , query 7 | , query1 8 | , PGSelda 9 | , deleteFrom 10 | , update 11 | ) where 12 | 13 | import Prelude 14 | 15 | import Control.Monad.Except (ExceptT) 16 | import Control.Monad.Reader (ReaderT) 17 | import Data.Array (head) as Array 18 | import Data.Either (Either) 19 | import Data.Maybe (Maybe) 20 | import Database.PostgreSQL (class FromSQLRow, Connection, PGError) 21 | import Effect.Aff (Aff) 22 | import Selda (Col, Table) 23 | import Selda.Col (class GetCols) 24 | import Selda.PG.Class (class InsertRecordIntoTableReturning, BackendPGClass) 25 | import Selda.PG.Class as Selda.PG 26 | import Selda.Query (limit) 27 | import Selda.Query.Class (class GenericInsert, runSelda) 28 | import Selda.Query.Type (FullQuery(..)) 29 | import Selda.Query.Utils (class ColsToPGHandler, class TableToColsWithoutAlias) 30 | 31 | type PGSelda = ExceptT PGError (ReaderT Connection Aff) 32 | 33 | type B = BackendPGClass 34 | 35 | insert_ 36 | :: forall t r 37 | . GenericInsert BackendPGClass PGSelda t r 38 | => Connection 39 | -> Table t 40 | -> Array { | r } 41 | -> Aff (Either PGError Unit) 42 | insert_ conn t r = runSelda conn $ Selda.PG.insert_ t r 43 | 44 | insert1_ 45 | :: forall r t 46 | . GenericInsert BackendPGClass PGSelda t r 47 | => Connection 48 | -> Table t 49 | -> { | r } 50 | -> Aff (Either PGError Unit) 51 | insert1_ conn t r = runSelda conn $ Selda.PG.insert1_ t r 52 | 53 | insert 54 | :: forall r t tr 55 | . InsertRecordIntoTableReturning r t tr 56 | => Connection 57 | -> Table t 58 | -> Array { | r } 59 | -> Aff (Either PGError (Array { | tr })) 60 | insert conn t r = runSelda conn $ Selda.PG.insert t r 61 | 62 | insert1 63 | :: forall r t tr 64 | . InsertRecordIntoTableReturning r t tr 65 | => Connection 66 | -> Table t 67 | -> { | r } 68 | -> Aff (Either PGError { | tr }) 69 | insert1 conn t r = runSelda conn $ Selda.PG.insert1 t r 70 | 71 | query 72 | :: forall o i tup 73 | . ColsToPGHandler B i tup o 74 | => GetCols i 75 | => FromSQLRow tup 76 | => Connection 77 | -> FullQuery B (Record i) 78 | -> Aff (Either PGError (Array { | o })) 79 | query conn q = runSelda conn $ Selda.PG.query q 80 | 81 | query1 82 | :: forall o i tup 83 | . ColsToPGHandler B i tup o 84 | => GetCols i 85 | => FromSQLRow tup 86 | => Connection 87 | -> FullQuery B (Record i) 88 | -> Aff (Either PGError (Maybe { | o })) 89 | query1 conn (FullQuery q) = query conn (FullQuery (limit 1 >>= \_ -> q)) <#> map Array.head 90 | 91 | deleteFrom 92 | :: forall r r' 93 | . TableToColsWithoutAlias B r r' 94 | => Connection 95 | -> Table r 96 | -> ({ | r' } -> Col B Boolean) 97 | -> Aff (Either PGError Unit) 98 | deleteFrom conn table pred = runSelda conn $ Selda.PG.deleteFrom table pred 99 | 100 | update 101 | :: forall r r' 102 | . TableToColsWithoutAlias B r r' 103 | => GetCols r' 104 | => Connection 105 | -> Table r 106 | -> ({ | r' } -> Col B Boolean) 107 | -> ({ | r' } -> { | r' }) 108 | -> Aff (Either PGError Unit) 109 | update conn table pred up = runSelda conn $ Selda.PG.update table pred up 110 | -------------------------------------------------------------------------------- /src/Selda/Query/Class.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query.Class where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError) 6 | import Control.Monad.Except (ExceptT, runExceptT) 7 | import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, asks, runReaderT) 8 | import Data.Either (Either, either) 9 | import Effect.Aff (Aff) 10 | import Effect.Aff.Class (class MonadAff, liftAff) 11 | import Foreign (Foreign) 12 | import Heterogeneous.Folding (class HFoldl, hfoldl) 13 | import Selda.Col (Col) 14 | import Selda.Table (Table) 15 | import Selda.Query.ShowStatement (class GenericShowInsert, genericShowInsert) 16 | import Selda.Query.Type (FullQuery) 17 | import Selda.Query.Utils (RecordToArrayForeign(..)) 18 | import Type.Proxy (Proxy) 19 | 20 | class GenericQuery :: forall k. k -> (Type -> Type) -> Row Type -> Row Type -> Constraint 21 | class Monad m <= GenericQuery b m i o | i -> o, b -> m where 22 | genericQuery 23 | :: Proxy b 24 | -> FullQuery b { | i } 25 | -> m (Array { | o }) 26 | 27 | class GenericInsert :: forall k. k -> (Type -> Type) -> Row Type -> Row Type -> Constraint 28 | class Monad m <= GenericInsert b m t r | t -> r, b -> m where 29 | genericInsert 30 | :: Proxy b 31 | -> Table t 32 | -> Array { | r } 33 | -> m Unit 34 | 35 | class GenericDelete :: forall k. k -> (Type -> Type) -> Row Type -> Row Type -> Constraint 36 | class Monad m <= GenericDelete b m t r | t -> r, b -> m where 37 | genericDelete 38 | :: Proxy b 39 | -> Table t 40 | -> ({ | r } -> Col b Boolean) 41 | -> m Unit 42 | 43 | class GenericUpdate :: forall k. k -> (Type -> Type) -> Row Type -> Row Type -> Constraint 44 | class Monad m <= GenericUpdate b m t r | t -> r, b -> m where 45 | genericUpdate 46 | :: Proxy b 47 | -> Table t 48 | -> ({ | r } -> Col b Boolean) 49 | -> ({ | r } -> { | r }) 50 | -> m Unit 51 | 52 | -- | parametrized implementation of `genericInsert` 53 | genericInsert_ 54 | :: forall t r a b 55 | . GenericShowInsert t r 56 | => HFoldl (RecordToArrayForeign b) (Array Foreign) { | r } (Array Foreign) 57 | => { ph :: String, exec :: String -> Array Foreign -> a } 58 | -> Proxy b 59 | -> Table t 60 | -> Array { | r } 61 | -> a 62 | genericInsert_ { ph, exec } b table rs = do 63 | let 64 | q = genericShowInsert { ph } table rs 65 | l = rs >>= hfoldl (RecordToArrayForeign b) ([] :: Array Foreign) 66 | exec q l 67 | 68 | hoistSeldaWith 69 | :: forall r e' e m r' 70 | . MonadThrow e' m 71 | => MonadAsk r' m 72 | => MonadAff m 73 | => (e -> e') 74 | -> (r' -> r) 75 | -> ExceptT e (ReaderT r Aff) ~> m 76 | hoistSeldaWith fe fr m = do 77 | conn <- asks fr 78 | runReaderT (runExceptT m) conn # liftAff 79 | >>= either (throwError <<< fe) pure 80 | 81 | class 82 | ( MonadAff m 83 | , MonadError e m 84 | , MonadReader r m 85 | ) <= 86 | MonadSelda m e r 87 | | m -> e r 88 | 89 | instance monadSeldaInstance :: 90 | ( MonadAff m 91 | , MonadError e m 92 | , MonadReader r m 93 | ) => 94 | MonadSelda m e r 95 | 96 | runSelda 97 | :: forall a e r 98 | . r 99 | -> ExceptT e (ReaderT r Aff) a 100 | -> Aff (Either e a) 101 | runSelda conn m = runReaderT (runExceptT m) conn 102 | -------------------------------------------------------------------------------- /src/Selda/Table/Constraint.purs: -------------------------------------------------------------------------------- 1 | module Selda.Table.Constraint where 2 | 3 | import Prim.Row as R 4 | import Prim.RowList as RL 5 | import Type.RowList (class ListToRow, class RowListAppend) 6 | 7 | -- | Auto Constraint 8 | foreign import data Auto :: Type -> Type 9 | 10 | -- | Default Constraint 11 | foreign import data Default :: Type -> Type 12 | 13 | class EraseConstraint :: forall k1 k2. k1 -> k2 -> Constraint 14 | class EraseConstraint a b | a -> b 15 | 16 | instance eraseAuto :: EraseConstraint (Auto col) col 17 | else instance eraseDefault :: EraseConstraint (Default col) col 18 | else instance nothingToErase :: EraseConstraint col col 19 | 20 | class MaxColumnsToInsert :: Row Type -> RL.RowList Type -> Constraint 21 | class MaxColumnsToInsert t maxCols | t -> maxCols 22 | 23 | instance maxColumnsToInsert :: 24 | ( RL.RowToList t tl 25 | , FilterOutConstraintColumns tl simpleCols 26 | , FilterDefaultColumns tl defaultCols 27 | , RowListAppend simpleCols defaultCols maxCols 28 | ) => 29 | MaxColumnsToInsert t maxCols 30 | 31 | class MinColumnsToInsert :: Row Type -> RL.RowList Type -> Constraint 32 | class MinColumnsToInsert t minCols | t -> minCols 33 | 34 | instance minColumnsToInsert :: 35 | ( RL.RowToList t tl 36 | , FilterOutConstraintColumns tl minCols 37 | ) => 38 | MinColumnsToInsert t minCols 39 | 40 | -- | Removes `Auto` and `Default` columns from `i` 41 | class FilterOutConstraintColumns :: RL.RowList Type -> RL.RowList Type -> Constraint 42 | class FilterOutConstraintColumns i o | i -> o 43 | 44 | instance filterOutConstraintColumnsNil :: FilterOutConstraintColumns RL.Nil RL.Nil 45 | else instance filterOutConstraintColumnsAuto :: 46 | FilterOutConstraintColumns tail rl => 47 | FilterOutConstraintColumns (RL.Cons sym (Auto t) tail) rl 48 | else instance filterOutConstraintColumnsDefault :: 49 | FilterOutConstraintColumns tail rl => 50 | FilterOutConstraintColumns (RL.Cons sym (Default t) tail) rl 51 | else instance filterOutConstraintColumnsCons :: 52 | FilterOutConstraintColumns tail rl => 53 | FilterOutConstraintColumns (RL.Cons sym t tail) (RL.Cons sym t rl) 54 | 55 | -- | Returns only `Default` columns with erased `Default` wrapper 56 | class FilterDefaultColumns :: RL.RowList Type -> RL.RowList Type -> Constraint 57 | class FilterDefaultColumns (i :: RL.RowList Type) (o :: RL.RowList Type) | i -> o 58 | 59 | instance filterDefaultColumnsNil :: FilterDefaultColumns RL.Nil RL.Nil 60 | else instance filterDefaultColumnsConsDefault :: 61 | FilterDefaultColumns tail rl => 62 | FilterDefaultColumns (RL.Cons sym (Default t) tail) (RL.Cons sym t rl) 63 | else instance filterDefaultColumnsSkip :: 64 | FilterDefaultColumns tail rl => 65 | FilterDefaultColumns (RL.Cons sym t tail) rl 66 | 67 | class IsSubRowList :: RL.RowList Type -> RL.RowList Type -> Constraint 68 | class IsSubRowList lhs rhs 69 | 70 | instance isSubRowList :: 71 | ( ListToRow rl1 r1 72 | , ListToRow rl2 r2 73 | , R.Union r1 diff r2 74 | ) => 75 | IsSubRowList rl1 rl2 76 | 77 | class CanInsertColumnsIntoTable :: RL.RowList Type -> Row Type -> Constraint 78 | class CanInsertColumnsIntoTable cols t 79 | 80 | instance canInsertColumnsIntoTable :: 81 | ( MaxColumnsToInsert t maxCols 82 | , MinColumnsToInsert t minCols 83 | , IsSubRowList minCols cols 84 | , IsSubRowList cols maxCols 85 | ) => 86 | CanInsertColumnsIntoTable cols t 87 | 88 | -------------------------------------------------------------------------------- /src/Selda.purs: -------------------------------------------------------------------------------- 1 | module Selda 2 | ( module Query.Type 3 | , module Col 4 | , module Lit 5 | , module ShowStatement 6 | , module Query 7 | , module Table 8 | , module Expr.Ord 9 | , in_ 10 | , count 11 | , max_ 12 | , sum_ 13 | , not_ 14 | , inArray 15 | , isNull 16 | , isNull_ 17 | , expAnd 18 | , expOr 19 | , asc 20 | , desc 21 | ) where 22 | 23 | import Prelude 24 | 25 | import Data.Exists (mkExists) 26 | import Data.Maybe (Maybe) 27 | import Data.Newtype (unwrap) 28 | import Dodo as Dodo 29 | import Selda.Aggr (Aggr(..)) 30 | import Selda.Col (Col(..)) as Col 31 | import Selda.Col (Col(..), showCol) 32 | import Selda.Expr (Expr(..), Fn(..), InArray(..), UnExp(..), UnOp(..)) 33 | import Selda.Expr.Ord ((.==), (./=), (.>), (.>=), (.<), (.<=)) as Expr.Ord 34 | import Selda.Lit (lit, class Lit) as Lit 35 | import Selda.Query (crossJoin, crossJoin_, innerJoin, innerJoin_, restrict, having, notNull, notNull_, union, unionAll, intersect, except, leftJoin, leftJoin_, distinct, aggregate, groupBy, groupBy', selectFrom, selectFrom_, limit, offset, orderBy) as Query 36 | import Selda.Query.PrettyPrint (dodoPrint) 37 | import Selda.Query.ShowStatement (ppQuery) 38 | import Selda.Query.ShowStatement (showQuery, showDeleteFrom, showUpdate) as ShowStatement 39 | import Selda.Query.Type (Order(..), FullQuery) 40 | import Selda.Query.Type (Query(..), FullQuery(..)) as Query.Type 41 | import Selda.Table (Table(..)) as Table 42 | 43 | asc :: Order 44 | asc = Asc 45 | 46 | desc :: Order 47 | desc = Desc 48 | 49 | -- infixl 4 `like` 50 | infixr 3 expAnd as .&& 51 | infixr 2 expOr as .|| 52 | 53 | -- | SQL `IN` expression - tests whether a given column expression `Col s a` 54 | -- | is present in the result set of the given sub query. 55 | in_ 56 | :: forall s a 57 | . Col s a 58 | -> (forall z. FullQuery z { x :: Col z a }) 59 | -> Col s Boolean 60 | in_ col subQ = Col $ Any do 61 | c <- showCol col 62 | doc <- ppQuery subQ 63 | let q = dodoPrint $ Dodo.indent $ Dodo.break <> doc <> Dodo.break 64 | pure $ c <> " IN (" <> q <> ")" 65 | 66 | count :: forall s a. Col s a -> Aggr s Int 67 | count (Col e) = Aggr $ Col $ EFn $ mkExists $ FnCount e identity 68 | 69 | -- | returns `Nothing` in case of empty set aggregation 70 | max_ :: forall s a. Col s a -> Aggr s (Maybe a) 71 | max_ (Col e) = Aggr $ Col $ EFn $ mkExists $ FnMax e identity 72 | 73 | sum_ :: forall s a. Col s a -> Aggr s (Maybe Int) 74 | sum_ (Col e) = Aggr $ Col $ EFn $ mkExists $ FnSum e identity 75 | 76 | not_ :: forall s. Col s Boolean -> Col s Boolean 77 | not_ (Col e) = Col $ EUnOp $ mkExists $ UnExp (Not identity identity) e 78 | 79 | inArray :: forall s a. Col s a -> Array (Col s a) -> Col s Boolean 80 | inArray (Col e) cols = Col $ EInArray $ mkExists $ InArray e exprs identity 81 | where 82 | exprs = map unwrap cols 83 | 84 | isNull :: forall s a. Col s (Maybe a) -> Col s Boolean 85 | isNull (Col e) = Col $ EUnOp $ mkExists $ UnExp (IsNull identity) e 86 | 87 | isNull_ :: forall s a. Aggr s (Maybe a) -> Aggr s Boolean 88 | isNull_ (Aggr col) = Aggr $ isNull col 89 | 90 | expAnd 91 | :: forall col s 92 | . HeytingAlgebra (col s Boolean) 93 | => col s Boolean 94 | -> col s Boolean 95 | -> col s Boolean 96 | expAnd = (&&) 97 | 98 | expOr 99 | :: forall col s 100 | . HeytingAlgebra (col s Boolean) 101 | => col s Boolean 102 | -> col s Boolean 103 | -> col s Boolean 104 | expOr = (||) 105 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let mkPackage = 2 | https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.0-20190626/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57 3 | 4 | let upstream = 5 | https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20221201/packages.dhall 6 | sha256:d1a68fa15709eaa686515eb5b9950d82c743f7bf73e3d87a4abe9e1be6fda571 7 | 8 | in upstream 9 | with postgresql-client = 10 | mkPackage 11 | [ "aff", "argonaut", "arrays", "assert", "bifunctors", "bytestrings" 12 | , "datetime", "decimals", "dotenv", "effect", "either", "enums" 13 | , "exceptions", "foldable-traversable", "foreign", "foreign-generic" 14 | , "foreign-object", "identity", "integers", "js-date", "lists", "maybe" 15 | , "newtype", "node-process", "nullable", "ordered-collections", "partial" 16 | , "polyform", "polyform-batteries-core", "polyform-batteries-env", "prelude" 17 | , "psci-support", "string-parsers", "strings", "test-unit", "transformers" 18 | , "tuples", "typelevel-prelude", "validation" 19 | ] 20 | "https://github.com/rightfold/purescript-postgresql-client.git" 21 | "v3.4.1" 22 | with 23 | polyform = 24 | mkPackage 25 | [ "heterogeneous", "js-unsafe-stringify", "newtype" ,"ordered-collections" 26 | , "variant", "profunctor", "invariant", "foreign-object" 27 | , "run", "transformers","validation", "foreign" 28 | ] 29 | "https://github.com/purescript-polyform/polyform.git" 30 | "v0.9.2" 31 | 32 | with 33 | polyform-batteries-core = mkPackage 34 | [ "debug", "decimals", "filterable", "numbers" 35 | , "polyform", "prelude", "record-extra", "test-unit" 36 | ] 37 | "https://github.com/purescript-polyform/batteries-core.git" 38 | "v0.3.0" 39 | with 40 | polyform-batteries-urlencoded = 41 | mkPackage 42 | [ "argonaut" , "console" , "debug" , "effect" , "form-urlencoded" 43 | , "polyform-batteries-core" , "psci-support" , "spec" 44 | ] 45 | "https://github.com/purescript-polyform/batteries-urlencoded.git" 46 | "v0.4.1" 47 | with polyform-batteries-env = 48 | mkPackage 49 | [ "arrays" 50 | , "identity" 51 | , "maybe" 52 | , "ordered-collections" 53 | , "polyform" 54 | , "polyform-batteries-core" 55 | , "prelude" 56 | , "psci-support" 57 | , "typelevel-prelude" 58 | ] 59 | "https://github.com/purescript-polyform/batteries-env.git" 60 | "v0.2.0" 61 | with bytestrings = 62 | mkPackage 63 | [ "arrays", "console", "effect", "exceptions", "foldable-traversable" 64 | , "integers", "leibniz", "maybe", "newtype", "node-buffer", "partial" 65 | , "prelude", "quickcheck", "quickcheck-laws", "quotient", "unsafe-coerce" 66 | ] 67 | "https://github.com/martyall/purescript-bytestrings.git" 68 | "e51cf868a4137c1c48c98d32115bb2014c9f7624" 69 | with quotient = 70 | mkPackage 71 | [ "prelude", "quickcheck" ] 72 | "https://github.com/rightfold/purescript-quotient.git" 73 | "v3.0.0" 74 | with foreign-generic = 75 | mkPackage 76 | [ "arrays", "assert", "bifunctors", "console", "control" 77 | , "effect", "either", "exceptions", "foldable-traversable" 78 | , "foreign", "foreign-object", "identity", "lists", "maybe" 79 | , "newtype", "partial", "prelude", "record", "strings" 80 | , "transformers", "tuples", "unsafe-coerce" 81 | ] 82 | "https://github.com/paluh/purescript-foreign-generic.git" 83 | "a5c23d29e72619624978446293ac9bb45ccd2fde" 84 | with js-unsafe-stringify = 85 | mkPackage 86 | ([] : List Text) 87 | "https://github.com/paluh/purescript-js-unsafe-stringify.git" 88 | "master" 89 | -------------------------------------------------------------------------------- /src/Selda/Query/ShowStatement.purs: -------------------------------------------------------------------------------- 1 | -- | Common to-string functions for SQL statements 2 | -- | (SELECT, UPDATE, DELETE, INSERT) shared between backends. 3 | module Selda.Query.ShowStatement where 4 | 5 | import Prelude 6 | 7 | import Data.Array (catMaybes) 8 | import Data.Array as Array 9 | import Data.Exists (runExists) 10 | import Data.Maybe (Maybe(..)) 11 | import Data.String (joinWith) 12 | import Data.Traversable (traverse) 13 | import Data.Tuple (Tuple(..)) 14 | import Prim.RowList as RL 15 | import Selda.Col (class GetCols, Col, getCols, showCol) 16 | import Selda.Expr (ShowM, showExpr) 17 | import Selda.Query.PrettyPrint (PrettyM, dodoPrint, ppState) 18 | import Selda.Query.Type (FullQuery, GenState(..), runFullQuery) 19 | import Selda.Query.Utils (class RowListLength, class TableToColsWithoutAlias, rowListLength, tableToColsWithoutAlias) 20 | import Selda.Table (class TableColumnNames, Table, showColumnName, tableColumnNames, tableName) 21 | import Selda.Table.Constraint (class CanInsertColumnsIntoTable) 22 | import Type.Proxy (Proxy(..)) 23 | 24 | ppQuery :: forall i s. GetCols i => FullQuery s { | i } -> PrettyM 25 | ppQuery q = ppState st 26 | where 27 | (Tuple res (GenState st')) = runFullQuery q 28 | st = st' { cols = getCols res } 29 | 30 | showQuery :: forall i s. GetCols i => FullQuery s (Record i) -> ShowM 31 | showQuery q = dodoPrint <$> ppQuery q 32 | 33 | showDeleteFrom 34 | :: forall t s r 35 | . TableToColsWithoutAlias s t r 36 | => Table t 37 | -> ({ | r } -> Col s Boolean) 38 | -> ShowM 39 | showDeleteFrom table pred = do 40 | let recordWithCols = tableToColsWithoutAlias (Proxy :: Proxy s) table 41 | pred_str <- showCol $ pred recordWithCols 42 | pure $ "DELETE FROM " <> tableName table <> " WHERE " <> pred_str 43 | 44 | showUpdate 45 | :: forall t s r 46 | . TableToColsWithoutAlias s t r 47 | => GetCols r 48 | => Table t 49 | -> ({ | r } -> Col s Boolean) 50 | -> ({ | r } -> { | r }) 51 | -> ShowM 52 | showUpdate table pred up = do 53 | let 54 | recordWithCols = tableToColsWithoutAlias (Proxy :: Proxy s) table 55 | f (Tuple name expr) = do 56 | updatedValue <- runExists showExpr expr 57 | let columnName = showColumnName name 58 | pure $ 59 | if columnName == updatedValue then Nothing 60 | else Just $ columnName <> " = " <> updatedValue 61 | pred_str <- showCol $ pred recordWithCols 62 | vals <- joinWith ", " <$> catMaybes <$> (traverse f $ getCols $ up recordWithCols) 63 | pure $ 64 | if vals == "" then "" 65 | else 66 | "UPDATE " <> tableName table <> " SET " <> vals <> " WHERE " <> pred_str 67 | 68 | -- | typeclass-alias for `genericShowInsert` constraints 69 | class GenericShowInsert t r where 70 | genericShowInsert 71 | :: { ph :: String } 72 | -> Table t 73 | -> Array { | r } 74 | -> String 75 | 76 | -- | the alias hides the auxiliary type parameter `rl` 77 | instance genericShowInsertImpl :: 78 | ( TableColumnNames rl 79 | , RL.RowToList r rl 80 | , CanInsertColumnsIntoTable rl t 81 | , RowListLength rl 82 | ) => 83 | GenericShowInsert t r 84 | where 85 | genericShowInsert { ph } table rs = 86 | let 87 | cols = joinWith ", " $ tableColumnNames (Proxy :: Proxy rl) 88 | len = rowListLength (Proxy :: Proxy rl) 89 | placeholders = mkPlaceholders ph 1 len $ Array.length rs 90 | in 91 | [ "INSERT INTO ", tableName table, " (", cols, ") VALUES ", placeholders, ";" ] 92 | # joinWith "" 93 | 94 | mkPlaceholders :: String -> Int -> Int -> Int -> String 95 | mkPlaceholders ph fstPH len n = 96 | if n <= 0 then "" 97 | else 98 | Array.range 0 (n - 1) 99 | # map ((*) len >>> (+) fstPH >>> phs) 100 | # joinWith ", " 101 | where 102 | phs i = 103 | Array.range i (i + len - 1) 104 | # map (\j -> ph <> show j) 105 | # joinWith ", " 106 | # \s -> "(" <> s <> ")" 107 | -------------------------------------------------------------------------------- /src/Selda/Query/Type.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query.Type where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.State (class MonadState, State, runState) 6 | import Control.Monad.State as State 7 | import Data.Exists (Exists) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Newtype (class Newtype, unwrap, wrap) 10 | import Data.Tuple (Tuple) 11 | import Selda.Expr (Expr) 12 | import Selda.Table (AliasedTable, Alias) 13 | import Unsafe.Coerce (unsafeCoerce) 14 | 15 | -- table or subquery, each with alias 16 | data SQL 17 | = FromTable AliasedTable 18 | | SubQuery Alias GenState 19 | 20 | -- describes elements which appear after FROM in generated sql 21 | data Source 22 | = From SQL 23 | | CrossJoin Source SQL 24 | | JoinOn JoinType Source SQL (Expr Boolean) 25 | | Combination QBinOp GenState GenState Alias 26 | 27 | data JoinType 28 | = LeftJoin 29 | | InnerJoin 30 | 31 | data QBinOp 32 | = Union 33 | | UnionAll 34 | | Intersect 35 | | Except 36 | 37 | -- main state 38 | -- FROM+JOIN[S] components in `source` 39 | -- WHERE components in `restricts` 40 | -- SELECT components in `cols`, list of `Expr a`, where type `a` is irrelevant 41 | -- `nextId` provides fresh identifiers 42 | type GenState_ = 43 | { source :: Source 44 | , restricts :: Array (Expr Boolean) 45 | , havings :: Array (Expr Boolean) 46 | , nextId :: Int 47 | , cols :: Array (Tuple Alias (Exists Expr)) 48 | , aggr :: Array (Exists Expr) 49 | , order :: Array (Tuple Order (Exists Expr)) 50 | , limit :: Maybe Int 51 | , offset :: Maybe Int 52 | , distinct :: Boolean 53 | } 54 | 55 | newtype GenState = GenState GenState_ 56 | 57 | derive instance newtypeGenState :: Newtype GenState _ 58 | 59 | -- | Represents an intermediate query state. 60 | -- | Before being wrapped with FullQuery this state represents SQL query without 61 | -- | FROM component, but having every other including JOIN[s] 62 | newtype Query :: forall k. k -> Type -> Type 63 | newtype Query s a = Query (State GenState a) 64 | 65 | derive instance newtypeQuery :: Newtype (Query s a) _ 66 | derive newtype instance functorQuery :: Functor (Query s) 67 | derive newtype instance applyQuery :: Apply (Query s) 68 | derive newtype instance applicativeQuery :: Applicative (Query s) 69 | derive newtype instance bindQuery :: Bind (Query s) 70 | derive newtype instance monadQuery :: Monad (Query s) 71 | derive newtype instance stateQuery :: MonadState GenState (Query s) 72 | 73 | -- | wrapper for query that is ready for SQL generation 74 | newtype FullQuery :: forall k. k -> Type -> Type 75 | newtype FullQuery s a = FullQuery (Query s a) 76 | 77 | derive instance newtypeFullQuery :: Newtype (FullQuery s a) _ 78 | derive newtype instance functorFullQuery :: Functor (FullQuery s) 79 | derive newtype instance applyFullQuery :: Apply (FullQuery s) 80 | derive newtype instance applicativeFullQuery :: Applicative (FullQuery s) 81 | derive newtype instance bindFullQuery :: Bind (FullQuery s) 82 | derive newtype instance monadFullQuery :: Monad (FullQuery s) 83 | 84 | data Order = Asc | Desc 85 | 86 | initState :: GenState 87 | initState = GenState 88 | { source: (unsafeCoerce unit :: Source) 89 | , restricts: [] 90 | , havings: [] 91 | , nextId: 0 92 | , cols: [] 93 | , aggr: [] 94 | , order: [] 95 | , limit: Nothing 96 | , offset: Nothing 97 | , distinct: false 98 | } 99 | 100 | get :: forall s. Query s GenState_ 101 | get = unwrap <$> State.get 102 | 103 | put :: forall s. GenState_ -> Query s Unit 104 | put = State.put <<< wrap 105 | 106 | modify_ :: forall s. (GenState_ -> GenState_) -> Query s Unit 107 | modify_ f = do 108 | st <- get 109 | put $ f st 110 | 111 | freshId :: forall s. Query s Int 112 | freshId = do 113 | st <- get 114 | put $ st { nextId = st.nextId + 1 } 115 | pure st.nextId 116 | 117 | runQuery :: forall a s. Query s a -> Tuple a GenState 118 | runQuery (Query st) = runState st initState 119 | 120 | runFullQuery :: forall a s. FullQuery s a -> Tuple a GenState 121 | runFullQuery = unwrap >>> runQuery 122 | -------------------------------------------------------------------------------- /src/Selda/Table.purs: -------------------------------------------------------------------------------- 1 | module Selda.Table 2 | ( Column(..) 3 | , AliasedTable 4 | , Alias 5 | , StringSQL 6 | , showColumn 7 | , showColumnName 8 | , Table(..) 9 | , tableName 10 | , class TableColumns 11 | , tableColumns 12 | , class TableColumnNames 13 | , tableColumnNames 14 | ) where 15 | 16 | import Prelude 17 | 18 | import Data.Maybe (Maybe(..)) 19 | import Data.String (Pattern(..), Replacement(..), replace) as String 20 | import Data.Symbol (class IsSymbol, reflectSymbol) 21 | import Prim.Row as R 22 | import Prim.RowList as RL 23 | import Record as Record 24 | import Selda.Table.Constraint (class EraseConstraint) 25 | import Type.Proxy (Proxy(..)) 26 | 27 | -- | Represents table-like SQL sources. 28 | -- | 29 | -- | `Table` constructor is used for simple cases. 30 | -- | **It requires a table name, which is not namespaced!** 31 | -- | The given `name` is used as an alias prefix for its columns, 32 | -- | meaning each column is namespaced using a full alias 33 | -- | that is a combination of the table's `name` and a unique number 34 | -- | supplied during query generation. 35 | -- | 36 | -- | `Source` covers more flexible cases. 37 | -- | It requires an alias prefix and a way to create an SQL string 38 | -- | (which is used in the `FROM` or `JOIN` SQL clause) 39 | -- | with or without a full alias (which is a combination of an alias prefix 40 | -- | and a unique number supplied during query generation). 41 | data Table :: Row Type -> Type 42 | data Table r 43 | = Table { name :: String } 44 | | Source Alias (Maybe Alias -> StringSQL) 45 | 46 | tableName :: forall t. Table t -> String 47 | tableName = case _ of 48 | Table { name } -> name 49 | Source _ f -> f Nothing 50 | 51 | type Alias = String 52 | 53 | type StringSQL = String 54 | 55 | -- | Table-like source has two components: 56 | -- | - body (SQL appearing after FROM or JOIN) 57 | -- | - alias (used as a namespace for columns of the Table-like source) 58 | type AliasedTable = { body :: String, alias :: Alias } 59 | 60 | newtype Column :: forall k. k -> Type 61 | newtype Column a = Column { namespace :: Alias, name :: String } 62 | 63 | -- Table { name ∷ String, id ∷ Int } → { name ∷ Column String, id ∷ Column Int } 64 | class TableColumns :: RL.RowList Type -> Row Type -> Constraint 65 | class TableColumns rl r | rl -> r where 66 | tableColumns :: forall t proxy. { alias :: Alias | t } -> proxy rl -> Record r 67 | 68 | instance tableColumnsNil :: TableColumns RL.Nil () where 69 | tableColumns _ _ = {} 70 | 71 | instance tableColumnsCons :: 72 | ( IsSymbol sym 73 | , R.Lacks sym r' 74 | , EraseConstraint t t' 75 | , R.Cons sym (Column t') r' r 76 | , TableColumns tail r' 77 | ) => 78 | TableColumns (RL.Cons sym t tail) r 79 | where 80 | tableColumns table _ = 81 | let 82 | _sym = (Proxy :: Proxy sym) 83 | res' = tableColumns table (Proxy :: Proxy tail) 84 | col = Column 85 | { namespace: table.alias 86 | , name: showColumnName $ reflectSymbol _sym 87 | } 88 | in 89 | Record.insert _sym col res' 90 | 91 | class TableColumnNames :: RL.RowList Type -> Constraint 92 | class TableColumnNames rl where 93 | tableColumnNames :: forall proxy. proxy rl -> Array String 94 | 95 | instance tableColumnNamesHead :: TableColumnNames RL.Nil where 96 | tableColumnNames _ = [] 97 | else instance tableColumnNamesCons :: 98 | ( IsSymbol sym 99 | , TableColumnNames tail 100 | ) => 101 | TableColumnNames (RL.Cons sym t tail) 102 | where 103 | tableColumnNames _ = tableColumnNames _tail 104 | <> [ showColumnName $ reflectSymbol _sym ] 105 | where 106 | _tail = (Proxy :: Proxy tail) 107 | _sym = (Proxy :: Proxy sym) 108 | 109 | showColumnName :: String -> String 110 | showColumnName name = "\"" <> name <> "\"" 111 | 112 | showColumn :: forall a. Column a -> String 113 | showColumn (Column { namespace, name }) 114 | | namespace == "" = name 115 | | otherwise = namespace <> "." <> name 116 | 117 | -- | Escape double quotes in an SQL identifier. 118 | escapeQuotes :: String -> String 119 | escapeQuotes = String.replace (String.Pattern "\"") (String.Replacement "\"\"") 120 | -------------------------------------------------------------------------------- /src/Selda/Query/PrettyPrint.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query.PrettyPrint 2 | ( PrettyM 3 | , prettyM 4 | , ppState 5 | , dodoPrint 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Control.Apply (lift2) 11 | import Control.Monad.Reader (ReaderT) 12 | import Control.Monad.State (State) 13 | import Data.Exists (Exists, runExists) 14 | import Data.Newtype (unwrap) 15 | import Data.Traversable (traverse) 16 | import Data.Tuple (Tuple, uncurry) 17 | import Data.Tuple.Nested ((/\)) 18 | import Dodo (Doc, alignCurrentColumn, appendBreak, break, foldWithSeparator, indent, isEmpty, lines, plainText, print, text, twoSpaces) 19 | import Foreign (Foreign) 20 | import Selda.Expr (Expr, QueryParams, ShowMCtx, showExpr, showM) 21 | import Selda.Query.ShowQuery (ishowAliasedCol, ishowCompoundOp, ishowJoinType, ishowLimitOffset, ishowOrder) 22 | import Selda.Query.Type (GenState_, Order, SQL(..), Source(..)) 23 | import Selda.Table (Alias) 24 | 25 | type PrettyM = ReaderT ShowMCtx (State QueryParams) (Doc String) 26 | 27 | prettyM 28 | :: String 29 | -> Int 30 | -> PrettyM 31 | -> { params :: Array Foreign, nextIndex :: Int, strQuery :: String } 32 | prettyM ph i m = showM ph i $ dodoPrint <$> m 33 | 34 | ppState :: GenState_ -> PrettyM 35 | ppState { cols, source, restricts, havings, aggr, order, limit, offset, distinct } = 36 | ppCols distinct cols 37 | `appDoc` ppFrom source 38 | `appTxt` ppRestricts restricts 39 | `appTxt` ppGrouping aggr 40 | `appTxt` ppHavings havings 41 | `appTxt` ppOrdering order 42 | `appTxt` (pure <<< text <<< uncurry ishowLimitOffset) (limit /\ offset) 43 | where 44 | appDoc = lift2 appendBreak 45 | appTxt = lift2 appendNonEmptyDoc 46 | appendNonEmptyDoc a b = 47 | if isEmpty b then a 48 | else a <> break <> b 49 | 50 | ppCols :: Boolean -> Array (Tuple Alias (Exists Expr)) -> PrettyM 51 | ppCols distinct = ppXS clause commaBreak (map text <<< ishowAliasedCol) 52 | where 53 | clause = "SELECT " <> if distinct then "DISTINCT " else "" 54 | 55 | ppFrom :: Source -> PrettyM 56 | ppFrom source = (text "FROM " <> _) <$> ppSource source 57 | 58 | ppSource :: Source -> PrettyM 59 | ppSource = case _ of 60 | From t -> ppSQL t 61 | CrossJoin src sql -> do 62 | src' <- ppSource src 63 | sql' <- ppSQL sql 64 | pure $ src' <> break <> text "CROSS JOIN " <> sql' 65 | JoinOn joinType src sql e -> do 66 | src' <- ppSource src 67 | sql' <- ppSQL sql 68 | e' <- showExpr e 69 | pure $ src' <> break 70 | <> text (ishowJoinType joinType) 71 | <> sql' 72 | <> text (" ON (" <> e' <> ")") 73 | Combination op q1 q2 alias -> do 74 | s1 <- ppState $ unwrap q1 75 | s2 <- ppState $ unwrap q2 76 | let 77 | ppCombinedSubQuery s = lines 78 | [ text "SELECT * FROM" 79 | , text "(" <> alignCurrentColumn s 80 | , text ") combined_sub_query" 81 | ] 82 | pure $ indent $ (break <> _) $ lines 83 | [ text "(" <> alignCurrentColumn (ppCombinedSubQuery s1) 84 | , text (ishowCompoundOp op) 85 | , text " " <> alignCurrentColumn (ppCombinedSubQuery s2) 86 | , text (") " <> alias) 87 | ] 88 | 89 | ppSQL :: SQL -> PrettyM 90 | ppSQL = case _ of 91 | FromTable t -> pure $ text t.body 92 | SubQuery alias state -> do 93 | s <- ppState $ unwrap state 94 | pure $ indent $ break 95 | <> text "(" 96 | <> alignCurrentColumn s 97 | <> break 98 | <> text (") " <> alias) 99 | 100 | ppRestricts :: Array (Expr Boolean) -> PrettyM 101 | ppRestricts = ppXS "WHERE " (break <> text "AND ") ppExpr 102 | 103 | ppHavings :: Array (Expr Boolean) -> PrettyM 104 | ppHavings = ppXS "HAVING " (break <> text "AND ") ppExpr 105 | 106 | ppGrouping :: Array (Exists Expr) -> PrettyM 107 | ppGrouping = ppXS "GROUP BY " commaBreak $ runExists ppExpr 108 | 109 | ppOrdering :: Array (Tuple Order (Exists Expr)) -> PrettyM 110 | ppOrdering = ppXS "ORDER BY " commaBreak (map text <<< ishowOrder) 111 | 112 | dodoPrint :: forall a. Doc a -> String 113 | dodoPrint = print plainText twoSpaces 114 | 115 | ppExpr :: forall a. Expr a -> PrettyM 116 | ppExpr e = text <$> showExpr e 117 | 118 | commaBreak :: forall a. Doc a 119 | commaBreak = text "," <> break 120 | 121 | ppXS :: forall a d m. Monad m => String -> Doc d -> (a -> m (Doc d)) -> Array a -> m (Doc d) 122 | ppXS clause sep f = case _ of 123 | [] -> pure $ mempty 124 | xs -> do 125 | ss <- traverse f xs 126 | pure $ text clause 127 | <> alignCurrentColumn (foldWithSeparator sep ss) 128 | -------------------------------------------------------------------------------- /src/Selda/SQLite3/Class.purs: -------------------------------------------------------------------------------- 1 | module Selda.SQLite3.Class 2 | ( class MonadSeldaSQLite3 3 | , query 4 | , query1 5 | , insert_ 6 | , deleteFrom 7 | , update 8 | , BackendSQLite3Class 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Control.Monad.Reader (ask) 14 | import Data.Array (null) 15 | import Data.Array as Array 16 | import Data.Either (either) 17 | import Data.List.Types (NonEmptyList) 18 | import Data.Maybe (Maybe) 19 | import Effect.Aff (throwError) 20 | import Effect.Aff.Class (liftAff) 21 | import Foreign (Foreign, ForeignError, MultipleErrors) 22 | import Heterogeneous.Folding (class HFoldl) 23 | import SQLite3 (DBConnection, queryDB) 24 | import Selda.Col (Col, class GetCols) 25 | import Selda.Query.Class (class GenericDelete, class GenericInsert, class GenericQuery, class GenericUpdate, class MonadSelda, genericDelete, genericInsert, genericInsert_, genericQuery, genericUpdate) 26 | import Selda.Query.ShowStatement (class GenericShowInsert, showQuery, showDeleteFrom, showUpdate) 27 | import Selda.Query.Type (FullQuery) 28 | import Selda.Query.Utils (class MapR, class TableToColsWithoutAlias, class ToForeign, RecordToArrayForeign, UnCol_) 29 | import Selda.SQLite3 (showSQLite3_) 30 | import Selda.Table (Table) 31 | import Simple.JSON (class ReadForeign, class WriteForeign, read, write) 32 | import Type.Proxy (Proxy(..)) 33 | 34 | type B = BackendSQLite3Class 35 | 36 | data BackendSQLite3Class 37 | 38 | class 39 | ( MonadSelda m (NonEmptyList ForeignError) DBConnection 40 | ) <= 41 | MonadSeldaSQLite3 m 42 | 43 | instance monadSeldaSQLite3Instance :: 44 | MonadSelda m MultipleErrors DBConnection => 45 | MonadSeldaSQLite3 m 46 | 47 | query 48 | :: forall m i o 49 | . GenericQuery BackendSQLite3Class m i o 50 | => FullQuery B { | i } 51 | -> m (Array { | o }) 52 | query = genericQuery (Proxy :: Proxy BackendSQLite3Class) 53 | 54 | query1 55 | :: forall m i o 56 | . GenericQuery BackendSQLite3Class m i o 57 | => FullQuery B { | i } 58 | -> m (Maybe { | o }) 59 | query1 q = query q <#> Array.head 60 | 61 | instance genericQuerySQLite3 :: 62 | ( MonadSeldaSQLite3 m 63 | , ReadForeign { | o } 64 | , MapR UnCol_ i o 65 | , GetCols i 66 | ) => 67 | GenericQuery BackendSQLite3Class m i o 68 | where 69 | genericQuery _ q = do 70 | rows <- execSQLite3 # showSQLite3_ (showQuery q) 71 | either throwError pure (read rows) 72 | 73 | insert_ 74 | :: forall m t r 75 | . GenericInsert BackendSQLite3Class m t r 76 | => Table t 77 | -> Array { | r } 78 | -> m Unit 79 | insert_ = genericInsert (Proxy :: Proxy BackendSQLite3Class) 80 | 81 | instance sqlite3ToForeign :: WriteForeign a => ToForeign BackendSQLite3Class a where 82 | toForeign _ = write 83 | 84 | instance genericInsertSQLite3 :: 85 | ( HFoldl (RecordToArrayForeign BackendSQLite3Class) 86 | (Array Foreign) 87 | { | r } 88 | (Array Foreign) 89 | , MonadSeldaSQLite3 m 90 | , GenericShowInsert t r 91 | ) => 92 | GenericInsert BackendSQLite3Class m t r 93 | where 94 | genericInsert proxy table l = when (not $ null l) do 95 | genericInsert_ { exec: execSQLite3_, ph: "?" } proxy table l 96 | 97 | deleteFrom 98 | :: forall t r m 99 | . GenericDelete BackendSQLite3Class m t r 100 | => Table t 101 | -> ({ | r } -> Col B Boolean) 102 | -> m Unit 103 | deleteFrom = genericDelete (Proxy :: Proxy BackendSQLite3Class) 104 | 105 | instance genericDeleteSQLite3 :: 106 | ( TableToColsWithoutAlias B t r 107 | , MonadSeldaSQLite3 m 108 | ) => 109 | GenericDelete BackendSQLite3Class m t r 110 | where 111 | genericDelete _ table pred = 112 | execSQLite3_ # showSQLite3_ (showDeleteFrom table pred) 113 | 114 | update 115 | :: forall t r m 116 | . GenericUpdate BackendSQLite3Class m t r 117 | => Table t 118 | -> ({ | r } -> Col B Boolean) 119 | -> ({ | r } -> { | r }) 120 | -> m Unit 121 | update = genericUpdate (Proxy :: Proxy BackendSQLite3Class) 122 | 123 | instance genericUpdateSQLite3 :: 124 | ( TableToColsWithoutAlias B t r 125 | , GetCols r 126 | , MonadSeldaSQLite3 m 127 | ) => 128 | GenericUpdate BackendSQLite3Class m t r 129 | where 130 | genericUpdate _ table pred up = 131 | execSQLite3_ # showSQLite3_ (showUpdate table pred up) 132 | 133 | -- | Utility function to execute a given query (as String) with parameters 134 | execSQLite3 :: forall m. MonadSeldaSQLite3 m => String -> Array Foreign -> m Foreign 135 | execSQLite3 q params = do 136 | conn <- ask 137 | liftAff $ queryDB conn q params 138 | 139 | -- | Utility function to execute a given query (as String) with parameters and discard the result 140 | execSQLite3_ :: forall m. MonadSeldaSQLite3 m => String -> Array Foreign -> m Unit 141 | execSQLite3_ q l = when (q /= "") $ void $ execSQLite3 q l 142 | -------------------------------------------------------------------------------- /src/Selda/Query/Utils.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query.Utils where 2 | 3 | import Prelude 4 | 5 | import Data.Symbol (class IsSymbol) 6 | import Data.Tuple (Tuple(..)) 7 | import Foreign (Foreign) 8 | import Heterogeneous.Folding (class Folding, class FoldingWithIndex, class HFoldlWithIndex, hfoldlWithIndex) 9 | import Prim.Row as R 10 | import Prim.RowList as RL 11 | import Prim.TypeError (class Fail, Text, Beside) 12 | import Record as Record 13 | import Selda.Col (class ToCols, Col, toCols) 14 | import Selda.Table (class TableColumns, Table, tableColumns) 15 | import Type.Proxy (Proxy(..)) 16 | import Type.RowList (class ListToRow) 17 | 18 | type App :: forall k1 k2. (k1 -> k2) -> k1 -> k2 19 | type App a b = a b 20 | 21 | infixr 0 type App as :=> 22 | 23 | class MappingRL :: forall k1 k2 k3. k1 -> k2 -> k3 -> Constraint 24 | class MappingRL f a b | f a -> b 25 | 26 | class MapRL :: forall k. k -> RL.RowList Type -> RL.RowList Type -> Constraint 27 | class MapRL f i o | f i -> o 28 | 29 | instance mapRLNil :: MapRL f RL.Nil RL.Nil 30 | instance mapRLCons :: 31 | ( MappingRL f a a' 32 | , MapRL f tail tail' 33 | ) => 34 | MapRL f (RL.Cons sym a tail) (RL.Cons sym a' tail') 35 | 36 | class MapR :: forall k. k -> Row Type -> Row Type -> Constraint 37 | class MapR f i o | f i -> o 38 | 39 | instance mapR :: 40 | ( RL.RowToList i il 41 | , MapRL f il ol 42 | , ListToRow ol o 43 | ) => 44 | MapR f i o 45 | 46 | data UnCol_ 47 | 48 | instance unColRL :: UnCol a b => MappingRL UnCol_ a b 49 | 50 | -- | For record 51 | -- | `{ n1 ∷ Col s String, n2 ∷ Col s String, id ∷ Col s Int }` 52 | -- | build function 53 | -- | \Tuple int (Tuple string1 string2) 54 | -- | → { id: int, n1: string1, n2: string2 } 55 | class ColsToPGHandler :: forall k. k -> Row Type -> Type -> Row Type -> Constraint 56 | class ColsToPGHandler s i tup o | s i -> tup o where 57 | colsToPGHandler :: forall proxy. proxy s -> { | i } -> (tup -> { | o }) 58 | 59 | instance colsToPGHandlerI :: 60 | ( RL.RowToList i il 61 | , ValidateSInCols s il 62 | , HFoldlWithIndex TupleToRecordFunc (Unit -> {}) { | i } (tup -> { | o }) 63 | ) => 64 | ColsToPGHandler s i tup o 65 | where 66 | colsToPGHandler _ i = hfoldlWithIndex TupleToRecordFunc f i 67 | where 68 | f = (const {} :: Unit -> {}) 69 | 70 | class ValidateSInCols :: forall k. k -> RL.RowList Type -> Constraint 71 | class ValidateSInCols s il 72 | 73 | instance rLUnColNil :: ValidateSInCols s RL.Nil 74 | else instance rLUnColCons :: 75 | ValidateSInCols s tail => 76 | ValidateSInCols s (RL.Cons sym (Col s t) tail) 77 | else instance failValidateSInCols :: 78 | Fail (Text sym <:> Text " is not Col or the scope 's' is wrong") => 79 | ValidateSInCols s (RL.Cons sym col tail) 80 | 81 | class UnCol :: forall k1 k2. k1 -> k2 -> Constraint 82 | class UnCol i o | i -> o 83 | 84 | instance mapTypeCol :: UnCol (Col s a) a 85 | 86 | data TupleToRecordFunc = TupleToRecordFunc 87 | 88 | instance tupToRec :: 89 | ( IsSymbol sym 90 | , R.Lacks sym r 91 | , R.Cons sym a r r' 92 | , UnCol i a 93 | ) => 94 | FoldingWithIndex TupleToRecordFunc 95 | (Proxy sym) 96 | (tup -> { | r }) 97 | i 98 | (Tuple a tup -> { | r' }) 99 | where 100 | foldingWithIndex TupleToRecordFunc _ f _ = 101 | \(Tuple a tup) -> Record.insert (Proxy :: Proxy sym) a $ f tup 102 | 103 | data RecordToTuple = RecordToTuple 104 | 105 | instance rToTuple :: Folding RecordToTuple tail a (Tuple a tail) where 106 | folding _ tail a = Tuple a tail 107 | 108 | data RecordToArrayForeign :: forall k. k -> Type 109 | data RecordToArrayForeign b = RecordToArrayForeign (Proxy b) 110 | 111 | instance rToArrForeign :: 112 | ToForeign b a => 113 | Folding (RecordToArrayForeign b) (Array Foreign) a (Array Foreign) 114 | where 115 | folding (RecordToArrayForeign b) acc a = [ toForeign b a ] <> acc 116 | 117 | class ToForeign :: forall k. k -> Type -> Constraint 118 | class ToForeign b a where 119 | toForeign :: forall proxy. proxy b -> a -> Foreign 120 | 121 | class TupleRev t1 acc t2 | t1 acc -> t2 where 122 | tupleRev :: t1 -> acc -> t2 123 | 124 | instance tuplerevh :: TupleRev Unit acc acc where 125 | tupleRev _ t = t 126 | else instance tuplerevc :: 127 | TupleRev b (Tuple a acc) res => 128 | TupleRev (Tuple a b) acc res 129 | where 130 | tupleRev (Tuple a b) acc = tupleRev b (Tuple a acc) 131 | 132 | data RecordLength = RecordLength 133 | 134 | instance rlen :: Folding RecordLength Int a Int where 135 | folding _ acc _ = acc + 1 136 | 137 | class RowListLength :: forall k. k -> Constraint 138 | class RowListLength rl where 139 | rowListLength :: forall proxy. proxy rl -> Int 140 | 141 | instance rowListLengthNil :: RowListLength RL.Nil where 142 | rowListLength _ = 0 143 | else instance rowListLengthCons :: RowListLength t => RowListLength (RL.Cons s a t) where 144 | rowListLength _ = rowListLength (Proxy :: Proxy t) + 1 145 | 146 | -- | ```purescript 147 | -- | Table ( a1 ∷ A1 , a2 ∷ A2 ... ) 148 | -- | → 149 | -- | { a1 ∷ Col s A1, a2 ∷ Col s A2 ... } 150 | -- | ``` 151 | class TableToColsWithoutAlias :: forall k. k -> Row Type -> Row Type -> Constraint 152 | class TableToColsWithoutAlias s r o | r -> o where 153 | tableToColsWithoutAlias :: forall proxy. proxy s -> Table r -> { | o } 154 | 155 | instance tableToColsI :: 156 | ( RL.RowToList r rl 157 | , TableColumns rl i 158 | , ToCols s i o 159 | ) => 160 | TableToColsWithoutAlias s r o 161 | where 162 | tableToColsWithoutAlias _ _ = recordWithCols 163 | where 164 | recordWithColumns = tableColumns { alias: "" } (Proxy :: Proxy rl) 165 | recordWithCols = toCols (Proxy :: Proxy s) recordWithColumns 166 | 167 | infixl 4 type Beside as <:> 168 | -------------------------------------------------------------------------------- /src/Selda/Expr.purs: -------------------------------------------------------------------------------- 1 | module Selda.Expr 2 | ( showExpr 3 | 4 | -- internal AST for expressions 5 | , Expr(..) 6 | , Literal(..) 7 | , None(..) 8 | , BinOp(..) 9 | , UnOp(..) 10 | , BinExp(..) 11 | , UnExp(..) 12 | , Fn(..) 13 | , InArray(..) 14 | 15 | -- ShowM monad for handling serialization of Col's 16 | , showM 17 | , ShowM 18 | , ShowMCtx 19 | , QueryParams 20 | ) where 21 | 22 | import Prelude 23 | 24 | import Control.Monad.Reader (ReaderT, ask, runReaderT) 25 | import Control.Monad.State (State, get, put, runState) 26 | import Data.Array as Array 27 | import Data.Exists (Exists, runExists) 28 | import Data.Leibniz (type (~)) 29 | import Data.List (List, (:)) 30 | import Data.List as List 31 | import Data.Maybe (Maybe) 32 | import Data.String (joinWith) 33 | import Data.String.CodeUnits (fromCharArray, toCharArray) 34 | import Data.Traversable (traverse) 35 | import Data.Tuple (Tuple(..)) 36 | import Foreign (Foreign) 37 | import Selda.Table (Column, showColumn) 38 | 39 | -- | AST for SQL expressions: 40 | -- | 41 | -- | - EColumn: column values from tables or sub queries 42 | -- | - ELit: simple literals like String, Int, Boolean 43 | -- | - EBinOp: binary operations 44 | -- | - EUnOp: unary operations 45 | -- | - EFn: SQL functions, e.g. aggregate functions: max, sum, count 46 | -- | - EInArray: represents a boolean expression that `e` is in `array` 47 | -- | - EForeign: raw foreign value to be passed as a query parameter 48 | -- | - Any: generic expression represented as a string in the `ShowM` monad 49 | data Expr o 50 | = EColumn (Column o) 51 | | ELit (Literal o) 52 | | EBinOp (Exists (BinExp o)) 53 | | EUnOp (Exists (UnExp o)) 54 | | EFn (Exists (Fn o)) 55 | | EInArray (Exists (InArray o)) 56 | | EForeign Foreign 57 | | Any ShowM 58 | 59 | -- | Datatype for literal values - extensibility is provided with a use of 60 | -- | `EForeign` to pass the value as `Foreign` that is expected in the desired 61 | -- | database backend. 62 | data Literal a 63 | = LBoolean Boolean (Boolean ~ a) 64 | | LString String (String ~ a) 65 | | LInt Int (Int ~ a) 66 | | LNull (Exists (None a)) 67 | 68 | data None a b = None (Maybe b ~ a) 69 | 70 | data BinOp i o 71 | = Or (Boolean ~ i) (Boolean ~ o) 72 | | And (Boolean ~ i) (Boolean ~ o) 73 | | Gt (Boolean ~ o) 74 | | Ge (Boolean ~ o) 75 | | Lt (Boolean ~ o) 76 | | Le (Boolean ~ o) 77 | | Eq (Boolean ~ o) 78 | 79 | data UnOp i o 80 | = IsNotNull (Boolean ~ o) 81 | | IsNull (Boolean ~ o) 82 | | Not (Boolean ~ i) (Boolean ~ o) 83 | 84 | data BinExp o i = BinExp (BinOp i o) (Expr i) (Expr i) 85 | 86 | data UnExp o i = UnExp (UnOp i o) (Expr i) 87 | 88 | data Fn o i 89 | = FnMax (Expr i) (Maybe i ~ o) 90 | | FnCount (Expr i) (Int ~ o) 91 | | FnSum (Expr i) (Maybe Int ~ o) 92 | 93 | data InArray o i = InArray (Expr i) (Array (Expr i)) (Boolean ~ o) 94 | 95 | primPGEscape :: String -> String 96 | primPGEscape = toCharArray >>> (_ >>= escape) >>> fromCharArray 97 | where 98 | escape :: Char -> Array Char 99 | escape c = case c of 100 | '\'' -> [ c, c ] 101 | _ -> pure c 102 | 103 | -- | Keeps a list of parameters that will be passed to the backend-specific 104 | -- | query execution (which takes SQL query as String with placeholders $ 105 | -- | and an array with parameters that correspond to these placeholders) 106 | type QueryParams = 107 | { invertedParams :: List Foreign 108 | , nextIndex :: Int 109 | } 110 | 111 | type ShowMCtx = 112 | { mkPlaceholder :: Int -> String 113 | } 114 | 115 | -- | Monad for: (Query AST) → (Query String with placeholders, Parameters) 116 | type ShowM = ReaderT ShowMCtx (State QueryParams) String 117 | 118 | runShowM :: (Int -> String) -> Int -> ShowM -> Tuple String QueryParams 119 | runShowM mkPlaceholder firstIndex m = 120 | runReaderT m { mkPlaceholder } 121 | # flip runState { invertedParams: mempty, nextIndex: firstIndex } 122 | 123 | showM 124 | :: String 125 | -> Int 126 | -> ShowM 127 | -> { params :: Array Foreign, nextIndex :: Int, strQuery :: String } 128 | showM ph i m = { params, nextIndex, strQuery } 129 | where 130 | mkPh int = ph <> show int 131 | (Tuple strQuery { invertedParams, nextIndex }) = runShowM mkPh i m 132 | params = Array.fromFoldable $ List.reverse invertedParams 133 | 134 | showForeign :: Foreign -> ShowM 135 | showForeign x = do 136 | { mkPlaceholder } <- ask 137 | s <- get 138 | put $ s { nextIndex = 1 + s.nextIndex, invertedParams = x : s.invertedParams } 139 | pure $ mkPlaceholder s.nextIndex 140 | 141 | showLiteral :: forall a. Literal a -> String 142 | showLiteral = case _ of 143 | LBoolean b _ -> show b 144 | LString s _ -> "'" <> primPGEscape s <> "'" 145 | LInt i _ -> show i 146 | LNull _ -> "null" 147 | 148 | showBinOp :: forall i o. BinOp i o -> String 149 | showBinOp = case _ of 150 | Or _ _ -> " or " 151 | And _ _ -> " and " 152 | Gt _ -> " > " 153 | Ge _ -> " >= " 154 | Lt _ -> " < " 155 | Le _ -> " <= " 156 | Eq _ -> " = " 157 | 158 | showExpr :: forall a. Expr a -> ShowM 159 | showExpr = case _ of 160 | EColumn col -> pure $ showColumn col 161 | ELit lit -> pure $ showLiteral lit 162 | EBinOp e -> runExists showBinExp e 163 | EUnOp e -> runExists showUnExp e 164 | EFn fn -> runExists showFn fn 165 | EInArray e -> runExists showInArray e 166 | EForeign x -> showForeign x 167 | Any m -> m 168 | 169 | showBinExp :: forall o i. BinExp o i -> ShowM 170 | showBinExp (BinExp op e1 e2) = do 171 | s1 <- showExpr e1 172 | s2 <- showExpr e2 173 | pure $ "(" <> s1 <> showBinOp op <> s2 <> ")" 174 | 175 | showUnExp :: forall o i. UnExp o i -> ShowM 176 | showUnExp (UnExp op e) = do 177 | let 178 | ret s = "(" <> s <> ")" 179 | matchOp s = case op of 180 | IsNotNull _ -> s <> " IS NOT NULL" 181 | IsNull _ -> s <> " IS NULL" 182 | Not _ _ -> "NOT " <> s 183 | ret <$> matchOp <$> showExpr e 184 | 185 | showFn :: forall o i. Fn o i -> ShowM 186 | showFn fn = 187 | let 188 | ret op e = (\s -> op <> "(" <> s <> ")") <$> showExpr e 189 | in 190 | let 191 | castToInt s = "CAST(" <> s <> " AS INTEGER)" 192 | in 193 | case fn of 194 | FnMax e _ -> ret "MAX" e 195 | FnCount e _ -> castToInt <$> ret "COUNT" e 196 | FnSum e _ -> castToInt <$> ret "SUM" e 197 | 198 | showInArray :: forall o i. InArray o i -> ShowM 199 | showInArray (InArray x xs _) = do 200 | s <- showExpr x 201 | ss <- traverse showExpr xs 202 | pure $ "(" <> s <> " IN (" <> joinWith ", " ss <> "))" 203 | -------------------------------------------------------------------------------- /test/Utils.purs: -------------------------------------------------------------------------------- 1 | module Test.Utils where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (ExceptT) 6 | import Control.Monad.Reader (ReaderT) 7 | import Data.Array (fromFoldable) 8 | import Data.Either (either) 9 | import Data.Foldable (class Foldable, find, foldl, for_, length) 10 | import Data.List.Types (NonEmptyList) 11 | import Data.Maybe (Maybe(..)) 12 | import Database.PostgreSQL (Connection, PGError) 13 | import Effect.Aff (Aff, catchError, throwError) 14 | import Effect.Class.Console (log) 15 | import Effect.Exception (error) 16 | import Foreign (ForeignError, MultipleErrors, renderForeignError) 17 | import JS.Unsafe.Stringify (unsafeStringify) 18 | import SQLite3 (DBConnection) 19 | import Selda (FullQuery, showQuery) 20 | import Selda.Col (class GetCols) 21 | import Selda.Expr (ShowM) 22 | import Selda.PG (showPG) 23 | import Selda.PG.Class (BackendPGClass) 24 | import Selda.Query.Class (class GenericQuery, genericQuery, runSelda) 25 | import Selda.SQLite3 (showSQLite3) 26 | import Selda.SQLite3.Class (BackendSQLite3Class) 27 | import Test.Unit (TestSuite) 28 | import Test.Unit as Unit 29 | import Test.Unit.Assert (assert, expectFailure) 30 | import Type.Proxy (Proxy(..)) 31 | 32 | type TestCtx :: forall k1 k2. k1 -> k2 -> Type -> Type 33 | type TestCtx b m ctx = 34 | { b ∷ Proxy b 35 | , m ∷ Proxy m 36 | , ctx ∷ ctx 37 | } 38 | 39 | testWith 40 | ∷ ∀ b m ctx i o 41 | . TestBackend b m ctx 42 | ⇒ GenericQuery b m i o 43 | ⇒ GetCols i 44 | ⇒ TestCtx b m ctx 45 | → (Array { | o } → Array { | o } → Aff Unit) 46 | → String 47 | → Array { | o } 48 | → FullQuery b { | i } 49 | → TestSuite 50 | testWith ctx assertFn msg expected q = Unit.test msg 51 | $ testWith' ctx assertFn expected q 52 | 53 | testFailingWith 54 | ∷ ∀ b m ctx i o 55 | . TestBackend b m ctx 56 | ⇒ GenericQuery b m i o 57 | ⇒ GetCols i 58 | ⇒ TestCtx b m ctx 59 | → String 60 | → FullQuery b { | i } 61 | → TestSuite 62 | testFailingWith ctx msg q = Unit.test msg 63 | $ expectFailure "failure msg" 64 | $ testWith' ctx (\_ _ → pure unit) [] q 65 | 66 | class TestBackend :: forall k. k -> (Type -> Type) -> Type -> Constraint 67 | class TestBackend b m ctx | b m → ctx where 68 | testWith' 69 | ∷ ∀ i o 70 | . GenericQuery b m i o 71 | ⇒ GetCols i 72 | ⇒ TestCtx b m ctx 73 | → (Array { | o } → Array { | o } → Aff Unit) 74 | → Array { | o } 75 | → FullQuery b { | i } 76 | → Aff Unit 77 | 78 | -- testFailingWith ctx = testWith' ctx unordered "failing: aggr & having" 79 | 80 | instance testBackendPG 81 | ∷ TestBackend BackendPGClass 82 | (ExceptT PGError (ReaderT Connection Aff)) 83 | { conn ∷ Connection } 84 | where 85 | testWith' { b, ctx: { conn } } assertFn = 86 | testWith_ assertFn (showPG >>> _.strQuery) b (runPGSeldaAff conn) 87 | 88 | instance testBackendSQLite3 89 | ∷ TestBackend BackendSQLite3Class 90 | (ExceptT (NonEmptyList ForeignError) (ReaderT DBConnection Aff)) 91 | { conn ∷ DBConnection } 92 | where 93 | testWith' { b, ctx: { conn } } assertFn = 94 | testWith_ assertFn (showSQLite3 >>> _.strQuery) b (runSQLite3SeldaAff conn) 95 | 96 | testWith_ 97 | ∷ ∀ m i o b 98 | . GenericQuery b m i o 99 | ⇒ GetCols i 100 | ⇒ (Array { | o } → Array { | o } → Aff Unit) 101 | → (ShowM → String) 102 | → Proxy b 103 | → (m ~> Aff) 104 | → Array { | o } 105 | → FullQuery b { | i } 106 | → Aff Unit 107 | testWith_ assertFn showB b runM = 108 | testQueryWith_ (\q → runM $ genericQuery b q) assertFn (showQuery >>> showB) 109 | 110 | testWithPG 111 | ∷ ∀ a 112 | . Connection 113 | → (TestCtx BackendPGClass PGSelda { conn ∷ Connection } → a) 114 | → a 115 | testWithPG conn k = k { b, m, ctx: { conn } } 116 | where 117 | b = (Proxy ∷ Proxy BackendPGClass) 118 | m = (Proxy ∷ Proxy PGSelda) 119 | 120 | testWithSQLite3 121 | ∷ ∀ a 122 | . DBConnection 123 | → (TestCtx BackendSQLite3Class SQLite3Selda { conn ∷ DBConnection } → a) 124 | → a 125 | testWithSQLite3 conn k = k { b, m, ctx: { conn } } 126 | where 127 | b = (Proxy ∷ Proxy BackendSQLite3Class) 128 | m = (Proxy ∷ Proxy SQLite3Selda) 129 | 130 | testQueryWith_ 131 | ∷ ∀ expected query queryResult 132 | . (query → Aff queryResult) 133 | → (expected → queryResult → Aff Unit) 134 | → (query → String) 135 | → expected 136 | → query 137 | → Aff Unit 138 | testQueryWith_ run assertFunc showQ expected query = 139 | run query >>= assertFunc expected # catchError $ \e → do 140 | log "Error occured - Printing the query below" 141 | logQuery 142 | throwError e 143 | where logQuery = log "" *> log (showQ query) 144 | 145 | withRollback_ 146 | ∷ ∀ err a 147 | . (String → Aff (Maybe err)) 148 | → Aff a 149 | → Aff Unit 150 | withRollback_ exec action = do 151 | let 152 | throwErr msg err = throwError $ error $ msg <> unsafeStringify err 153 | rollback = exec "ROLLBACK" >>= case _ of 154 | Just err → throwErr "Error on transaction rollback: " err 155 | Nothing → pure unit 156 | begun ← exec "BEGIN TRANSACTION" 157 | case begun of 158 | Just err → throwErr "Error on transaction initialization: " err 159 | Nothing → void $ catchError 160 | (action >>= const rollback) (\e → rollback >>= const (throwError e)) 161 | 162 | runSeldaAff ∷ ∀ r e. r → ExceptT e (ReaderT r Aff) ~> Aff 163 | runSeldaAff = runSeldaAffWith unsafeStringify 164 | 165 | runSeldaAffWith ∷ ∀ e r. (e → String) → r → ExceptT e (ReaderT r Aff) ~> Aff 166 | runSeldaAffWith fe conn m = runSelda conn m >>= either onError pure 167 | where 168 | msg = "Error occured during text execution: " 169 | onError e = throwError $ error $ msg <> fe e 170 | 171 | runPGSeldaAff ∷ Connection → PGSelda ~> Aff 172 | runPGSeldaAff = runSeldaAffWith $ show 173 | 174 | runSQLite3SeldaAff ∷ DBConnection → SQLite3Selda ~> Aff 175 | runSQLite3SeldaAff = runSeldaAffWith $ show <<< map renderForeignError 176 | 177 | type SQLite3Selda = ExceptT MultipleErrors (ReaderT DBConnection Aff) 178 | 179 | type PGSelda = ExceptT PGError (ReaderT Connection Aff) 180 | 181 | assertIn ∷ ∀ f2 f1 a. Show a ⇒ Eq a ⇒ Foldable f2 ⇒ Foldable f1 ⇒ f1 a → f2 a → Aff Unit 182 | assertIn l1 l2 = for_ l1 \x1 → do 183 | case find (x1 == _) l2 of 184 | Nothing → assert ((show x1) <> " not found in [" <> foldl (\acc x → acc <> show x <> " ") " " l2 <> "]") false 185 | Just _ → pure unit 186 | 187 | assertUnorderedSeqEq ∷ ∀ f2 f1 a. Show a ⇒ Eq a ⇒ Foldable f2 ⇒ Foldable f1 ⇒ f1 a → f2 a → Aff Unit 188 | assertUnorderedSeqEq l1 l2 = do 189 | assertIn l1 l2 190 | assertIn l2 l1 191 | let 192 | len1 = (length l1 ∷ Int) 193 | len2 = (length l2 ∷ Int) 194 | msg = "The same elements, but the length is different : " <> show len1 <> " != " <> show len2 195 | assert msg $ len1 == len2 196 | 197 | assertSeqEq ∷ ∀ f2 f1 a. Show a ⇒ Eq a ⇒ Foldable f2 ⇒ Foldable f1 ⇒ f1 a → f2 a → Aff Unit 198 | assertSeqEq l1 l2 = assert msg $ xs == ys 199 | where 200 | msg = show xs <> " != " <> show ys 201 | xs = fromFoldable l1 202 | ys = fromFoldable l2 203 | 204 | assertEq ∷ ∀ a. Show a ⇒ Eq a ⇒ a → a → Aff Unit 205 | assertEq x y = assert msg $ x == y 206 | where msg = show x <> " != " <> show y 207 | 208 | -------------------------------------------------------------------------------- /src/Selda/PG/Class.purs: -------------------------------------------------------------------------------- 1 | module Selda.PG.Class 2 | ( class MonadSeldaPG 3 | , class InsertRecordIntoTableReturning 4 | , insertRecordIntoTableReturning 5 | , insert_ 6 | , insert 7 | , insert1 8 | , insert1_ 9 | , query 10 | , query1 11 | , deleteFrom 12 | , update 13 | , BackendPGClass 14 | ) where 15 | 16 | import Prelude 17 | import Control.Monad.Reader (ask) 18 | import Data.Array (concat, null) 19 | import Data.Array as Array 20 | import Data.Array.Partial (head) 21 | import Data.Maybe (Maybe) 22 | import Data.Traversable (traverse) 23 | import Data.Tuple (Tuple(..)) 24 | import Database.PostgreSQL (Connection, class FromSQLRow, class ToSQLRow, class ToSQLValue, PGError, toSQLValue) 25 | import Database.PostgreSQL as PostgreSQL 26 | import Database.PostgreSQL.PG as PostgreSQL.PG 27 | import Foreign (Foreign) 28 | import Heterogeneous.Folding (class HFoldl, hfoldl) 29 | import Partial.Unsafe (unsafePartial) 30 | import Prim.RowList as RL 31 | import Selda.Col (class GetCols, Col) 32 | import Selda.Expr (ShowM) 33 | import Selda.PG (showInsert1, showPG) 34 | import Selda.Query (limit) 35 | import Selda.Query.Class (class GenericDelete, class GenericInsert, class GenericQuery, class GenericUpdate, class MonadSelda, genericDelete, genericInsert, genericInsert_, genericQuery, genericUpdate) 36 | import Selda.Query.ShowStatement (class GenericShowInsert, showDeleteFrom, showQuery, showUpdate) 37 | import Selda.Query.Type (FullQuery(..), runFullQuery) 38 | import Selda.Query.Utils (class ColsToPGHandler, class RowListLength, class TableToColsWithoutAlias, class ToForeign, RecordToArrayForeign, RecordToTuple(..), colsToPGHandler, tableToColsWithoutAlias) 39 | import Selda.Table (class TableColumnNames, Table) 40 | import Selda.Table.Constraint (class CanInsertColumnsIntoTable) 41 | import Type.Proxy (Proxy(..)) 42 | 43 | type B = BackendPGClass 44 | 45 | data BackendPGClass 46 | 47 | class MonadSelda m PGError Connection <= MonadSeldaPG m 48 | 49 | instance monadSeldaPGInstance :: 50 | MonadSelda m PGError Connection => 51 | MonadSeldaPG m 52 | 53 | pgQuery 54 | :: forall i o m 55 | . ToSQLRow i 56 | => FromSQLRow o 57 | => MonadSeldaPG m 58 | => PostgreSQL.Query i o 59 | -> i 60 | -> m (Array o) 61 | pgQuery q xTup = do 62 | conn <- ask 63 | PostgreSQL.PG.query conn q xTup 64 | 65 | pgExecute 66 | :: forall m 67 | . MonadSeldaPG m 68 | => ShowM 69 | -> m Unit 70 | pgExecute m = when (strQuery /= "") do 71 | conn <- ask 72 | PostgreSQL.PG.execute conn (PostgreSQL.Query strQuery) params 73 | where 74 | { strQuery, params } = showPG m 75 | 76 | -- | Executes an insert query for each input record. 77 | insert_ 78 | :: forall m t r 79 | . GenericInsert BackendPGClass m t r 80 | => MonadSeldaPG m 81 | => Table t 82 | -> Array { | r } 83 | -> m Unit 84 | insert_ = genericInsert (Proxy :: Proxy BackendPGClass) 85 | 86 | insert1_ 87 | :: forall m t r 88 | . GenericInsert BackendPGClass m t r 89 | => MonadSeldaPG m 90 | => Table t 91 | -> { | r } 92 | -> m Unit 93 | insert1_ table r = insert_ table [ r ] 94 | 95 | -- | Executes an insert query for each input record. 96 | -- | Column constraints: `Default`s are optional, `Auto`s are forbidden 97 | insert 98 | :: forall m r t ret 99 | . InsertRecordIntoTableReturning r t ret 100 | => MonadSeldaPG m 101 | => Table t 102 | -> Array { | r } 103 | -> m (Array { | ret }) 104 | insert table xs = concat <$> traverse ins1 xs 105 | where 106 | ins1 r = insertRecordIntoTableReturning r table 107 | 108 | insert1 109 | :: forall m r t ret 110 | . InsertRecordIntoTableReturning r t ret 111 | => MonadSeldaPG m 112 | => Table t 113 | -> { | r } 114 | -> m { | ret } 115 | insert1 table r = unsafePartial $ head <$> insertRecordIntoTableReturning r table 116 | 117 | -- | Inserts `{ | r }` into `Table t`. Checks constraints (Auto, Default). 118 | -- | Returns inserted record with every column from `Table t`. 119 | class InsertRecordIntoTableReturning r t ret | r t -> ret where 120 | insertRecordIntoTableReturning 121 | :: forall m. MonadSeldaPG m => { | r } -> Table t -> m (Array { | ret }) 122 | 123 | instance insertRecordIntoTableReturningInstance :: 124 | ( RL.RowToList r rlcols 125 | , CanInsertColumnsIntoTable rlcols t 126 | , TableColumnNames rlcols 127 | , RowListLength rlcols 128 | , ToSQLRow rTuple 129 | , FromSQLRow trTuple 130 | , HFoldl RecordToTuple Unit { | r } rTuple 131 | , TableToColsWithoutAlias s t tr 132 | , RL.RowToList tr trl 133 | , TableColumnNames trl 134 | , ColsToPGHandler s tr trTuple ret 135 | ) => 136 | InsertRecordIntoTableReturning r t ret where 137 | insertRecordIntoTableReturning r table = do 138 | let 139 | s = (Proxy :: Proxy s) 140 | colsToinsert = (Proxy :: Proxy rlcols) 141 | rTuple = hfoldl RecordToTuple unit r 142 | 143 | tr = tableToColsWithoutAlias s table 144 | colsToRet = (Proxy :: Proxy trl) 145 | q = showInsert1 table colsToinsert colsToRet 146 | rows <- pgQuery (PostgreSQL.Query q) rTuple 147 | pure $ map (colsToPGHandler s tr) rows 148 | 149 | instance pgToForeign :: ToSQLValue a => ToForeign BackendPGClass a where 150 | toForeign _ = toSQLValue 151 | 152 | instance genericInsertPGClass :: 153 | ( HFoldl 154 | (RecordToArrayForeign BackendPGClass) 155 | (Array Foreign) 156 | { | r } 157 | (Array Foreign) 158 | , MonadSeldaPG m 159 | , GenericShowInsert t r 160 | ) => 161 | GenericInsert BackendPGClass m t r where 162 | genericInsert = genericInsert_ { exec, ph: "$" } 163 | where 164 | exec q l = 165 | when (not $ null l) do 166 | conn <- ask 167 | PostgreSQL.PG.execute conn (PostgreSQL.Query q) l 168 | 169 | query 170 | :: forall o i m 171 | . GenericQuery BackendPGClass m i o 172 | => FullQuery B { | i } 173 | -> m (Array { | o }) 174 | query = genericQuery (Proxy :: Proxy BackendPGClass) 175 | 176 | query1 177 | :: forall o i m 178 | . GenericQuery BackendPGClass m i o 179 | => FullQuery B { | i } 180 | -> m (Maybe { | o }) 181 | query1 (FullQuery q) = query (FullQuery (limit 1 >>= \_ -> q)) <#> Array.head 182 | 183 | instance genericQueryPG :: 184 | ( ColsToPGHandler B i tup o 185 | , GetCols i 186 | , FromSQLRow tup 187 | , MonadSeldaPG m 188 | ) => 189 | GenericQuery BackendPGClass m i o where 190 | genericQuery _ q = do 191 | let 192 | (Tuple res _) = runFullQuery q 193 | 194 | { strQuery, params } = showPG $ showQuery q 195 | rows <- pgQuery (PostgreSQL.Query strQuery) params 196 | pure $ map (colsToPGHandler (Proxy :: Proxy BackendPGClass) res) rows 197 | 198 | deleteFrom 199 | :: forall t r m 200 | . GenericDelete BackendPGClass m t r 201 | => Table t 202 | -> ({ | r } -> Col B Boolean) 203 | -> m Unit 204 | deleteFrom = genericDelete (Proxy :: Proxy BackendPGClass) 205 | 206 | instance genericDeletePG :: 207 | ( TableToColsWithoutAlias B t r 208 | , MonadSeldaPG m 209 | ) => 210 | GenericDelete BackendPGClass m t r where 211 | genericDelete _ table pred = pgExecute $ showDeleteFrom table pred 212 | 213 | update 214 | :: forall t r m 215 | . GenericUpdate BackendPGClass m t r 216 | => Table t 217 | -> ({ | r } -> Col B Boolean) 218 | -> ({ | r } -> { | r }) 219 | -> m Unit 220 | update = genericUpdate (Proxy :: Proxy BackendPGClass) 221 | 222 | instance genericUpdatePG :: 223 | ( TableToColsWithoutAlias B t r 224 | , GetCols r 225 | , MonadSeldaPG m 226 | ) => 227 | GenericUpdate BackendPGClass m t r where 228 | genericUpdate _ table pred up = pgExecute $ showUpdate table pred up 229 | -------------------------------------------------------------------------------- /test/PG.purs: -------------------------------------------------------------------------------- 1 | module Test.PG where 2 | 3 | import Prelude 4 | import Data.Date (Date, canonicalDate) 5 | import Data.Either (Either(..)) 6 | import Data.Enum (toEnum) 7 | import Data.Maybe (Maybe(..), fromJust, isJust, maybe) 8 | import Database.PostgreSQL (Connection) 9 | import Database.PostgreSQL as PostgreSQL 10 | import Database.PostgreSQL.Aff as PostgreSQL.Aff 11 | import Effect.Aff (Aff) 12 | import JS.Unsafe.Stringify (unsafeStringify) 13 | import Partial.Unsafe (unsafePartial) 14 | import Selda (Col, Table(..), lit, restrict, selectFrom, showUpdate, (.==), (.>)) 15 | import Selda.PG (extract, generateSeries, litPG, showPGQuery) 16 | import Selda.PG.Class (BackendPGClass, deleteFrom, insert, insert1, insert1_, insert_, update) 17 | import Selda.Table.Constraint (Auto, Default) 18 | import Test.Common (bankAccounts, descriptions, legacySuite, people) 19 | import Test.Selda.PG.Config (load) as Config 20 | import Test.Types (AccountType(..)) 21 | import Test.Unit (TestSuite, failure, suite, test) 22 | import Test.Utils (PGSelda, TestCtx, assertEq, assertUnorderedSeqEq, runSeldaAff, testWith, testWithPG) 23 | 24 | employees ∷ 25 | Table 26 | ( id ∷ Auto Int 27 | , name ∷ String 28 | , salary ∷ Default Int 29 | , date ∷ Default Date 30 | ) 31 | employees = Table { name: "employees" } 32 | 33 | -- | Table with a problematic column name in Postgresql. Only for querying 34 | pgKeywordTable ∷ Table ( end ∷ Int ) 35 | pgKeywordTable = Table { name: "pg_keyword_table" } 36 | 37 | -- | Table with a problematic column name in Postgresql 38 | -- | with manually escaped column name. 39 | -- | Use for insert/update/delete. Not safe for querying though. 40 | pgKeywordTable_quote ∷ Table ( "end" ∷ Int ) 41 | pgKeywordTable_quote = Table { name: "pg_keyword_table" } 42 | 43 | qualifiedTableWithSchema ∷ Table ( id ∷ Auto Int, name ∷ String ) 44 | qualifiedTableWithSchema = Source "tablename" \alias → "qualified.tablename" <> maybe "" (" " <> _) alias 45 | 46 | date ∷ Int → Int → Int → Date 47 | date y m d = 48 | unsafePartial $ fromJust 49 | $ canonicalDate 50 | <$> toEnum y 51 | <*> toEnum m 52 | <*> toEnum d 53 | 54 | testSuite ∷ 55 | TestCtx BackendPGClass PGSelda { conn ∷ Connection } → 56 | TestSuite 57 | testSuite ctx = do 58 | let 59 | unordered = assertUnorderedSeqEq 60 | -- ordered = assertSeqEq 61 | testWith ctx unordered "employees inserted with default and without salary" 62 | [ { id: 1, name: "E1", salary: 123, date: date 2000 10 20 } 63 | , { id: 2, name: "E2", salary: 500, date: date 2000 11 21 } 64 | -- , { id: 3, name: "E3", salary: 500, date: date 2000 12 22 } 65 | ] 66 | $ selectFrom employees \r → do 67 | restrict $ not $ r.date .> (litPG $ date 2000 11 21) 68 | pure r 69 | testWith ctx unordered "extract month from employees" 70 | [ { y: "2000", m: "10", d: "20" } 71 | , { y: "2000", m: "11", d: "21" } 72 | , { y: "2000", m: "12", d: "22" } 73 | ] 74 | $ selectFrom employees \r → do 75 | let 76 | (y ∷ Col BackendPGClass _) = extract "year" r.date 77 | let 78 | m = extract "month" r.date 79 | let 80 | d = extract "day" r.date 81 | pure { y, m, d } 82 | testWith ctx unordered "select * from keyword table" 83 | ([] ∷ Array ({ end ∷ Int })) 84 | $ selectFrom pgKeywordTable pure 85 | testWith ctx unordered "select * from qualifiedTableWithSchema" 86 | [ { id: 2, name: "s2" } ] 87 | $ selectFrom qualifiedTableWithSchema pure 88 | testWith ctx unordered "generate_series(3,5)" 89 | [ { i: 3 } 90 | , { i: 4 } 91 | , { i: 5 } 92 | ] 93 | $ selectFrom (generateSeries 3 5) pure 94 | test "Generated UPDATE does not include unchanged columns" do 95 | assertEq """UPDATE people SET "name" = 'name' WHERE ("id" = 7)""" 96 | $ showPGQuery 97 | $ showUpdate people 98 | (\r → r.id .== lit 7) 99 | (\r → r { name = lit "name" }) 100 | 101 | main ∷ (TestSuite → Aff Unit) → Aff Unit 102 | main cont = do 103 | pool ← Config.load 104 | PostgreSQL.Aff.withConnection pool case _ of 105 | Left pgError → failure ("PostgreSQL connection error: " <> unsafeStringify pgError) 106 | Right conn → do 107 | createdb ← 108 | PostgreSQL.Aff.execute conn 109 | ( PostgreSQL.Query 110 | """ 111 | DROP TABLE IF EXISTS people; 112 | CREATE TABLE people ( 113 | id INTEGER PRIMARY KEY, 114 | name TEXT NOT NULL, 115 | age INTEGER 116 | ); 117 | 118 | DO $$ 119 | BEGIN 120 | IF NOT EXISTS (SELECT 1 FROM pg_type WHERE typname = 'account_type') THEN 121 | CREATE TYPE ACCOUNT_TYPE as ENUM ( 122 | 'business', 123 | 'personal' 124 | ); 125 | END IF; 126 | END$$; 127 | 128 | DROP TABLE IF EXISTS bank_accounts; 129 | CREATE TABLE bank_accounts ( 130 | id INTEGER PRIMARY KEY, 131 | "personId" INTEGER NOT NULL, 132 | balance INTEGER NOT NULL, 133 | "accountType" ACCOUNT_TYPE NOT NULL 134 | ); 135 | 136 | DROP TABLE IF EXISTS descriptions; 137 | CREATE TABLE descriptions ( 138 | id INTEGER PRIMARY KEY, 139 | text TEXT 140 | ); 141 | 142 | DROP TABLE IF EXISTS emptyTable; 143 | CREATE TABLE emptyTable ( 144 | id INTEGER PRIMARY KEY 145 | ); 146 | 147 | DROP TABLE IF EXISTS pg_keyword_table; 148 | CREATE TABLE pg_keyword_table ( 149 | "end" INTEGER NOT NULL 150 | ); 151 | 152 | DROP TABLE IF EXISTS employees; 153 | CREATE TABLE employees ( 154 | id SERIAL PRIMARY KEY, 155 | name TEXT NOT NULL, 156 | salary INTEGER DEFAULT 500, 157 | date DATE NOT NULL DEFAULT '2000-10-20' 158 | ); 159 | 160 | DROP TABLE IF EXISTS qualified.tablename; 161 | DROP SCHEMA IF EXISTS qualified; 162 | CREATE SCHEMA qualified; 163 | CREATE TABLE qualified.tablename ( 164 | id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, 165 | name TEXT NOT NULL 166 | ); 167 | """ 168 | ) 169 | PostgreSQL.Row0 170 | when (isJust createdb) 171 | $ failure ("PostgreSQL createdb error: " <> unsafeStringify createdb) 172 | runSeldaAff conn do 173 | insert_ people 174 | [ { id: 1, name: "name1", age: Just 11 } 175 | , { id: 2, name: "name2", age: Just 22 } 176 | , { id: 3, name: "name3", age: Just 33 } 177 | ] 178 | insert_ bankAccounts 179 | [ { id: 1, personId: 1, balance: 100, accountType: Business } 180 | , { id: 2, personId: 1, balance: 150, accountType: Personal } 181 | , { id: 3, personId: 3, balance: 300, accountType: Personal } 182 | ] 183 | insert_ descriptions 184 | [ { id: 1, text: Just "text1" } 185 | , { id: 3, text: Nothing } 186 | ] 187 | -- id is Auto, so it cannot be inserted 188 | -- insert_ employees [{ id: 1, name: "E1", salary: 123 }] 189 | insert_ employees [ { name: "E1", salary: 123 } ] 190 | insert1_ employees { name: "E2", date: date 2000 11 21 } 191 | insert1_ employees { name: "E3" } 192 | update employees 193 | (\r → r.name .== lit "E1") 194 | (\r → r { salary = lit 123 }) 195 | insert_ qualifiedTableWithSchema 196 | [ { name: "s1" } 197 | , { name: "s2" } 198 | ] 199 | update qualifiedTableWithSchema 200 | (\r → r.id .== lit 1) 201 | (\r → r { name = lit "s" }) 202 | deleteFrom qualifiedTableWithSchema 203 | (\r → r.name .== lit "s") 204 | -- simple test delete 205 | runSeldaAff conn do 206 | insert1_ people { id: 4, name: "delete", age: Just 999 } 207 | deleteFrom people \r → r.id .== lit 4 208 | -- simple test update 209 | runSeldaAff conn do 210 | { name, age } ← insert1 people { id: 5, name: "update", age: Just 999 } 211 | update people 212 | (\r → r.name .== lit name) 213 | (\r → r { age = lit $ Just 1000 }) 214 | deleteFrom people \r → r.age .> lit age 215 | update employees 216 | (\r → r.name .== lit "E3") 217 | (\r → r { date = lit $ date 2000 12 22 }) 218 | -- test a table with SQL keyword as a column name 219 | runSeldaAff conn do 220 | insert1_ pgKeywordTable_quote { "end": 1 } 221 | update pgKeywordTable_quote 222 | (\r → r."end" .== lit 1) 223 | (\r → r { "end" = lit 2 }) 224 | deleteFrom pgKeywordTable_quote 225 | (\r → r."end" .== lit 2) 226 | -- test empty insert,update won't break 227 | runSeldaAff conn do 228 | _ ← insert people ([] ∷ Array { id ∷ Int, name ∷ String, age ∷ Maybe Int }) 229 | insert_ people ([] ∷ Array { id ∷ Int, name ∷ String, age ∷ Maybe Int }) 230 | update people (\r → r.id .== r.id) identity 231 | cont do 232 | suite "PG" $ testWithPG conn legacySuite 233 | suite "PG.Specific" $ testWithPG conn testSuite 234 | -------------------------------------------------------------------------------- /src/Selda/Query.purs: -------------------------------------------------------------------------------- 1 | module Selda.Query where 2 | 3 | import Prelude 4 | 5 | import Data.Array ((:)) 6 | import Data.Exists (mkExists) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.Newtype (wrap) 9 | import Data.Symbol (class IsSymbol, reflectSymbol) 10 | import Data.Tuple (Tuple(..), snd) 11 | import Heterogeneous.Mapping (class HMap, class HMapWithIndex, class Mapping, class MappingWithIndex, hmap, hmapWithIndex) 12 | import Prim.RowList as RL 13 | import Selda.Aggr (Aggr(..), UnAggr(..), WrapWithAggr(..)) 14 | import Selda.Col (class GetCols, class ToCols, Col(..), getCols, toCols) 15 | import Selda.Expr (Expr(..), UnExp(..), UnOp(..)) 16 | import Selda.Inner (Inner, OuterCols(..)) 17 | import Selda.Query.Type (FullQuery(..), GenState(..), JoinType(..), Order, QBinOp(..), Query, SQL(..), Source(..), freshId, modify_, runFullQuery) 18 | import Selda.Table (class TableColumns, Alias, Column(..), Table(..), tableColumns) 19 | import Type.Proxy (Proxy(..)) 20 | import Unsafe.Coerce (unsafeCoerce) 21 | 22 | -- | `selectFrom table k` creates a fully described query which is a valid SQL query. 23 | -- | 24 | -- | It starts with the following SQL query scheme: 25 | -- | 26 | -- | ```sql 27 | -- | SELECT 28 | -- | FROM 29 | -- | 30 | -- | ``` 31 | -- | 32 | -- | The continuation `k` is executed with a record of columns from the `table` 33 | -- | The rest of the query - `` - is specified using 34 | -- | actions in the `Query` monad (such as `restrict`) 35 | -- | 36 | -- | Query result is specified as a result of the continuation `k` 37 | -- | 38 | -- | EXAMPLE: 39 | -- | ```purescript 40 | -- | selectFrom tableWithIdAndName \r → do 41 | -- | restrict $ r.id .== lit 17 42 | -- | pure { nameOfaUserWithId17: r.name } 43 | -- | ``` 44 | -- | 45 | -- | SQL equivalent: 46 | -- | ```SQL 47 | -- | SELECT r.name AS nameOfaUserWithId17 48 | -- | FROM tableWithIdAndName r 49 | -- | WHERE r.id == 17 50 | -- | ``` 51 | selectFrom 52 | :: forall r s cols res 53 | . FromTable s r cols 54 | => Table r 55 | -> ({ | cols } -> Query s { | res }) 56 | -> FullQuery s { | res } 57 | selectFrom table k = FullQuery do 58 | { res, sql } <- fromTable table 59 | modify_ \st -> st { source = From sql } 60 | k res 61 | 62 | -- | Similar to the `selectFrom` but starts a query from the given sub query (not a table) 63 | -- | See the `selectFrom` documentation for more details. 64 | selectFrom_ 65 | :: forall inner s resi reso 66 | . FromSubQuery s inner resi 67 | => FullQuery (Inner s) { | inner } 68 | -> ({ | resi } -> Query s { | reso }) 69 | -> FullQuery s { | reso } 70 | selectFrom_ iq k = FullQuery do 71 | { res, sql } <- fromSubQuery iq 72 | modify_ \st -> st { source = From sql } 73 | k res 74 | 75 | -- | `restrict condition` adds the `condition` to the SQL `WHERE` clause. 76 | -- | Multiple `restrict` operations are joined with `AND` 77 | restrict :: forall s. Col s Boolean -> Query s Unit 78 | restrict (Col e) = modify_ \st -> st { restricts = e : st.restricts } 79 | 80 | -- | `having condition` adds the `condition` to the SQL `HAVING` clause. 81 | -- | Multiple `having` operations are joined with `AND` 82 | having :: forall s. Aggr s Boolean -> Query s Unit 83 | having (Aggr (Col e)) = modify_ \st -> st { havings = e : st.havings } 84 | 85 | -- | `nutNull col` adds to the WHERE clause that col is not null 86 | -- | and returns the coerced column. 87 | notNull :: forall s a. Col s (Maybe a) -> Query s (Col s a) 88 | notNull col@(Col e) = do 89 | let 90 | notNullCol = Col $ EUnOp $ mkExists $ UnExp (IsNotNull identity) e 91 | fromMaybeCol = (unsafeCoerce :: Col s (Maybe a) -> Col s a) 92 | restrict notNullCol 93 | pure $ fromMaybeCol col 94 | 95 | -- | `nutNull_ aggr` adds to the HAVING clause that aggregate expression `aggr` 96 | -- | is not null and returns the coerced column. 97 | notNull_ :: forall s a. Aggr s (Maybe a) -> Query s (Aggr s a) 98 | notNull_ aggr@(Aggr (Col e)) = do 99 | let 100 | notNullAggr = Aggr $ Col $ EUnOp $ mkExists $ UnExp (IsNotNull identity) e 101 | fromMaybeAggr = (unsafeCoerce :: Aggr s (Maybe a) -> Aggr s a) 102 | having notNullAggr 103 | pure $ fromMaybeAggr aggr 104 | 105 | -- | `crossJoin table predicate` is equivalent to `CROSS JOIN
ON `. 106 | -- | Returns the columns from the joined table. 107 | crossJoin :: forall s r res. FromTable s r res => Table r -> Query s { | res } 108 | crossJoin table = do 109 | { res, sql } <- fromTable table 110 | modify_ \st -> st { source = CrossJoin st.source sql } 111 | pure res 112 | 113 | -- | `crossJoin_ subquery predicate` is equivalent to `CROSS JOIN ON `. 114 | -- | Returns the columns from the joined subquery. 115 | crossJoin_ 116 | :: forall inner s res 117 | . FromSubQuery s inner res 118 | => FullQuery (Inner s) { | inner } 119 | -> Query s { | res } 120 | crossJoin_ iq = do 121 | { res, sql } <- fromSubQuery iq 122 | modify_ \st -> st { source = CrossJoin st.source sql } 123 | pure res 124 | 125 | distinct 126 | :: forall s r 127 | . FullQuery s { | r } 128 | -> FullQuery s { | r } 129 | distinct (FullQuery q) = FullQuery do 130 | modify_ \st -> st { distinct = true } 131 | q 132 | 133 | aggregate 134 | :: forall s aggr res 135 | . HMapWithIndex UnAggr { | aggr } { | res } 136 | => FullQuery s { | aggr } 137 | -> FullQuery s { | res } 138 | aggregate q = map (hmapWithIndex UnAggr) q 139 | 140 | groupBy :: forall s a. Col s a -> Query s (Aggr s a) 141 | groupBy col@(Col e) = do 142 | modify_ \st -> st { aggr = st.aggr <> [ mkExists e ] } 143 | pure $ Aggr col 144 | 145 | groupBy' 146 | :: forall i o s 147 | . GetCols i 148 | => HMap WrapWithAggr { | i } { | o } 149 | => { | i } 150 | -> Query s { | o } 151 | groupBy' i = do 152 | let aggr = map snd $ getCols i 153 | modify_ \st -> st { aggr = st.aggr <> aggr } 154 | pure $ hmap WrapWithAggr i 155 | 156 | orderBy :: forall s a. Order -> Col s a -> Query s Unit 157 | orderBy order (Col e) = 158 | modify_ \st -> st { order = st.order <> [ Tuple order $ mkExists e ] } 159 | 160 | limit :: forall s. Int -> Query s Unit 161 | limit i = modify_ $ _ { limit = Just i } 162 | 163 | offset :: forall s. Int -> Query s Unit 164 | offset i = modify_ \st -> 165 | case st.limit of 166 | -- sqlite requires `limit` when `offset` is provided 167 | Nothing -> st { offset = Just i, limit = top } 168 | Just __ -> st { offset = Just i } 169 | 170 | -- | `innerJoin table predicate` is equivalent to `JOIN
ON `. 171 | -- | Returns the columns from the joined table. 172 | innerJoin 173 | :: forall r s res 174 | . FromTable s r res 175 | => Table r 176 | -> ({ | res } -> Col s Boolean) 177 | -> Query s { | res } 178 | innerJoin table on = do 179 | { res, sql } <- fromTable table 180 | let Col e = on res 181 | modify_ \st -> st { source = JoinOn InnerJoin st.source sql e } 182 | pure res 183 | 184 | -- | `innerJoin_ predicate subquery` is equivalent to `JOIN ON `. 185 | -- | Returns the columns from the joined subquery. 186 | innerJoin_ 187 | :: forall s res inner 188 | . FromSubQuery s inner res 189 | => ({ | res } -> Col s Boolean) 190 | -> FullQuery (Inner s) { | inner } 191 | -> Query s { | res } 192 | innerJoin_ on iq = do 193 | { res, sql } <- fromSubQuery iq 194 | let Col e = on res 195 | modify_ \st -> st { source = JoinOn InnerJoin st.source sql e } 196 | pure res 197 | 198 | -- | `leftJoin table predicate` is equivalent to `LEFT JOIN
ON `. 199 | -- | Returns the columns from the joined table. 200 | -- | These columns become nullable due to the LEFT JOIN semantics 201 | -- | hence they are wrapped in Maybe. 202 | leftJoin 203 | :: forall r s res mres 204 | . FromTable s r res 205 | => HMap WrapWithMaybe { | res } { | mres } 206 | => Table r 207 | -> ({ | res } -> Col s Boolean) 208 | -> Query s { | mres } 209 | leftJoin table on = do 210 | { res, sql } <- fromTable table 211 | let Col e = on res 212 | modify_ \st -> st { source = JoinOn LeftJoin st.source sql e } 213 | pure $ hmap WrapWithMaybe res 214 | 215 | -- | `leftJoin_ predicate subquery` is equivalent to `LEFT JOIN ON `. 216 | -- | Returns the columns from the joined subquery. 217 | -- | These columns become nullable due to the LEFT JOIN semantics 218 | -- | hence they are wrapped in Maybe. 219 | leftJoin_ 220 | :: forall s res mres inner 221 | . FromSubQuery s inner res 222 | => HMap WrapWithMaybe { | res } { | mres } 223 | => ({ | res } -> Col s Boolean) 224 | -> FullQuery (Inner s) { | inner } 225 | -> Query s { | mres } 226 | leftJoin_ on iq = do 227 | { res, sql } <- fromSubQuery iq 228 | let Col e = on res 229 | modify_ \st -> st { source = JoinOn LeftJoin st.source sql e } 230 | pure $ hmap WrapWithMaybe res 231 | 232 | type CombineQuery = 233 | forall k (s :: k) r inner i o 234 | . FromSubQuery s inner i 235 | => HMapWithIndex SubQueryResult { | i } { | o } 236 | => FullQuery (Inner s) { | inner } 237 | -> FullQuery (Inner s) { | inner } 238 | -> ({ | o } -> Query s { | r }) 239 | -> FullQuery s { | r } 240 | 241 | union :: CombineQuery 242 | union = combineWith Union 243 | 244 | unionAll :: CombineQuery 245 | unionAll = combineWith UnionAll 246 | 247 | intersect :: CombineQuery 248 | intersect = combineWith Intersect 249 | 250 | except :: CombineQuery 251 | except = combineWith Except 252 | 253 | combineWith 254 | :: forall s r inner i o 255 | . FromSubQuery s inner i 256 | => HMapWithIndex SubQueryResult { | i } { | o } 257 | => QBinOp 258 | -> FullQuery (Inner s) { | inner } 259 | -> FullQuery (Inner s) { | inner } 260 | -> ({ | o } -> Query s { | r }) 261 | -> FullQuery s { | r } 262 | combineWith op q1 q2 k = FullQuery do 263 | r1 <- fromSubQuery q1 264 | r2 <- fromSubQuery q2 265 | alias <- freshId <#> \id -> "comb_q" <> show id 266 | modify_ \st -> st { source = Combination op r1.st r2.st alias } 267 | -- records `r1.res` and `r2.res` are identical, so we use either 268 | k $ createSubQueryResult alias r1.res 269 | 270 | class FromTable :: forall k. k -> Row Type -> Row Type -> Constraint 271 | class FromTable s t c | s t -> c where 272 | fromTable :: Table t -> Query s { res :: { | c }, sql :: SQL } 273 | 274 | instance tableToColsI :: 275 | ( RL.RowToList t tl 276 | , TableColumns tl i 277 | , ToCols s i c 278 | ) => 279 | FromTable s t c 280 | where 281 | fromTable = case _ of 282 | Table { name } -> 283 | go name \alias -> { body: name <> " " <> alias, alias } 284 | Source aliasPrefix aliasToBody -> 285 | go aliasPrefix \alias -> { body: aliasToBody $ Just alias, alias } 286 | where 287 | go aliasPrefix aliasToAliased = do 288 | id <- freshId 289 | let 290 | aliased = aliasToAliased $ aliasPrefix <> "_" <> show id 291 | i = tableColumns aliased (Proxy :: Proxy tl) 292 | res = toCols (Proxy :: Proxy s) i 293 | pure $ { res, sql: FromTable aliased } 294 | 295 | data WrapWithMaybe = WrapWithMaybe 296 | 297 | instance wrapWithMaybeLeaveMaybe :: Mapping WrapWithMaybe (Col s (Maybe a)) (Col s (Maybe a)) 298 | where 299 | mapping _ = identity 300 | else instance wrapWithMaybeInstance :: Mapping WrapWithMaybe (Col s a) (Col s (Maybe a)) 301 | where 302 | mapping _ = (unsafeCoerce :: Col s a -> Col s (Maybe a)) 303 | 304 | subQueryAlias :: forall s. Query s Alias 305 | subQueryAlias = do 306 | id <- freshId 307 | pure $ "sub_q" <> show id 308 | 309 | class FromSubQuery :: forall k. k -> Row Type -> Row Type -> Constraint 310 | class FromSubQuery s inner res | inner -> s res where 311 | fromSubQuery 312 | :: FullQuery (Inner s) { | inner } 313 | -> Query s { res :: { | res }, sql :: SQL, alias :: Alias, st :: GenState } 314 | 315 | instance fromSubQueryI :: 316 | ( HMapWithIndex OuterCols { | inner } { | res0 } 317 | , GetCols res0 318 | , HMapWithIndex SubQueryResult { | res0 } { | res } 319 | ) => 320 | FromSubQuery s inner res 321 | where 322 | fromSubQuery q = do 323 | let (Tuple innerRes (GenState st)) = runFullQuery q 324 | let res0 = hmapWithIndex OuterCols innerRes 325 | alias <- subQueryAlias 326 | let res = createSubQueryResult alias res0 327 | let genState = wrap $ st { cols = getCols res0 } 328 | pure $ { res, sql: SubQuery alias genState, alias, st: genState } 329 | 330 | -- | Outside of the subquery, every returned col (in SELECT ...) 331 | -- | (no matter if it's just a column of some table or expression or function or ...) 332 | -- | is seen as a column of this subquery. 333 | -- | So it can just be `.`. 334 | -- | 335 | -- | Creates record of Columns with namespace set as subquery alias 336 | -- | and column name as its symbol in record 337 | -- | 338 | -- | ```purescript 339 | -- | i ∷ { a ∷ Col s Int , b ∷ Col s String } = { a: lit 1, b: people.name } 340 | -- | createSubQueryResult namespace i 341 | -- | == 342 | -- | ({ a: ...{ namespace, name: "a" }, b: ...{ namespace, name: "b" } } 343 | -- | ∷ { a ∷ Col s Int , b ∷ Col s String }) 344 | -- | ``` 345 | createSubQueryResult 346 | :: forall i o 347 | . HMapWithIndex SubQueryResult { | i } { | o } 348 | => Alias 349 | -> { | i } 350 | -> { | o } 351 | createSubQueryResult = hmapWithIndex <<< SubQueryResult 352 | 353 | data SubQueryResult = SubQueryResult Alias 354 | 355 | instance subQueryResultInstance :: 356 | IsSymbol sym => 357 | MappingWithIndex SubQueryResult (Proxy sym) (Col s a) (Col s a) 358 | where 359 | mappingWithIndex (SubQueryResult namespace) sym (Col _) = 360 | Col $ EColumn $ Column { namespace, name: reflectSymbol sym } 361 | -------------------------------------------------------------------------------- /test/Common.purs: -------------------------------------------------------------------------------- 1 | module Test.Common where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Selda (Col, FullQuery, Table(..), aggregate, asc, count, crossJoin, desc, distinct, groupBy, having, inArray, in_, innerJoin, innerJoin_, isNull, leftJoin, leftJoin_, limit, lit, max_, notNull, notNull_, offset, orderBy, restrict, selectFrom, selectFrom_, sum_, union, (.<), (.<=), (.==), (.>)) 7 | import Selda.Query.Class (class GenericQuery) 8 | import Test.Types (AccountType(..)) 9 | import Test.Unit (TestSuite) 10 | import Test.Utils (class TestBackend, TestCtx, assertSeqEq, assertUnorderedSeqEq, testWith) 11 | 12 | people ∷ Table ( name ∷ String , age ∷ Maybe Int , id ∷ Int ) 13 | people = Table { name: "people" } 14 | 15 | bankAccounts ∷ Table ( personId ∷ Int, id ∷ Int, balance ∷ Int, accountType ∷ AccountType ) 16 | bankAccounts = Table { name: "bank_accounts" } 17 | 18 | descriptions ∷ Table ( id ∷ Int, text ∷ Maybe String ) 19 | descriptions = Table { name: "descriptions" } 20 | 21 | emptyTable ∷ Table ( id ∷ Int ) 22 | emptyTable = Table { name: "emptyTable" } 23 | 24 | testSelectEscapedString 25 | ∷ ∀ b m ctx 26 | . TestBackend b m ctx 27 | ⇒ GenericQuery b m 28 | ( val ∷ Col b String ) 29 | ( val ∷ String ) 30 | ⇒ TestCtx b m ctx 31 | → TestSuite 32 | testSelectEscapedString ctx = do 33 | testWith ctx assertUnorderedSeqEq "select escaped string" 34 | [ { val: "'abc' \' \"def\"" } ] 35 | $ aux 36 | where 37 | aux ∷ FullQuery b { val ∷ Col b String } 38 | aux = selectFrom people \r → do 39 | restrict $ r.id .== lit 1 40 | pure { val: lit "'abc' \' \"def\"" } 41 | 42 | legacySuite ctx = do 43 | let 44 | unordered = assertUnorderedSeqEq 45 | ordered = assertSeqEq 46 | 47 | testSelectEscapedString ctx 48 | 49 | testWith ctx unordered "simple select people" 50 | [ { id: 1, name: "name1", age: Just 11 } 51 | , { id: 2, name: "name2", age: Just 22 } 52 | , { id: 3, name: "name3", age: Just 33 } 53 | ] 54 | $ selectFrom people \r → do 55 | pure r 56 | 57 | testWith ctx unordered "select people, return different record" 58 | [ { x: 1, y: Just 11 } 59 | , { x: 2, y: Just 22 } 60 | , { x: 3, y: Just 33 } 61 | ] 62 | $ selectFrom people \{ id, age } → do 63 | pure { x: id, y: age } 64 | 65 | testWith ctx unordered "simple select people restrict" 66 | [ { id: 2, name: "name2", age: Just 22 } 67 | , { id: 3, name: "name3", age: Just 33 } 68 | ] 69 | $ selectFrom people \r@{ age } → do 70 | restrict $ age .> lit (Just 20) 71 | pure r 72 | 73 | testWith ctx unordered "simple select restrict on custom type" 74 | [ { id: 2, personId: 1, balance: 150, accountType: Personal } 75 | , { id: 3, personId: 3, balance: 300, accountType: Personal } 76 | ] 77 | $ selectFrom bankAccounts \r@{ accountType } → do 78 | restrict $ accountType .== lit Personal 79 | pure r 80 | 81 | testWith ctx unordered "cross product with restrict" 82 | [ { id1: 2, age1: Just 22, age2: Just 11 } 83 | , { id1: 3, age1: Just 33, age2: Just 11 } 84 | , { id1: 3, age1: Just 33, age2: Just 22 } 85 | ] 86 | $ selectFrom people \r1 → do 87 | r2 ← crossJoin people 88 | restrict $ r1.age .> r2.age 89 | pure { id1: r1.id, age1: r1.age, age2: r2.age } 90 | 91 | testWith ctx unordered "leftJoin: just Maybe Int insead of Maybe Maybe Int " 92 | [ { id: 1 93 | -- , age1: Just 11, age2: Just $ Just 11 94 | , age1: Just 11, age2: Just 11 95 | , name1: "name1", name2: Just "name1" } 96 | ] 97 | $ selectFrom people \r1 → do 98 | r2 ← leftJoin people \{ id } → id .== r1.id 99 | restrict $ r1.id .== lit 1 100 | -- error 101 | -- orderBy asc $ max_ r1.id 102 | pure 103 | { id: r1.id 104 | , age1: r1.age, age2: r2.age 105 | , name1: r1.name, name2: r2.name } 106 | 107 | testWith ctx unordered "leftJoin maybe column: Just Nothing vs Nothing" 108 | [ { id: 1, text: Just "text1" } 109 | , { id: 2, text: Nothing } 110 | , { id: 3, text: Nothing } 111 | -- , { id: 3, text: Just Nothing } 112 | ] 113 | $ selectFrom people \r → do 114 | { text } ← leftJoin descriptions \{ id } → r.id .== id 115 | pure { id: r.id, text } 116 | 117 | testWith ctx unordered "cross product as natural join" 118 | [ { id: 1, balance: 100, accountType: Business } 119 | , { id: 1, balance: 150, accountType: Personal } 120 | -- , { id: 2, balance: Nothing } 121 | , { id: 3, balance: 300, accountType: Personal } 122 | ] 123 | $ selectFrom people \{ id } → do 124 | { accountType, balance, personId } ← crossJoin bankAccounts 125 | restrict $ id .== personId 126 | pure { accountType, id, balance } 127 | 128 | testWith ctx unordered "inner join - natural join" 129 | [ { id: 1, balance: 100, accountType: Business } 130 | , { id: 1, balance: 150, accountType: Personal } 131 | , { id: 3, balance: 300, accountType: Personal } 132 | ] 133 | $ selectFrom people \{ id } → do 134 | { accountType, balance } ← innerJoin bankAccounts $ \b → id .== b.personId 135 | pure { accountType, id, balance } 136 | 137 | testWith ctx unordered "left join" 138 | [ { id: 1, balance: Just 100 } 139 | , { id: 1, balance: Just 150 } 140 | , { id: 2, balance: Nothing } 141 | , { id: 3, balance: Just 300 } 142 | ] 143 | $ selectFrom people \{ id } → do 144 | { balance } ← leftJoin bankAccounts \b → id .== b.personId 145 | pure { id, balance } 146 | 147 | testWith ctx unordered "left join but with subquery" 148 | [ { id: 1, balance: Just 100 } 149 | , { id: 1, balance: Just 150 } 150 | , { id: 2, balance: Nothing } 151 | , { id: 3, balance: Just 300 } 152 | ] 153 | $ selectFrom people \{ id } → do 154 | { balance } ← leftJoin_ (\b → id .== b.personId) do 155 | selectFrom bankAccounts \b → do 156 | -- restrict $ id .== b.personId -- type error 157 | pure b 158 | pure { id, balance } 159 | 160 | testWith ctx unordered "subquery with aggregate max" 161 | [ { balance: Just 150, id: 1 } 162 | , { balance: Nothing, id: 2 } 163 | , { balance: Just 300, id: 3 } 164 | ] $ selectFrom people \{ id } → do 165 | { balance } ← leftJoin_ (\b → id .== b.personId) $ 166 | aggregate $ selectFrom bankAccounts \b → do 167 | personId ← groupBy b.personId 168 | -- restrict $ id .> lit 1 169 | pure { personId, balance: max_ b.balance } 170 | pure { id, balance } 171 | 172 | testWith ctx unordered "aggr: max people id" 173 | [ { maxId: Just 3 } ] 174 | $ aggregate $ selectFrom people \{ id } → do 175 | pure { maxId: max_ id } 176 | 177 | testWith ctx unordered "aggr: max people id from bankAccounts with counts" 178 | [ { pid: 1, m: Just 150, c: 2 } 179 | , { pid: 3, m: Just 300, c: 1 } 180 | ] 181 | $ aggregate $ selectFrom bankAccounts \{ personId, balance } → do 182 | pid ← groupBy personId 183 | pure { pid, m: max_ balance, c: count personId } 184 | 185 | testWith ctx ordered "aggr: order by max people id desc" 186 | [ { pid: 3, m: 300, c: 1 } 187 | , { pid: 1, m: 150, c: 2 } 188 | ] 189 | $ selectFrom_ do 190 | aggregate $ selectFrom bankAccounts \{ personId, balance } → do 191 | pid ← groupBy personId 192 | pure { pid, m: max_ balance, c: count personId } 193 | $ \r@{ pid, c } → do 194 | m ← notNull r.m 195 | orderBy desc m 196 | pure { pid, m, c } 197 | 198 | testWith ctx unordered "aggr: max people id having (using subquery and restrict) count > 1" 199 | [ { pid: 1, m: 150, c: 2 } 200 | ] 201 | $ selectFrom_ do 202 | aggregate $ selectFrom bankAccounts \{ personId, balance } → do 203 | pid ← groupBy personId 204 | pure { pid, m: max_ balance, c: count personId } 205 | $ \r@{ pid, c } → do 206 | m ← notNull r.m 207 | restrict $ c .> lit 1 208 | pure { pid, m, c } 209 | 210 | testWith ctx unordered "aggr: max people id having count > 1" 211 | [ { pid: 1, m: 150, c: 2 } 212 | ] 213 | $ aggregate $ selectFrom bankAccounts \{ personId, balance } → do 214 | pid ← groupBy personId 215 | m ← notNull_ $ max_ balance 216 | let c = count personId 217 | having $ c .> lit 1 218 | pure { pid, m, c } 219 | 220 | testWith ctx unordered "limit negative returns 0" 221 | [ ] 222 | $ selectFrom people \r → do 223 | limit $ -7 224 | pure r 225 | 226 | testWith ctx unordered "offset negative is omitted" 227 | [ { id: 1 } 228 | , { id: 2 } 229 | , { id: 3 } 230 | ] 231 | $ selectFrom people \{ id } → do 232 | offset $ -7 233 | pure { id } 234 | 235 | testWith ctx unordered "limit + offset" 236 | [ { id: 2 } 237 | ] 238 | $ selectFrom people \{ id } → do 239 | orderBy asc id 240 | limit 1 241 | offset 1 242 | pure { id } 243 | 244 | testWith ctx unordered "just offset" 245 | [ { id: 3 } 246 | ] 247 | $ selectFrom people \{ id } → do 248 | orderBy asc id 249 | offset 2 250 | pure { id } 251 | 252 | testWith ctx unordered "limit + order by: return first" 253 | [ { pid: 3, maxBalance: Just 300 } ] 254 | $ aggregate $ selectFrom bankAccounts \{ personId, balance } → do 255 | pid ← groupBy personId 256 | limit 1 257 | orderBy desc personId 258 | pure { pid, maxBalance: max_ balance } 259 | 260 | testWith ctx unordered "max(id) on empty table returns 1 result: null" 261 | [ { maxId: Nothing } ] 262 | $ aggregate $ selectFrom emptyTable \r → pure { maxId: max_ r.id } 263 | 264 | testWith ctx unordered "max(id) on empty table returns 0 results with notNull" 265 | ([ ] ∷ Array { id ∷ Int }) 266 | $ selectFrom_ do 267 | aggregate $ selectFrom emptyTable \r → 268 | pure { maxId: max_ r.id } 269 | $ \r → do 270 | id ← notNull r.maxId 271 | pure { id } 272 | 273 | testWith ctx unordered "sum(balance); OR operator" 274 | [ { pid: 1, sum: Just 250 } 275 | , { pid: 2, sum: Nothing } 276 | ] 277 | $ aggregate $ selectFrom people \p → do 278 | b ← leftJoin bankAccounts \{ personId } → p.id .== personId 279 | pid ← groupBy p.id 280 | restrict $ p.id .== lit 1 || p.id .== lit 2 281 | pure { pid, sum: sum_ b.balance} 282 | 283 | testWith ctx unordered "return only not null values" 284 | [ { id: 1, text: "text1" } ] 285 | $ selectFrom descriptions \ { id, text: maybeText } → do 286 | text ← notNull maybeText 287 | pure { id, text } 288 | 289 | testWith ctx unordered "inArray" 290 | [ { id: 1, name: "name1", age: Just 11 } 291 | , { id: 3, name: "name3", age: Just 33 } 292 | ] 293 | $ selectFrom people \r → do 294 | restrict $ r.id `inArray` [ lit 1, lit 3 ] 295 | pure r 296 | 297 | testWith ctx unordered "not inArray" 298 | [ { id: 2, name: "name2", age: Just 22 } ] 299 | $ selectFrom people \r → do 300 | restrict $ not $ r.id `inArray` [ lit 1, lit 3 ] 301 | pure r 302 | 303 | testWith ctx unordered "select distinct personId from bankAccounts" 304 | [ { pid: 1 } 305 | , { pid: 3 } 306 | ] 307 | $ distinct $ selectFrom bankAccounts \r → do 308 | pure { pid: r.personId } 309 | 310 | testWith ctx unordered "restricted inner join without a subquery" 311 | [ { pid: 1 } 312 | , { pid: 3 } 313 | ] 314 | $ selectFrom people \r → do 315 | b ← leftJoin bankAccounts 316 | (\b → r.id .== b.personId && b.balance .> lit 100) 317 | _ ← notNull b.id 318 | pure { pid: r.id } 319 | 320 | testWith ctx unordered "select not null text from descriptions" 321 | [ { id: 3, text: Nothing } ] 322 | $ selectFrom descriptions \r → do 323 | restrict $ isNull r.text 324 | pure r 325 | 326 | testWith ctx unordered "union people with itself" 327 | [ { id: 1, name: "name1", age: Just 11 } 328 | , { id: 2, name: "name2", age: Just 22 } 329 | , { id: 3, name: "name3", age: Just 33 } 330 | ] 331 | $ selectFrom people pure `union` selectFrom people pure $ pure 332 | 333 | testWith ctx unordered "union people with itself - nested variant" 334 | [ { id: 1 } 335 | , { id: 2 } 336 | , { id: 3 } 337 | ] 338 | $ selectFrom people pure `union` selectFrom people pure $ \r → do 339 | pure { id: r.id } 340 | 341 | testWith ctx unordered "union age and balance" 342 | [ { v: 11 } 343 | , { v: 22 } 344 | , { v: 33 } 345 | , { v: 100 } 346 | ] 347 | $ union 348 | (selectFrom bankAccounts \r → pure { v: r.balance }) 349 | (selectFrom people \r → do 350 | v ← notNull r.age 351 | pure { v }) 352 | \r → do 353 | restrict $ r.v .<= lit 100 354 | pure r 355 | 356 | testWith ctx unordered "limit + orderby in subquery - with left join" 357 | [ { pid: 1, balance: 100 } 358 | , { pid: 1, balance: 150 } 359 | ] 360 | $ selectFrom people \r → do 361 | b ← leftJoin_ (\b → b.personId .== r.id) $ 362 | selectFrom bankAccounts \b → do 363 | limit 2 364 | orderBy asc b.balance 365 | pure b 366 | balance ← notNull b.balance 367 | pure { pid: r.id, balance } 368 | 369 | testWith ctx unordered "limit + orderby in subquery - with inner join" 370 | [ { pid: 1, balance: 100 } 371 | , { pid: 1, balance: 150 } 372 | ] 373 | $ selectFrom people \r → do 374 | { balance } ← innerJoin_ (\b → b.personId .== r.id) $ 375 | selectFrom bankAccounts \b → do 376 | limit 2 377 | orderBy asc b.balance 378 | pure b 379 | pure { pid: r.id, balance } 380 | 381 | testWith ctx unordered "limit in union's subqueries" 382 | [ { id: 1 } 383 | ] 384 | $ 385 | let 386 | subQ = selectFrom people \r → do 387 | limit 1 388 | restrict $ r.id .== lit 1 389 | pure { id: r.id } 390 | in subQ `union` subQ $ pure 391 | 392 | testWith ctx unordered "people with bank accounts using IN" 393 | [ { id: 1 } ] 394 | $ selectFrom people \{ id } → do 395 | restrict $ id .< lit 2 396 | restrict $ id `in_` (selectFrom bankAccounts \r → pure { x: r.personId }) 397 | restrict $ id .> lit 0 398 | pure { id } 399 | -------------------------------------------------------------------------------- /guide/Custom.md: -------------------------------------------------------------------------------- 1 | # Custom Types 2 | 3 | - [Custom Types](#custom-types) 4 | - [Preface](#preface) 5 | - [Before](#before) 6 | - [New Custom Type](#new-custom-type) 7 | - [Table Definition](#table-definition) 8 | - [`FromSQLValue`](#fromsqlvalue) 9 | - [`ToSQLValue`](#tosqlvalue) 10 | - [`litPG` vs `lit`](#litpg-vs-lit) 11 | - [Instances](#instances) 12 | - [Unsafe Escape Hatch](#unsafe-escape-hatch) 13 | - [`litPG` and `EForeign`](#litpg-and-eforeign) 14 | - [Any](#any) 15 | - [Custom PG function](#custom-pg-function) 16 | - [Table](#table) 17 | - [Table-like Source](#table-like-source) 18 | - [DB Schema - qualified table names](#db-schema---qualified-table-names) 19 | - [generate_series](#generate_series) 20 | - [Summary](#summary) 21 | - [Main Execution](#main-execution) 22 | - [Output](#output) 23 | 24 | ## Preface 25 | 26 | This cook book recipe is a literate PureScript file, which is designed to be a standalone runnable example. 27 | 28 | This guide describes how to handle custom data types *as-types-of-columns* in selda - how to define tables with them, query values of these types and write queries with these values as parameters. 29 | 30 | ```purescript 31 | module Guide.Custom where 32 | 33 | import Prelude 34 | 35 | import Control.Monad.Except (runExcept) 36 | import Data.Bifunctor (lmap) 37 | import Data.Either (Either(..), either) 38 | import Data.Generic.Rep (class Generic) 39 | import Data.Show.Generic (genericShow) 40 | import Data.Maybe (Maybe(..), maybe) 41 | import Database.PostgreSQL (class FromSQLValue, class ToSQLValue) 42 | import Effect (Effect) 43 | import Effect.Class (class MonadEffect) 44 | import Effect.Class.Console (log, logShow) 45 | import Foreign (readString, unsafeToForeign) 46 | import JS.Unsafe.Stringify (unsafeStringify) 47 | import Guide.SimpleE2E as Guide 48 | import Selda (Col(..), FullQuery, Table(..), distinct, innerJoin, innerJoin_, lit, notNull, restrict, selectFrom, showQuery, (.==), (.>=)) 49 | import Selda.Col (class GetCols, showCol) 50 | import Selda.Expr (Expr(..)) 51 | import Selda.PG (litPG, showPG) 52 | import Selda.PG.Class (insert_) 53 | import Selda.PG.Class as PG 54 | import Selda.Query.Class (runSelda) 55 | ``` 56 | ## Before 57 | 58 | Selda supports simple data types like String, Int, Maybe on its own. 59 | We can simply declare a table definition using these types. 60 | 61 | *(Remember that selda does not modify the database schema - 62 | a table definition is like a type annotation for already created table)* 63 | 64 | ```purescript 65 | people ∷ Table ( name ∷ String, age ∷ Maybe Int, id ∷ Int ) 66 | people = Table { name: "people" } 67 | ``` 68 | 69 | also querying values of these simple types and 70 | lifting them to column expressions `Col s a` (using the function `lit ∷ a → Col s a`) 71 | works just fine. 72 | 73 | ```purescript 74 | selectAdults 75 | ∷ ∀ s 76 | . FullQuery s { name ∷ Col s String, age ∷ Col s (Maybe Int), id ∷ Col s Int } 77 | selectAdults = selectFrom people \r → do 78 | age ← notNull r.age 79 | restrict $ age .>= lit 18 80 | pure r 81 | 82 | queryAdults 83 | ∷ ∀ m 84 | . PG.MonadSeldaPG m 85 | ⇒ m (Array { name ∷ String , age ∷ Maybe Int , id ∷ Int }) 86 | queryAdults = PG.query selectAdults 87 | ``` 88 | 89 | ## New Custom Type 90 | 91 | But we sometimes want to use other data types. 92 | Say we want to define another table called `bankAccounts` with a column 93 | called `accountType` that is an enum with possible values: 94 | "personal" or "business" 95 | 96 | It's convenient to mirror it with a custom data type `AccountType` in PureScript 97 | 98 | ```purescript 99 | data AccountType 100 | = Business 101 | | Personal 102 | derive instance eqAccountType ∷ Eq AccountType 103 | derive instance genericAccountType ∷ Generic AccountType _ 104 | instance showAccountTyp ∷ Show AccountType where 105 | show = genericShow 106 | ``` 107 | 108 | ### Table Definition 109 | 110 | We use `AccountType` to annotate a column `accountType` in the following table definition 111 | 112 | ```purescript 113 | bankAccounts ∷ Table ( personId ∷ Int, balance ∷ Int, accountType ∷ AccountType ) 114 | bankAccounts = Table { name: "bank_accounts" } 115 | ``` 116 | 117 | As an example let's consider a query that returns distinct account types of 118 | a person with a given name 119 | 120 | ```purescript 121 | selectAccountTypesOf 122 | ∷ ∀ s 123 | . String 124 | → FullQuery s { accountType ∷ Col s AccountType } 125 | selectAccountTypesOf name = distinct $ selectFrom people \r → do 126 | { accountType } ← innerJoin bankAccounts \b → b.personId .== r.id 127 | restrict $ r.name .== lit name 128 | pure { accountType } 129 | ``` 130 | 131 | But when we try to execute this query we get the following error: 132 | 133 | ``` 134 | No type class instance was found for 135 | Database.PostgreSQL.Value.FromSQLValue AccountType 136 | ``` 137 | 138 | Since we are using `PG.query` function for PostgreSQL we get an 139 | error specific to the `purescript-postgresql-client`. 140 | It uses two type classes (`ToSQLValue` and `FromSQLValue`) to 141 | handle serialization and deserialization. 142 | 143 | ### `FromSQLValue` 144 | 145 | `FromSQLValue` is used to parse `Foreign` value into `AccountType` in this case 146 | There are already provided instances for common data types, but we need to 147 | write our own to handle querying `AccountType` 148 | 149 | ```purescript 150 | queryAccountTypesOf 151 | ∷ ∀ m 152 | . PG.MonadSeldaPG m 153 | ⇒ FromSQLValue AccountType -- just to emphasise that we need this instance 154 | ⇒ m (Array { accountType ∷ AccountType }) 155 | queryAccountTypesOf = PG.query $ selectAccountTypesOf "John Smith" 156 | ``` 157 | 158 | ### `ToSQLValue` 159 | 160 | Similarly we would like to write queries with `AccountType` values. 161 | For example we could restrict a query to personal accounts only. 162 | Thus we want a function of type `AccountType → Col s AccountType` that could 163 | lift a value to a column expression. 164 | Previously we used `lit` to do that but it is restricted to simple data types. 165 | Here we need to use PostgreSQL specific function `litPG` that can create 166 | a column expression `Col s a` provided that there's an instance of `ToSQLValue a` 167 | 168 | #### `litPG` vs `lit` 169 | 170 | > Side note: One could use `litPG` exclusively and don't bother with dilemma when to use `lit` and when to use `litPG`. 171 | > But then every query becomes PG specific and might break when executed by another (e.g. SQLite3) backend. 172 | > Another difference between `lit` and `litPG` is that `lit` serializes a value to a string so it is visible in the printed query. 173 | > `litPG` on the other hand makes a query parameter - it serializes a value to `Foreign` and inserts a placeholder where `lit` might write a string. 174 | 175 | ```purescript 176 | selectAdultAccounts 177 | ∷ ∀ s 178 | . ToSQLValue AccountType -- just to emphasise that we need this instance 179 | ⇒ FullQuery s 180 | { balance ∷ Col s Int 181 | , id ∷ Col s Int 182 | } 183 | selectAdultAccounts = selectFrom bankAccounts \r@{balance} → do 184 | adult ← innerJoin_ (\a → a.id .== r.personId) selectAdults 185 | restrict $ r.accountType .== litPG Personal -- Only personal accounts! 186 | pure { id: adult.id, balance } 187 | ``` 188 | 189 | ## Instances 190 | 191 | Now to discharge these constraints we need instances of `FromSQLValue` and `ToSQLValue` for `AccountType`. 192 | 193 | ```purescript 194 | instance fromSqlValueAccountType ∷ FromSQLValue AccountType where 195 | fromSQLValue = readAccountType <=< lmap show <<< runExcept <<< readString 196 | 197 | readAccountType ∷ String → Either String AccountType 198 | readAccountType "business" = Right Business 199 | readAccountType "personal" = Right Personal 200 | readAccountType other = Left $ "Incorrect account type: " <> other 201 | 202 | instance toSQLValueProductType ∷ ToSQLValue AccountType where 203 | toSQLValue = showAccountType >>> unsafeToForeign 204 | 205 | showAccountType ∷ AccountType → String 206 | showAccountType Business = "business" 207 | showAccountType Personal = "personal" 208 | ``` 209 | 210 | ## Unsafe Escape Hatch 211 | 212 | Sometimes we want to make unsafe extensions and expose them via safe interface. 213 | One of such extensions would be to write a piece of SQL in a string and integrate it with selda expressions. 214 | 215 | Selda has fixed ADT that represent expressions (e.g. literals, some binary operations, some aggregate functions) - but it has two escape hatches that allow a user to make extensions. 216 | 217 | Firstly, user can provide a `Foreign` value (which is utilised by `litPG`). 218 | 219 | Secondly, user can provide an SQL in a string (covered below - [Any](#any)) 220 | 221 | ### `litPG` and `EForeign` 222 | 223 | It is worth knowing the implementation of `litPG`. 224 | 225 | ```purescript 226 | litPG ∷ ∀ col s a. ToSQLValue a ⇒ Coerce col ⇒ a → col s a 227 | litPG = unsafeFromCol <<< Col <<< EForeign <<< toSQLValue 228 | ``` 229 | 230 | - `toSQLValue` serializes a value to `Foreign` 231 | - `Col <<< EForeign` is an escape hatch - it creates a `Col s a` for any `Foreign` value, thus it is worth to use it carefully and always provide a type annotation 232 | - `unsafeFromCol` is a method from the `Coerce` class 233 | 234 | > `class Coerce` : 235 | > allows overloading for values that can be both `Col s a` and `Aggr s a`. 236 | > 237 | > For example: columns from a table need to be in the `GROUP BY` clause to be safely coerced to `Aggr`, while constants can be safely used in both contexts. 238 | > Hence we can use `litPG` for writing `restrict` (`Col s Boolean`) and `having` (`Aggr s Boolean`) conditions. 239 | 240 | ### Any 241 | 242 | Second use case: user can provide any SQL string as an expression. 243 | It is possible with the following function 244 | 245 | ```purescript 246 | (Col <<< Any) ∷ ∀ s a. ShowM → Col s a 247 | ``` 248 | 249 | It is best to think of `ShowM` as an abstract monad `m String` that additionally supports `showCol ∷ ∀ s a. Col s a → ShowM`. 250 | 251 | To simply provide an SQL string use `(Col <<< Any <<< pure) ∷ ∀ s a. String → Col s a` 252 | 253 | #### Custom PG function 254 | 255 | But it is usually not enough to use raw Strings. 256 | Some expressions depend on others, meaning we would have to serialize each of them to a string, but some are `Foreign` query parameters not meant to be *stringified*. 257 | Thus we need the `ShowM` monad and `showCol` function (or any `showX` function returning `ShowM`) to make proper string representations for every `Col` expression *(returning a placeholder (e.g. "$7") and accumulating parameters in case of `Foreign` query parameter)* 258 | 259 | Consider the following PG-specific function [`EXTRACT`](https://www.postgresql.org/docs/current/functions-datetime.html#FUNCTIONS-DATETIME-EXTRACT) that retrieves subfields from date/time values. 260 | 261 | We would like to encode it in selda. 262 | Say we want its type to be `extract ∷ ∀ a s. String → Col s a → Col s Int`. 263 | 264 | ***Please note** it is possibe to write a **more type-safe variant** either by restricting `a` to a date type or not allowing arbitrary strings as its first argument. 265 | But we want to keep it simple. 266 | User can write a safer alternative by wrapping the function `extract` defined below.* 267 | 268 | Let's implement it: 269 | 270 | ```purescript 271 | extract ∷ ∀ a s. String → Col s a → Col s Int 272 | extract field col = Col $ Any do 273 | s ← showCol col 274 | pure $ "extract(" <> field <> " from " <> s <> ")" 275 | ``` 276 | 277 | - `field` could be one of `["day", "month", "year"]` 278 | - `extract` depends on another expression `Col s a` so we need to turn in into a string using `showCol` function in order to use `Any` 279 | - In the last line we build a raw SQL string for the whole expression 280 | - We annotated it to return `Col s Int` because we know that it would match the foreign value returned one the query is executed - We could annotate it differently and maybe provide our own custom data type and handle \[de\]serialization ourselves with `From/ToSQLValue` instances. 281 | 282 | > **SQL expressions vs. SQL statements** 283 | > 284 | > One could think that now we can write any query as a raw SQL string since we have `Any`, but it is not that simple. 285 | > We can only use it to represent expressions whereas query is a `SELECT` statement, though there are expressions that depend on statements e.g. `IN` takes an expression and a query and returns a bool so it is expressible using `Any` (see: `in_` function). 286 | > 287 | > Though it is possible to encode more than just expressions - please see [Table-like Source](#table-like-source) 288 | 289 | ### Table 290 | 291 | To represent database tables we normally use `Table` constructor to provide the table name as well as column names with their corresponding types. 292 | 293 | Say we have a table named `"users"` with columns `( name ∷ String, id ∷ Int )`. 294 | When we generate SQL for a query involving `users` each column is prefixed with an alias for its *source* (here the *source* is the table `users`). 295 | 296 | Aliases are created using the table/source name and a unique number. 297 | - Meaning instead of `name` in a generated SQL there is `users_7.name`. 298 | - and after `FROM` (or `JOIN` ...) we see `... FROM users users_7 ...` 299 | 300 | These are the only two uses for `Table` data type during SQL generation: 301 | 1. get an alias so column names can be qualified 302 | 2. get its representation - a string that should appear after `FROM` (or `JOIN` ...) 303 | 304 | **Problem:** 305 | - tables created in different database schemas are not definable with the `Table` constructor (for a table `"myschema.users"` it produces incorrect qualified column names like `"myschema.users_3.name"`) 306 | - set returning database functions (like [`generate_series`](https://www.postgresql.org/docs/current/functions-srf.html)) that could be treated like a read-only tables yield a similar problem with aliases 307 | 308 | #### Table-like Source 309 | 310 | To retain readable aliases and fix problems above (and open more possibilities) there's another constructor called `Source` for the `Table` data type. 311 | 312 | `Source ∷ ∀ r. Alias → (Maybe Alias → StringSQL) → Table r` 313 | 314 | `Alias` and `StringSQL` are just aliases for `String`. 315 | So to create an arbitrary table-like source we need: 316 | - an alias - a prefix of the full alias used to qualify column names (a unique number will be provided during SQL generation) 317 | - a way to create its string-representation given a full alias (with a unique number already concatenated) 318 | - in case of `INSERT`/`UPDATE`/`DELETE` there's no alias hence there's `Maybe` 319 | 320 | ##### DB Schema - qualified table names 321 | 322 | To represent tables with schema-qualified names we use the `Source` constructor. 323 | 324 | **Example**: Given a table called `"myschema.users"` we create a table definition for it in a following way. 325 | 326 | ```purescript 327 | myschemaUsers ∷ Table ( name ∷ String, id ∷ Int ) 328 | myschemaUsers = Source "users" $ case _ of 329 | Nothing → "myschema.users" 330 | Just alias → "myschema.users" <> " " <> alias 331 | ``` 332 | 333 | Notice that the type-level part is the same as for the `Table` constructor - meaning we define columns the same way as before. 334 | 335 | ##### generate_series 336 | 337 | Similarly we utilise the `Source` constructor to represent set returning functions that can be treated like read-only tables, but aren't really tables. 338 | 339 | ```purescript 340 | generateSeries ∷ Int → Int → Table ( i ∷ Int ) 341 | generateSeries start stop = Source "gs" \maybeAlias → 342 | let alias = maybe "" identity maybeAlias in 343 | "generate_series(" <> show start <> ", " <> show stop <> ") " <> alias <> " (i)" 344 | ``` 345 | 346 | - We ignore alias being `Nothing` (it will break when we attempt to call insert/update/delete on it). 347 | - The string returned by the function in `Source` is tied to the type-level information - name of the column `i` is provided in the string as well as in the type row 348 | 349 | Executing a query `selectFrom (generateSeries 3 5) pure` the following SQL is generated 350 | 351 | ```SQL 352 | SELECT gs_0.i AS i 353 | FROM generate_series(3, 5) gs_0 (i) 354 | ``` 355 | 356 | ## Summary 357 | 358 | To sum up - to handle custom data types all we need to do is write appriopriate instances for the backend we chose. 359 | For pgclient they are: `ToSQLValue` and `FromSQLValue`. 360 | 361 | To make it complete let's execute queries that we've covered. 362 | We will use some functionality from the [Guide](SimpleE2E.md). 363 | 364 | To execute the main function below plese run following commands: 365 | ``` 366 | npm run-script lit && spago run -m Guide.Custom 367 | ``` 368 | 369 | ### Main Execution 370 | 371 | ```purescript 372 | main ∷ Effect Unit 373 | main = Guide.launchWithConnectionPG \conn → do 374 | -- create tables 375 | Guide.createPeople conn 376 | Guide.execute -- create bank accounts 377 | """ 378 | DROP TABLE IF EXISTS bank_accounts; 379 | CREATE TABLE bank_accounts ( 380 | id SERIAL PRIMARY KEY, 381 | "personId" INTEGER NOT NULL, 382 | balance INTEGER NOT NULL DEFAULT 100, 383 | "accountType" TEXT NOT NULL 384 | );""" conn 385 | 386 | runSelda conn app >>= either logShow pure 387 | 388 | app ∷ ∀ m. PG.MonadSeldaPG m ⇒ m Unit 389 | app = do 390 | -- insert some rows 391 | insert_ people 392 | [ { id: 1, name: "Just Mark", age: Just 11 } 393 | , { id: 2, name: "John Smith", age: Just 22 } 394 | ] 395 | insert_ bankAccounts 396 | [ { personId: 1, balance: 100, accountType: Personal } 397 | , { personId: 2, balance: 1000, accountType: Personal } 398 | , { personId: 2, balance: 1000, accountType: Business } 399 | , { personId: 2, balance: 2341, accountType: Business } 400 | ] 401 | logQuery $ selectAdults 402 | logQuery $ selectAccountTypesOf "John Smith" 403 | logQuery $ selectAdultAccounts 404 | 405 | log "query results" 406 | logShow =<< queryAdults 407 | logShow =<< queryAccountTypesOf 408 | logShow =<< PG.query selectAdultAccounts 409 | 410 | logQuery ∷ ∀ s i m. GetCols i ⇒ MonadEffect m ⇒ FullQuery s { | i } → m Unit 411 | logQuery q = do 412 | let { strQuery, params } = showPG $ showQuery q 413 | log strQuery 414 | log $ unsafeStringify params 415 | log "" 416 | ``` 417 | 418 | #### Output 419 | (may be outdated) 420 | ``` 421 | SELECT people_0.name AS name, people_0.id AS id, people_0.age AS age 422 | FROM people people_0 423 | WHERE (people_0.age >= 18) AND (people_0.age IS NOT NULL) 424 | [] 425 | 426 | SELECT DISTINCT bank_accounts_1.accountType AS accountType 427 | FROM people people_0 428 | JOIN bank_accounts bank_accounts_1 ON ((bank_accounts_1.personId = people_0.id)) 429 | WHERE (people_0.name = 'John Smith') 430 | [] 431 | 432 | SELECT sub_q1.id AS id, bank_accounts_0.balance AS balance 433 | FROM bank_accounts bank_accounts_0 434 | JOIN 435 | ( SELECT people_0.name AS name, people_0.id AS id, people_0.age AS age 436 | FROM people people_0 437 | WHERE (people_0.age >= 18) AND (people_0.age IS NOT NULL) ) sub_q1 ON ((sub_q1.id = bank_accounts_0.personId)) 438 | WHERE (bank_accounts_0.accountType = $1) 439 | ["personal"] 440 | 441 | query results 442 | [{ age: (Just 22), id: 2, name: "John Smith" }] 443 | [{ accountType: Business },{ accountType: Personal }] 444 | [{ balance: 1000, id: 2 }] 445 | ``` 446 | -------------------------------------------------------------------------------- /guide/SimpleE2E.md: -------------------------------------------------------------------------------- 1 | # Simple End-to-End Example 2 | 3 | - [Simple End-to-End Example](#simple-end-to-end-example) 4 | - [Preface](#preface) 5 | - [Setup](#setup) 6 | - [Table definition](#table-definition) 7 | - [Constraints - wrappers: `Auto` and `Default`](#constraints---wrappers-auto-and-default) 8 | - [First Query](#first-query) 9 | - [Query vs. FullQuery](#query-vs-fullquery) 10 | - [Nested Query](#nested-query) 11 | - [Aggregation](#aggregation) 12 | - [Type Errors](#type-errors) 13 | - [Execution](#execution) 14 | - [Query Pretty Printing](#query-pretty-printing) 15 | - [Execution](#execution-1) 16 | 17 | ## Preface 18 | 19 | This guide is a literate PureScript file, which is designed to be a standalone runnable example (executed before the actual test suite). 20 | So it is quite verbose and in the [Setup](#setup) chapter we do some schema modifications that would normally by in a separate script. 21 | Just have it in mind while reading :wink: 22 | 23 | ```purescript 24 | module Guide.SimpleE2E where 25 | 26 | import Prelude 27 | 28 | import Control.Monad.Except (class MonadError, ExceptT, runExceptT, throwError) 29 | import Control.Monad.Reader (class MonadReader, ReaderT, asks, runReaderT) 30 | import Data.Either (Either(..), either) 31 | import Data.Maybe (Maybe(..), maybe) 32 | import Data.Variant (Variant, inj) 33 | import Database.PostgreSQL (PGError) 34 | import Database.PostgreSQL as PostgreSQL 35 | import Database.PostgreSQL.Aff as PostgreSQL.Aff 36 | import Effect (Effect) 37 | import Effect.Aff (Aff, error, launchAff_) 38 | import Effect.Aff as Aff 39 | import Effect.Aff.Class (class MonadAff, liftAff) 40 | import Effect.Class.Console (log, logShow) 41 | import Selda (Col, FullQuery, Table(..), aggregate, max_, count, groupBy, leftJoin, lit, notNull, restrict, selectFrom, selectFrom_, showQuery, (.==), (.>)) 42 | import Selda.Aggr (Aggr) 43 | import Selda.Col (class GetCols) 44 | import Selda.PG (showPG) 45 | import Selda.PG.Class (insert_, query) 46 | import Selda.Table.Constraint (Auto, Default) 47 | import Test.Selda.PG.Config (load) as Config 48 | import Type.Proxy (Proxy(..)) 49 | ``` 50 | ## Setup 51 | 52 | - To run the examples below we need a postgresql db. 53 | Set it up with the following command: 54 | 55 | ```bash 56 | docker-compose up -d 57 | ``` 58 | Or do it manually - check [docker-compose.yml](../docker-compose.yml) 59 | 60 | - prepare `.env` file 61 | 62 | ```bash 63 | cp .env-ci .env 64 | ``` 65 | 66 | ### Table definition 67 | 68 | If we have a database table already created, we have to declare it here to reference it. 69 | We use a `Table` data type to create a *table definition*. 70 | Its type is parameterized by a *row of types* that describes the columns and their types in the database. 71 | 72 | ```purescript 73 | exampleTable ∷ Table 74 | ( nullableText ∷ Maybe String -- column with possible null values 75 | , numberColumn ∷ Int -- integer column with `NOT NULL` constraint 76 | , autoNumber ∷ Auto Int -- value is supplied automatically, cannot be inserted 77 | , valueWithDefault ∷ Default Int -- optional column for `insert` operation 78 | ) 79 | exampleTable = Table { name: "example_table" } 80 | ``` 81 | 82 | We will use the `postgresql-client` to create some tables in our database. 83 | To do so we define an auxiliary function `execute` that takes the SQL string literal, executes it and if something goes wrong it throws an error. 84 | 85 | ```purescript 86 | execute ∷ String → PostgreSQL.Connection → Aff Unit 87 | execute sql conn = do 88 | PostgreSQL.Aff.execute' conn (PostgreSQL.Query sql) 89 | >>= maybe (pure unit) (throwError <<< error <<< show) 90 | ``` 91 | 92 | The function that creates our first table - `people` - is defined below. 93 | 94 | ```purescript 95 | createPeople ∷ PostgreSQL.Connection → Aff Unit 96 | createPeople = execute """ 97 | DROP TABLE IF EXISTS people; 98 | CREATE TABLE people ( 99 | id INTEGER PRIMARY KEY, 100 | name TEXT NOT NULL, 101 | age INTEGER 102 | );""" 103 | ``` 104 | 105 | Please note that `purescript-selda` does not handle schema modification, such as table creation, we are doing it manually using `postgresql-client`. 106 | So it is important to correctly define the tables and types for its columns. 107 | 108 | Notice that `name` column has `NOT NULL` constraint, unlike the `age` column. 109 | We use `Maybe` for type of nullable columns. 110 | 111 | ```purescript 112 | people ∷ Table 113 | ( id ∷ Int 114 | , name ∷ String 115 | , age ∷ Maybe Int 116 | ) 117 | people = Table { name: "people" } 118 | ``` 119 | 120 | #### Constraints - wrappers: `Auto` and `Default` 121 | 122 | Sometimes we want the database to create values for some columns automatically. 123 | So we could not be able to insert these manually, but still have an opportunity to query whole rows from a table. 124 | Similarly other columns may be optional - with default value. 125 | 126 | We will present what to do in such situations by defining a table `bankAccounts` with an auto-increment value and a column with a default value. 127 | 128 | ```purescript 129 | createBankAccounts ∷ PostgreSQL.Connection → Aff Unit 130 | createBankAccounts = execute """ 131 | DROP TABLE IF EXISTS bank_accounts; 132 | CREATE TABLE bank_accounts ( 133 | id SERIAL PRIMARY KEY, 134 | "personId" INTEGER NOT NULL, 135 | balance INTEGER NOT NULL DEFAULT 100 136 | );""" 137 | 138 | bankAccounts ∷ Table 139 | ( id ∷ Auto Int 140 | , personId ∷ Int 141 | , balance ∷ Default Int 142 | ) 143 | bankAccounts = Table { name: "bank_accounts" } 144 | ``` 145 | 146 | We express that a column value is assigned automatically by wrapping its type in a `Auto` constructor, likewise `Default` for columns that can we optionally specify for the `insert` operation. 147 | 148 | Using a *constraint constructor* (`Auto`, `Default`) only affects `insert` operation. 149 | 150 | | Column's type Wrapper | on **insert** | 151 | | ---------------------------- | ------------------ | 152 | | *None* (e.g. `Int`) | value is required | 153 | | Default (e.g. `Default Int`) | value is optional | 154 | | Auto (e.g. `Auto Int`) | value is forbidden | 155 | 156 | 158 | 159 | ## First Query 160 | 161 | Since we have defined table definitions, we can write some queries. 162 | Let's say we want to get people's names along with their balance, but we only want people with *id* higher than 1. 163 | 164 | We can solve it with a following SQL query. 165 | 166 | ```sql 167 | SELECT people.name, bank_accounts.balance 168 | FROM people 169 | LEFT JOIN bank_accounts ON people.id = bank_accounts.personId 170 | WHERE people.id > 1 171 | ``` 172 | 173 | We can write the same query using `purescript-selda`. 174 | 175 | ```purescript 176 | qNamesWithBalance 177 | ∷ ∀ s. FullQuery s { name ∷ Col s String , balance ∷ Col s (Maybe Int) } 178 | qNamesWithBalance = 179 | selectFrom people \{ id, name } → do -- FROM people 180 | { balance } ← leftJoin bankAccounts -- LEFT JOIN bank_accounts 181 | \acc → id .== acc.personId -- ON people.id = bank_accounts.personId 182 | restrict $ id .> lit 1 -- WHERE people.id > 1 183 | pure { name, balance } -- SELECT people.name, bank_accounts.balance 184 | ``` 185 | 186 | And below is the generated SQL for the query `qNamesWithBalance`. 187 | 188 | ```sql 189 | SELECT people_0.name AS name, bank_accounts_1.balance AS balance 190 | FROM people people_0 191 | LEFT JOIN bank_accounts bank_accounts_1 ON ((people_0.id = bank_accounts_1.personId)) 192 | WHERE (people_0.id > 1) 193 | ``` 194 | 195 | We define a query using the `selectFrom` function by providing a **table definition** and a function that takes a record of columns from the table and returns a *query description*. 196 | Operations such as `restrict` and `leftJoin` modify the state of the query, or as we called it earlier - *query description*. 197 | 198 | 200 | 201 | 204 | We write a join condition as a function that takes a record of columns from a table we are joining and return a boolean expression. 205 | Notice that `leftJoin` also changes the types in a column's record. The `balance` column is nullable in that context, so it represents a value of type `Maybe Int`. 206 | 207 | 208 | #### Query vs. FullQuery 209 | 210 | The return type of operations like `restrict` and `leftJoin` is `Query s _`, contrary to the return type of the `selectFrom` which is `FullQuery s _`. 211 | The difference between them is very subtle. 212 | The idea is that `FullQuery` means a *fully described query*, so it can be used as a nested query or executed. 213 | Without the distinction one could write just a `restrict` (or `leftJoin`) operation and execute this 'query'. 214 | Everything would typecheck, but in the runtime we would get a query without any table name in the `FROM` clause (like: `SELECT ... FROM ??? WHERE ...`). 215 | 216 | ## Nested Query 217 | 218 | We can use the previously defined `qNamesWithBalance` as a subquery to filter out the null values in the `balance` column. 219 | 220 | ```purescript 221 | qBankAccountOwnersWithBalance 222 | ∷ ∀ s. FullQuery s { name ∷ Col s String , balance ∷ Col s Int } 223 | qBankAccountOwnersWithBalance = 224 | selectFrom_ qNamesWithBalance \r → do 225 | balance ← notNull r.balance 226 | pure $ r { balance = balance } 227 | ``` 228 | 229 | We used the `selectFrom_` function which is similar to the `selectFrom` that we saw earlier, but instead of *table definition* we provide a nested query as its first argument. 230 | 231 | In the *query description* we filter out the null values in balance. 232 | It adds to the `WHERE` clause that `balance IS NOT NULL` and it returns a column representation `Col s Int` instead of `Col s (Maybe Int)`. 233 | 234 | ## Aggregation 235 | 236 | We would like to know how many people have a bank account. 237 | To do this we first write a query that returns `personId` from `bankAccounts` without duplicates. 238 | We accomplish that using aggregation: we are groupping by `personId` column and simply return the only aggregated column. 239 | 240 | Queries that use aggregation can be problematic. 241 | Only aggregated columns and results of aggregate functions can appear in the result. 242 | To prevent some such runtime errors, we added separate representation for aggregate values (`Aggr s a`) which is only returned by `groupBy` and aggregate functions like `count` and `max_`. 243 | Mixing `Col` and `Aggr` is not allowed and it will result in a type error. 244 | To validate and use the query (nest it or execute it) we have to call `aggregate` function that changes `Aggr` into `Col`. 245 | 246 | ```purescript 247 | qCountBankAccountOwners 248 | ∷ ∀ s. FullQuery s { numberOfOwners ∷ Col s Int } 249 | qCountBankAccountOwners = 250 | aggregate $ selectFrom_ 251 | (aggregate $ selectFrom bankAccounts \{ personId } → do 252 | pid ← groupBy personId 253 | pure { pid }) 254 | \{ pid } → pure { numberOfOwners: count pid } 255 | ``` 256 | 257 | ## Type Errors 258 | 259 | Sometimes we do something wrong and it (hopefully) results in a type error (and not a runtime error). 260 | We would like to get useful error messages that lead us to the source of the problem, but when a library heavily uses generic programming on type classes it is not always possible... 261 | 262 | ```purescript 263 | aggregate $ selectFrom_ 264 | (aggregate $ selectFrom bankAccounts \{ id, personId } → do 265 | pid ← groupBy personId 266 | pure { pid: personId }) -- (personId ∷ Col _ _) used instead of (pid ∷ Aggr _ _) 267 | \{ pid } → pure { numberOfOwners: count pid } 268 | ``` 269 | 270 | In the query above, when we use `personId` instead of `pid` in the result or include `id` in the result we get following error message: 271 | 272 | ``` 273 | No type class instance was found for 274 | Selda.PG.Utils.ContainsOnlyColTypes (Cons "pid" t4 Nil) 275 | The instance head contains unknown type variables. Consider adding a type annotation. 276 | ``` 277 | 278 | Without knowing the implementation details this message is not really helpful. 279 | We can mitigate the problem with these error messages by providing a type annotation for the nested query or define it as top-level value. 280 | 281 | ```purescript 282 | -- top-level definition, type annotation omitted 283 | qBankAccountOwnerIds = 284 | aggregate $ selectFrom bankAccounts \{ id, personId } → do 285 | pid ← groupBy personId 286 | pure { pid: personId } -- (personId ∷ Col _ _) used instead of (pid ∷ Aggr _ _) 287 | ``` 288 | 289 | Now we encounter a custom type error that says: 290 | ``` 291 | field 'pid' is not aggregated. Its type should be 'Aggr _ _' 292 | ``` 293 | 294 | Let us consider another query that will find maximum balance for each person. 295 | We are going to do this intentionally wrong to show what happens if we try to execute it (We cover query execution in the [next chapter](#execution)). 296 | 297 | ```purescript 298 | qPersonsMaxBalance 299 | ∷ ∀ s. FullQuery s { pid ∷ Col s Int, maxBalance ∷ Aggr s (Maybe Int) } 300 | qPersonsMaxBalance = 301 | selectFrom people \{ id: pid } → do 302 | b ← leftJoin bankAccounts \b → b.personId .== pid 303 | balance ← notNull b.balance 304 | pure { pid, maxBalance: max_ balance } 305 | ``` 306 | 307 | In the query above we did not use the `groupBy` operation on the `personId` column, but we used the aggregate function `max_`. 308 | Every value in the resulting record has to be groupped by or come from aggregate function. 309 | When we try to execute `qPersonsMaxBalance`, we get the following error message: 310 | ``` 311 | A custom type error occurred while solving type class constraints: 312 | balance is not Col or the scope 's' is wrong 313 | ``` 314 | 315 | An inquisitive reader might spot that `maxBalance` is nullable despite that we called `notNull` on `balance` column. 316 | The aggregate function `max_` returns nullable values, because SQL's function `MAX` returns a null when the data set is empty and there is nothing to aggregate. 317 | 318 | ## Execution 319 | 320 | Now we will show how to execute queries and perform insert operations using `purescript-selda`. 321 | We perform these actions in a monad that satisfies three constraints: `MonadAff m, MonadError PGError m, MonadReader PostgreSQL.Connection m`. 322 | There is a provided 'shortcut' for these classes called `MonadSeldaPG m`. 323 | 324 | > **MonadSeldaPG vs Aff:**
325 | > To avoid monad stack one can use alternative functions in the `PG.Aff` module that work with plain monad `Aff`. 326 | 327 | In the example below, we'll use an incompatible monad stack with the `MonadSeldaPG` constraint to show what to do in this situation. 328 | Our Reader's context is a record and for an error type we use the polymorphic variant from [purescript-variant](https://github.com/natefaubion/purescript-variant). 329 | 330 | ```purescript 331 | type Context = 332 | { conn ∷ PostgreSQL.Connection 333 | , other ∷ String 334 | } 335 | type AppError = Variant 336 | ( pgError ∷ PGError 337 | , error ∷ String 338 | ) 339 | _pgError = Proxy ∷ Proxy "pgError" 340 | type App = ReaderT Context (ExceptT AppError Aff) 341 | 342 | runApp ∷ ∀ a. Context → App a → Aff (Either AppError a) 343 | runApp ctx m = runExceptT $ runReaderT m ctx 344 | ``` 345 | 346 | We define a hoist function that transforms a basic `MonadSeldaPG` stack instance into a more general one that will be suitable for our `App` monad. 347 | 348 | ```purescript 349 | hoistSeldaWith 350 | ∷ ∀ e m r 351 | . MonadAff m 352 | ⇒ MonadError e m 353 | ⇒ MonadReader r m 354 | ⇒ (PGError → e) 355 | → (r → PostgreSQL.Connection) 356 | → ExceptT PGError (ReaderT PostgreSQL.Connection Aff) ~> m 357 | hoistSeldaWith fe fr m = do 358 | conn ← asks fr 359 | runReaderT (runExceptT m) conn # liftAff 360 | >>= either (throwError <<< fe) pure 361 | 362 | hoistSelda 363 | ∷ ∀ e r m 364 | . MonadReader { conn ∷ PostgreSQL.Connection | r } m 365 | ⇒ MonadError (Variant ( pgError ∷ PGError | e )) m 366 | ⇒ MonadAff m 367 | ⇒ ExceptT PGError (ReaderT PostgreSQL.Connection Aff) ~> m 368 | hoistSelda = hoistSeldaWith (inj _pgError) (_.conn) 369 | ``` 370 | 371 | #### Query Pretty Printing 372 | To get a generated SQL string from a query we can use the following function. 373 | 374 | ```purescript 375 | generateSQLStringFromQuery 376 | ∷ ∀ s r 377 | . GetCols r 378 | ⇒ FullQuery s { | r } 379 | → String 380 | generateSQLStringFromQuery = showQuery >>> showPG >>> _.strQuery 381 | ``` 382 | 383 | Selda utilises prepared statements, so a query may contain parameters and placeholders for them in the generated SQL. 384 | Different backends handle it differently, that's why the generated SQL from the `showQuery` function is returned inside the monad `ShowM`. 385 | 386 | To run the `ShowM` computation we need to specify the backend. 387 | In our case we can use the predefined `showPG` function. 388 | We get as a result a record that contains the array of foreign parameters (here it is always empty, this functionality will be explained in an upcoming guide) and the expected generated SQL under the *"strQuery"* label. 389 | 390 | #### Execution 391 | 392 | ```purescript 393 | app ∷ App Unit 394 | app = do 395 | hoistSelda $ insert_ people 396 | [ { id: 1, name: "name1", age: Just 11 } 397 | , { id: 2, name: "name2", age: Just 22 } 398 | , { id: 3, name: "name3", age: Just 33 } 399 | ] 400 | ``` 401 | Let's start with some insert operations, so we have something in the database to work with. 402 | `hoistSelda` is needed to lift these operations into the `App` monad. 403 | 404 | ```purescript 405 | hoistSelda do 406 | insert_ bankAccounts 407 | [ { personId: 1, balance: 150 } -- we can't provide a value for `id` 408 | , { personId: 3, balance: 300 } 409 | ] 410 | insert_ bankAccounts 411 | [ { personId: 1 } ] -- `balance` omitted, the database will use its default value 412 | ``` 413 | We leverage the capabilities of the `Auto` and `Default` table constraints. 414 | It is forbidden to provide `id` column since its value should be assigned by the database. 415 | We can either specify a value for `balance` column or leave it empty and let database handle it. 416 | 417 | ```purescript 418 | hoistSelda do 419 | -- shortcut for the `generateSQLStringFromQuery` 420 | let str = generateSQLStringFromQuery 421 | 422 | log $ str qNamesWithBalance 423 | query qNamesWithBalance >>= logShow 424 | ``` 425 | We execute a query by calling `query` and as a result we get an array of records. 426 | We can also get SQL string literal from a query using the `str` helper function. 427 | ```purescript 428 | log $ str qBankAccountOwnersWithBalance 429 | query qBankAccountOwnersWithBalance >>= logShow 430 | 431 | log $ str qCountBankAccountOwners 432 | query qCountBankAccountOwners >>= logShow 433 | 434 | -- query qPersonsMaxBalance >>= logShow 435 | -- TYPE ERROR 436 | ``` 437 | 438 | Now we will finally write the `main` that will interpret our `app`. 439 | We start by preparing a connection to the database (We use here predefined test `Config.load` helper 440 | which reads the environment (or `.env` file) for pg connection info and builds a pool for us). 441 | 442 | 443 | ```purescript 444 | main ∷ Effect Unit 445 | main = launchWithConnectionPG \conn → do 446 | ``` 447 | When we've got the connection we can create the database tables and then run our monad stack. 448 | ```purescript 449 | createPeople conn 450 | createBankAccounts conn 451 | runApp { conn, other: "other" } app >>= either logShow pure 452 | 453 | launchWithConnectionPG ∷ (PostgreSQL.Connection → Aff Unit) → Effect Unit 454 | launchWithConnectionPG m = do 455 | launchAff_ do 456 | pool ← Config.load 457 | PostgreSQL.Aff.withConnection pool case _ of 458 | Left pgError → logShow ("PostgreSQL connection error: " <> show pgError) 459 | Right conn → do 460 | ``` 461 | We are going to wrap everything in a transaction and do a rollback at the end because it is only for testing purposes. 462 | ```purescript 463 | execute "BEGIN TRANSACTION" conn 464 | res ← Aff.try $ m conn 465 | execute "ROLLBACK TRANSACTION" conn 466 | either throwError pure res 467 | ``` 468 | --------------------------------------------------------------------------------