├── .github └── workflows │ └── run-tests.yml ├── .gitignore ├── ChangeLog.hs ├── LICENSE ├── Makefile ├── README.md ├── cabal.project ├── default.nix ├── pgtest-compose.yml ├── selda-build-tools.cabal ├── selda-json ├── selda-json.cabal └── src │ └── Database │ └── Selda │ └── JSON.hs ├── selda-postgresql ├── Setup.hs ├── default.nix ├── selda-postgresql.cabal └── src │ └── Database │ └── Selda │ ├── PostgreSQL.hs │ └── PostgreSQL │ └── Encoding.hs ├── selda-sqlite ├── Setup.hs ├── default.nix ├── selda-sqlite.cabal └── src │ └── Database │ └── Selda │ ├── SQLite.hs │ └── SQLite │ └── Parser.hs ├── selda-tests ├── LICENSE ├── PGConnectInfo.hs ├── default.nix ├── selda-tests.cabal └── test │ ├── RunTests.hs │ ├── Tables.hs │ ├── Tests │ ├── JSON.hs │ ├── MultiConn.hs │ ├── Mutable.hs │ ├── NonDB.hs │ ├── PGConnectionString.hs │ ├── Query.hs │ └── Validation.hs │ └── Utils.hs ├── selda ├── Setup.hs ├── default.nix ├── selda.cabal └── src │ └── Database │ ├── Selda.hs │ └── Selda │ ├── Backend.hs │ ├── Backend │ └── Internal.hs │ ├── Column.hs │ ├── Compile.hs │ ├── Debug.hs │ ├── Exp.hs │ ├── FieldSelectors.hs │ ├── Frontend.hs │ ├── Generic.hs │ ├── Inner.hs │ ├── MakeSelectors.hs │ ├── Migrations.hs │ ├── Nullable.hs │ ├── Prepared.hs │ ├── Query.hs │ ├── Query │ └── Type.hs │ ├── SQL.hs │ ├── SQL │ ├── Print.hs │ └── Print │ │ └── Config.hs │ ├── Selectors.hs │ ├── SqlRow.hs │ ├── SqlType.hs │ ├── Table.hs │ ├── Table │ ├── Compile.hs │ ├── Type.hs │ └── Validation.hs │ ├── Transform.hs │ ├── Types.hs │ ├── Unsafe.hs │ └── Validation.hs ├── stack-ghc-9.0.yaml ├── stack-ghc-9.2.yaml ├── stack.yaml └── website ├── assets ├── prism.css ├── prism.js ├── robots.txt ├── selda.png └── style.css ├── cabal.project ├── compile.hs ├── pages ├── index.md ├── tutorial.md └── tutorial │ ├── ch1-example-explained.md │ ├── ch2-destructive-operations.md │ └── ch3-advanced-queries.md ├── templates └── default.html └── website.cabal /.github/workflows/run-tests.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | matrix: 13 | ghc: ['8.8.2', '8.10.1', '9.2.5', '9.4.4'] 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v2 17 | - uses: actions/setup-haskell@v1 18 | with: 19 | ghc-version: ${{ matrix.ghc }} 20 | cabal-version: '3.2' 21 | - uses: harmon758/postgresql-action@v1 22 | with: 23 | postgresql version: '13' 24 | postgresql db: 'test' 25 | postgresql user: 'postgres' 26 | postgresql password: 'password' 27 | 28 | - name: Cache 29 | uses: actions/cache@v1 30 | env: 31 | cache-name: cache-cabal 32 | with: 33 | path: ~/.cabal 34 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 35 | restore-keys: | 36 | ${{ runner.os }}-build-${{ env.cache-name }}- 37 | ${{ runner.os }}-build- 38 | ${{ runner.os }}- 39 | 40 | - name: Install dependencies 41 | run: | 42 | cabal v2-update 43 | cabal v2-build --only-dependencies --enable-tests --enable-benchmarks 44 | - name: Run checks 45 | run: | 46 | cp ./README.md ./selda/README.md 47 | make license 48 | cabal v2-run selda-changelog md 49 | make check 50 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | *~ 3 | *.hi 4 | *.o 5 | dist 6 | #* 7 | /selda/README.md 8 | /selda/ChangeLog.md 9 | /website/BaseUrl.hs 10 | /website/_site 11 | /*/LICENSE 12 | dist-newstyle 13 | cabal.project.local 14 | .stack-work/ 15 | /stack*.yaml.lock 16 | *.sqlite 17 | !.gitignore 18 | !.github 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017-2019 Anton Ekblad 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGES=selda selda-sqlite selda-postgresql selda-json 2 | .PHONY: help build license haddock check test selda json pgtest pgtest-docker sqlite postgres repl upload-selda upload 3 | CABAL_BUILDFLAGS ?= 4 | CABAL ?= cabal 5 | 6 | help: 7 | @echo "Available targets:" 8 | @echo "build - build packages" 9 | @echo "test - build packages and run tests with SQLite" 10 | @echo "pgtest - build packages and run tests with PostgreSQL" 11 | @echo "pgtest-docker - build packages and run tests with a Docker PostgreSQL image" 12 | @echo "repl - start ghci" 13 | @echo "check - build package, run tests, do a cabal sanity check" 14 | @echo "selda - build core Selda package" 15 | @echo "sqlite - build sqlite backend" 16 | @echo "json - build json extensions" 17 | @echo "postgres - build postgres backend" 18 | @echo "upload - upload packages to Hackage" 19 | @echo "upload-selda - upload only the main selda package" 20 | @echo "haddock - build Haddock docs" 21 | 22 | build: selda sqlite postgres json 23 | 24 | license: 25 | for package in $(PACKAGES) ; do \ 26 | cp -f ./LICENSE ./$$package/LICENSE ; \ 27 | done 28 | 29 | haddock: 30 | ${CABAL} v2-haddock $(PACKAGES) 31 | 32 | check: test pgtest haddock 33 | ${CABAL} v2-run selda-changelog md 34 | ${CABAL} v2-clean 35 | for pkg in $(PACKAGES) ; do \ 36 | cd $$pkg ; \ 37 | ${CABAL} check ; \ 38 | cd .. ; \ 39 | done 40 | ${CABAL} v2-sdist $(PACKAGES) 41 | ${CABAL} v2-configure -f-localcache selda 42 | ${CABAL} v2-build selda 43 | 44 | test: selda sqlite 45 | cd ./selda-tests && ${CABAL} v2-configure --enable-tests $(CABAL_BUILDFLAGS) 46 | cd ./selda-tests && ${CABAL} v2-test $(CABAL_BUILDFLAGS) 47 | 48 | pgtest: selda postgres 49 | cd ./selda-tests && ${CABAL} v2-configure --enable-tests -fpostgres $(CABAL_BUILDFLAGS) 50 | cd ./selda-tests && ${CABAL} v2-test $(CABAL_BUILDFLAGS) 51 | 52 | pgtest-docker: selda postgres .has_postgres_docker_image 53 | docker run --rm --name selda-postgres -p 5432:5432 -e POSTGRES_PASSWORD=password -d docker.io/postgres 54 | cd ./selda-tests && ${CABAL} v2-configure --enable-tests -fpostgres $(CABAL_BUILDFLAGS) 55 | cd ./selda-tests && ${CABAL} v2-test $(CABAL_BUILDFLAGS) 56 | docker stop selda-postgres 57 | 58 | .has_postgres_docker_image: 59 | docker pull docker.io/postgres 60 | touch .has_postgres_docker_image 61 | 62 | selda: license 63 | cp -f README.md ./selda/README.md 64 | ${CABAL} v2-build selda $(CABAL_BUILDFLAGS) 65 | 66 | json: license 67 | ${CABAL} v2-build selda-json $(CABAL_BUILDFLAGS) 68 | 69 | sqlite: license 70 | ${CABAL} v2-build selda-sqlite $(CABAL_BUILDFLAGS) 71 | 72 | postgres: license 73 | ${CABAL} v2-build selda-postgresql $(CABAL_BUILDFLAGS) 74 | 75 | repl: 76 | ${CABAL} v2-repl --ghc-options="-XOverloadedStrings" selda-sqlite $(CABAL_BUILDFLAGS) 77 | 78 | upload-selda: check 79 | ${CABAL} v2-run selda-changelog validate 80 | ${CABAL} v2-run selda-changelog tag 81 | ${CABAL} upload ./dist-newstyle/sdist/selda-0.*.tar.gz 82 | git push 83 | git push --tags 84 | 85 | upload: check 86 | ${CABAL} v2-run selda-changelog validate 87 | ${CABAL} v2-run selda-changelog tag 88 | ${CABAL} upload $$(for pkg in $(PACKAGES) ; do echo ./dist-newstyle/sdist/$$pkg-0.*.tar.gz ; done) 89 | git push 90 | git push --tags 91 | echo "All done!" 92 | echo "Don't forget to publish the package RCs and draft a GitHub release." 93 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Selda 2 | ===== 3 | 4 | [![Join the chat at https://gitter.im/selda-hs/Lobby](https://badges.gitter.im/selda-hs/Lobby.svg)](https://gitter.im/selda-hs/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 5 | [![Hackage](https://img.shields.io/hackage/v/selda.svg?style=flat)](http://hackage.haskell.org/package/selda) 6 | [![IRC channel](https://img.shields.io/badge/IRC-%23selda-1e72ff.svg?style=flat)](https://www.irccloud.com/invite?channel=%23selda&hostname=irc.freenode.net&port=6697&ssl=1) 7 | ![MIT License](http://img.shields.io/badge/license-MIT-brightgreen.svg) 8 | ![Haskell CI](https://github.com/valderman/selda/workflows/Haskell%20CI/badge.svg) 9 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/selda.svg)](https://packdeps.haskellers.com/feed?needle=selda) 10 | 11 | 12 | What is Selda? 13 | ============== 14 | [Selda](https://selda.link) is a Haskell library for interacting with SQL-based relational databases. 15 | It was inspired by [LINQ](https://en.wikipedia.org/wiki/Language_Integrated_Query) and 16 | [Opaleye](http://hackage.haskell.org/package/opaleye). 17 | 18 | 19 | Features 20 | ======== 21 | 22 | * Monadic interface. 23 | * Portable: backends for SQLite and PostgreSQL. 24 | * Generic: easy integration with your existing Haskell types. 25 | * Creating, dropping and querying tables using type-safe database schemas. 26 | * Typed query language with products, filtering, joins and aggregation. 27 | * Inserting, updating and deleting rows from tables. 28 | * Conditional insert/update. 29 | * Transactions, uniqueness constraints and foreign keys. 30 | * Type-safe, backend-specific functionality, such as JSON lookups. 31 | * Seamless prepared statements. 32 | * Lightweight and modular: few dependencies, and non-essential features are 33 | optional or split into add-on packages. 34 | 35 | 36 | Getting started 37 | =============== 38 | 39 | Install the `selda` package from Hackage, as well as at least one of the 40 | backends: 41 | 42 | $ cabal update 43 | $ cabal install selda selda-sqlite selda-postgresql 44 | 45 | Then, read [the tutorial](https://selda.link/tutorial). 46 | The [API documentation](http://hackage.haskell.org/package/selda) will probably 47 | also come in handy. 48 | 49 | 50 | Requirements 51 | ============ 52 | 53 | Selda requires GHC 8.0+, as well as SQLite 3.7.11+ or PostgreSQL 9.4+. 54 | To build the SQLite backend, you need a C compiler installed. 55 | To build the PostgreSQL backend, you need the `libpq` development libraries 56 | installed (`libpq-dev` on Debian-based Linux distributions). 57 | 58 | Hacking 59 | ======= 60 | 61 | Contributing 62 | ------------ 63 | 64 | All forms of contributions are welcome! 65 | 66 | If you have a bug to report, please try to include as much information as 67 | possible, preferably including: 68 | 69 | * A brief description (one or two sentences) of the bug. 70 | * The version of Selda+backend where the bug was found. 71 | * A step-by-step guide to reproduce the bug. 72 | * The *expected* result from following these steps. 73 | * What *actually* happens when following the steps. 74 | * Which component contains the bug (selda, selda-sqlite or selda-postgresql), 75 | if you're reasonably sure about where the bug is. 76 | 77 | Bonus points for a small code example that illustrates the problem. 78 | 79 | If you want to contribute code, please consult the following checklist before 80 | sending a pull request: 81 | 82 | * Does the code build with a recent version of GHC? 83 | * Do all the tests pass? 84 | * Have you added any tests covering your code? 85 | 86 | If you want to contribute code but don't really know where to begin, 87 | issues tagged [good first issue](https://github.com/valderman/selda/issues?q=is%3Aissue+is%3Aopen+label%3A%22good+first+issue%22) are a good start. 88 | 89 | 90 | Setting up the build environment 91 | -------------------------------- 92 | 93 | From the repository root: 94 | 95 | * Install `libpq-dev` from your package manager. 96 | This is required to build the PostgreSQL backend. 97 | * Make sure you're running a cabal version that supports v2-style commands. 98 | * Familiarise yourself with the various targets in the makefile. 99 | The dependencies between Selda, the backends and the tests are slightly 100 | complex, so straight-up cabal is too quirky for day to day hacking. 101 | 102 | 103 | PostgreSQL backend testing with Docker 104 | -------------------------------------- 105 | 106 | To test the PostgreSQL backend, use the provided `pgtest-compose.yml` docker-compose file: 107 | ``` 108 | sudo docker-compose -f pgtest-compose.yml up -d 109 | make pgtest 110 | sudo docker-compose -f pgtest-compose.yml down 111 | ``` 112 | 113 | 114 | TODOs 115 | ----- 116 | 117 | Features that would be nice to have but are not yet implemented. 118 | 119 | * Monadic if/else 120 | * Streaming 121 | * MySQL/MariaDB backend 122 | * MSSQL backend 123 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | selda/ 3 | selda-sqlite/ 4 | selda-postgresql/ 5 | selda-tests/ 6 | selda-json/ 7 | ./ -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {}, compiler ? "ghc863" }: 2 | let 3 | hps = pkgs.haskell.packages.${compiler}.override { 4 | overrides = self: super: with pkgs.haskell.lib; { 5 | selda = self.callPackage ./selda {}; 6 | selda-postgresql = self.callPackage ./selda-postgresql {}; 7 | selda-sqlite = self.callPackage ./selda-sqlite {}; 8 | selda-tests = dontHaddock (self.callPackage ./selda-tests {}); 9 | }; 10 | }; 11 | in with hps; { 12 | inherit selda selda-postgresql selda-tests selda-sqlite; 13 | } -------------------------------------------------------------------------------- /pgtest-compose.yml: -------------------------------------------------------------------------------- 1 | version: "3" 2 | services: 3 | postgres: 4 | image: postgres:11 5 | container_name: pgtest 6 | ports: 7 | - "127.0.0.1:5432:5432" 8 | environment: 9 | - POSTGRES_DB=test 10 | - POSTGRES_USER=postgres 11 | - POSTGRES_PASSWORD=password 12 | -------------------------------------------------------------------------------- /selda-build-tools.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: selda-build-tools 3 | version: 0.1.0.0 4 | license: MIT 5 | author: Anton Ekblad 6 | maintainer: anton@ekblad.cc 7 | build-type: Simple 8 | 9 | executable selda-changelog 10 | main-is: ChangeLog.hs 11 | build-depends: 12 | base >=4.8 && <5, 13 | time >=1.5 && <1.10, 14 | filepath >=1.4 && <1.5, 15 | process >=1.5 && <1.7 16 | default-language: Haskell2010 17 | -------------------------------------------------------------------------------- /selda-json/selda-json.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: selda-json 3 | version: 0.1.1.1 4 | synopsis: JSON support for the Selda database library. 5 | description: Types and classes to support storing and querying 6 | JSON values using Selda via Aeson. 7 | homepage: https://selda.link 8 | -- bug-reports: 9 | license: MIT 10 | author: Anton Ekblad 11 | maintainer: anton@ekblad.cc 12 | -- copyright: 13 | category: Database 14 | build-type: Simple 15 | 16 | library 17 | exposed-modules: 18 | Database.Selda.JSON 19 | build-depends: 20 | aeson >=1.0 && <2.2 21 | , base >=4.9 && <5 22 | , bytestring >=0.10 && <0.12 23 | , selda >=0.4 && <0.6 24 | , text >=1.0 && <2.1 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | -------------------------------------------------------------------------------- /selda-json/src/Database/Selda/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, OverloadedStrings #-} 2 | module Database.Selda.JSON (JSONBackend (..)) where 3 | import Database.Selda (Text, Col, Inner) 4 | import Database.Selda.Backend 5 | import Database.Selda.Unsafe (sink, sink2) 6 | import Data.Aeson (Value (Null), encode, decode', FromJSON (..), ToJSON (..)) 7 | import qualified Data.ByteString.Lazy as BSL (ByteString, fromStrict, toStrict) 8 | import Data.Text.Encoding (encodeUtf8) 9 | 10 | class JSONValue a 11 | instance JSONValue Value 12 | instance JSONValue a => JSONValue (Maybe a) 13 | 14 | -- | Any backend that supports JSON lookups in queries. 15 | class JSONBackend b where 16 | -- | Look up the given key in the given JSON column. 17 | (~>) :: JSONValue a => Col b a -> Col b Text -> Col b (Maybe Value) 18 | infixl 8 ~> 19 | 20 | -- | Convert the given JSON column to plain text. 21 | jsonToText :: Col b Value -> Col b Text 22 | 23 | instance JSONBackend b => JSONBackend (Inner b) where 24 | (~>) = sink2 (~>) 25 | jsonToText = sink jsonToText 26 | 27 | decodeError :: Show a => a -> b 28 | decodeError x = error $ "fromSql: json column with invalid json: " ++ show x 29 | 30 | typeError :: Show a => a -> b 31 | typeError x = error $ "fromSql: json column with non-text value: " ++ show x 32 | 33 | textToLazyBS :: Text -> BSL.ByteString 34 | textToLazyBS = BSL.fromStrict . encodeUtf8 35 | 36 | instance SqlType Value where 37 | mkLit = LCustom TJSON . LBlob . BSL.toStrict . encode 38 | sqlType _ = TJSON 39 | defaultValue = mkLit Null 40 | fromSql (SqlBlob t) = maybe (decodeError t) id (decode' $ BSL.fromStrict t) 41 | fromSql (SqlString t) = maybe (decodeError t) id (decode' $ textToLazyBS t) 42 | fromSql x = typeError x 43 | 44 | instance FromJSON RowID where 45 | parseJSON = fmap toRowId . parseJSON 46 | instance ToJSON RowID where 47 | toJSON = toJSON . fromRowId 48 | 49 | instance FromJSON (ID a) where 50 | parseJSON = fmap toId . parseJSON 51 | instance ToJSON (ID a) where 52 | toJSON = toJSON . fromId 53 | -------------------------------------------------------------------------------- /selda-postgresql/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /selda-postgresql/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, exceptions, postgresql-libpq 2 | , selda, stdenv, text 3 | }: 4 | mkDerivation { 5 | pname = "selda-postgresql"; 6 | version = "0.1.8.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base bytestring exceptions postgresql-libpq selda text 10 | ]; 11 | homepage = "https://selda.link"; 12 | description = "PostgreSQL backend for the Selda database EDSL"; 13 | license = stdenv.lib.licenses.mit; 14 | } 15 | -------------------------------------------------------------------------------- /selda-postgresql/selda-postgresql.cabal: -------------------------------------------------------------------------------- 1 | name: selda-postgresql 2 | version: 0.1.8.2 3 | synopsis: PostgreSQL backend for the Selda database EDSL. 4 | description: PostgreSQL backend for the Selda database EDSL. 5 | Requires the PostgreSQL @libpq@ development libraries to be 6 | installed. 7 | homepage: https://github.com/valderman/selda 8 | license: MIT 9 | author: Anton Ekblad 10 | maintainer: anton@ekblad.cc 11 | category: Database 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | flag haste 16 | default: False 17 | description: Package is being installed for Haste. 18 | 19 | library 20 | exposed-modules: 21 | Database.Selda.PostgreSQL 22 | other-modules: 23 | Database.Selda.PostgreSQL.Encoding 24 | other-extensions: 25 | GADTs 26 | RecordWildCards 27 | OverloadedStrings 28 | CPP 29 | build-depends: 30 | base >=4.9 && <5 31 | , bytestring >=0.9 && <0.12 32 | , exceptions >=0.8 && <0.11 33 | , selda >=0.5 && <0.6 34 | , selda-json >=0.1 && <0.2 35 | , text >=1.0 && <2.1 36 | if !flag(haste) 37 | build-depends: 38 | postgresql-binary >=0.12 && <0.13 39 | , postgresql-libpq >=0.9 && <0.10 40 | , time >=1.5 && <1.13 41 | , uuid-types >=1.0 && <1.1 42 | hs-source-dirs: 43 | src 44 | default-language: 45 | Haskell2010 46 | ghc-options: 47 | -Wall 48 | -------------------------------------------------------------------------------- /selda-postgresql/src/Database/Selda/PostgreSQL/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, BangPatterns, OverloadedStrings, CPP #-} 2 | -- | Encoding/decoding for PostgreSQL. 3 | module Database.Selda.PostgreSQL.Encoding 4 | ( toSqlValue, fromSqlValue, fromSqlType, readInt64, readBool 5 | ) where 6 | #ifdef __HASTE__ 7 | 8 | toSqlValue, fromSqlValue, fromSqlType, readInt64, readBool :: a 9 | toSqlValue = undefined 10 | fromSqlValue = undefined 11 | fromSqlType = undefined 12 | readInt64 = undefined 13 | readBool = undefined 14 | 15 | #else 16 | 17 | import Control.Applicative ((<|>)) 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Lazy as LBS 20 | import Data.Char (toLower) 21 | import qualified Data.Text as T 22 | import Data.Time (utc, localToUTCTimeOfDay) 23 | import Database.PostgreSQL.LibPQ (Oid (..), Format (Binary)) 24 | import Database.Selda.Backend 25 | import PostgreSQL.Binary.Encoding as Enc 26 | import PostgreSQL.Binary.Decoding as Dec 27 | import qualified Data.UUID.Types as UUID (toByteString) 28 | import Data.Int (Int16, Int32, Int64) 29 | 30 | -- | OIDs for all types used by Selda. 31 | blobType, boolType, intType, int32Type, int16Type, textType, doubleType, 32 | dateType, timeType, timestampType, nameType, varcharType, uuidType, 33 | jsonbType :: Oid 34 | boolType = Oid 16 35 | intType = Oid 20 36 | int32Type = Oid 23 37 | int16Type = Oid 21 38 | textType = Oid 25 39 | nameType = Oid 19 40 | doubleType = Oid 701 41 | dateType = Oid 1082 42 | timeType = Oid 1266 43 | timestampType = Oid 1184 44 | blobType = Oid 17 45 | varcharType = Oid 1043 46 | uuidType = Oid 2950 47 | jsonbType = Oid 3802 48 | 49 | bytes :: Enc.Encoding -> BS.ByteString 50 | bytes = Enc.encodingBytes 51 | 52 | -- | Convert a parameter into an postgres parameter triple. 53 | fromSqlValue :: Lit a -> Maybe (Oid, BS.ByteString, Format) 54 | fromSqlValue (LBool b) = Just (boolType, bytes $ Enc.bool b, Binary) 55 | fromSqlValue (LInt64 n) = Just ( intType 56 | , bytes $ Enc.int8_int64 $ fromIntegral n 57 | , Binary) 58 | fromSqlValue (LInt32 n) = Just ( int32Type 59 | , bytes $ Enc.int4_int32 $ fromIntegral n 60 | , Binary) 61 | fromSqlValue (LDouble f) = Just (doubleType, bytes $ Enc.float8 f, Binary) 62 | fromSqlValue (LText s) = Just (textType, bytes $ Enc.text_strict s, Binary) 63 | fromSqlValue (LDateTime t) = Just ( timestampType 64 | , bytes $ Enc.timestamptz_int t 65 | , Binary) 66 | fromSqlValue (LTime t) = Just (timeType, bytes $ Enc.timetz_int (t, utc), Binary) 67 | fromSqlValue (LDate d) = Just (dateType, bytes $ Enc.date d, Binary) 68 | fromSqlValue (LUUID x) = Just (uuidType, bytes $ Enc.uuid x, Binary) 69 | fromSqlValue (LBlob b) = Just (blobType, bytes $ Enc.bytea_strict b, Binary) 70 | fromSqlValue (LNull) = Nothing 71 | fromSqlValue (LJust x) = fromSqlValue x 72 | fromSqlValue (LCustom TJSON (LBlob b)) = Just ( jsonbType 73 | , bytes $ Enc.jsonb_bytes b 74 | , Binary) 75 | fromSqlValue (LCustom _ l) = fromSqlValue l 76 | 77 | -- | Get the corresponding OID for an SQL type representation. 78 | fromSqlType :: SqlTypeRep -> Oid 79 | fromSqlType TBool = boolType 80 | fromSqlType TInt64 = intType 81 | fromSqlType TInt32 = int32Type 82 | fromSqlType TFloat = doubleType 83 | fromSqlType TText = textType 84 | fromSqlType TDateTime = timestampType 85 | fromSqlType TDate = dateType 86 | fromSqlType TTime = timeType 87 | fromSqlType TBlob = blobType 88 | fromSqlType TRowID = intType 89 | fromSqlType TUUID = uuidType 90 | fromSqlType TJSON = jsonbType 91 | 92 | -- | Convert the given postgres return value and type to an @SqlValue@. 93 | toSqlValue :: Oid -> BS.ByteString -> SqlValue 94 | toSqlValue t val 95 | | t == boolType = SqlBool $ parse Dec.bool val 96 | | t == intType = SqlInt64 $ parse (Dec.int :: Value Int64) val 97 | | t == int32Type = SqlInt32 $ parse (Dec.int :: Value Int32) val 98 | | t == int16Type = SqlInt32 $ fromIntegral $ parse (Dec.int :: Value Int16) val 99 | | t == doubleType = SqlFloat $ parse Dec.float8 val 100 | | t == blobType = SqlBlob $ parse Dec.bytea_strict val 101 | | t == uuidType = SqlBlob $ uuid2bs $ parse Dec.uuid val 102 | | t == timestampType = SqlUTCTime $ parse parseTimestamp val 103 | | t == timeType = SqlTime $ toTime $ parse parseTime val 104 | | t == dateType = SqlDate $ parse Dec.date val 105 | | t == jsonbType = SqlBlob $ parse (Dec.jsonb_bytes pure) val 106 | | t `elem` textish = SqlString $ parse Dec.text_strict val 107 | | otherwise = error $ "BUG: result with unknown type oid: " ++ show t 108 | where 109 | parseTimestamp = Dec.timestamptz_int <|> Dec.timestamptz_float 110 | parseTime = Dec.timetz_int <|> Dec.timetz_float 111 | toTime (tod, tz) = snd $ localToUTCTimeOfDay tz tod 112 | uuid2bs = LBS.toStrict . UUID.toByteString 113 | textish = [textType, nameType, varcharType] 114 | 115 | parse :: Value a -> BS.ByteString -> a 116 | parse p x = 117 | case valueParser p x of 118 | Right x' -> x' 119 | Left _ -> error "unable to decode value" 120 | 121 | -- | Read an Int from a binary encoded pgint8. 122 | readInt64 :: BS.ByteString -> Int64 123 | readInt64 = parse (Dec.int :: Value Int64) 124 | 125 | readBool :: T.Text -> Bool 126 | readBool = go . T.map toLower 127 | where 128 | go "f" = False 129 | go "0" = False 130 | go "false" = False 131 | go "n" = False 132 | go "no" = False 133 | go "off" = False 134 | go _ = True 135 | 136 | #endif 137 | -------------------------------------------------------------------------------- /selda-sqlite/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /selda-sqlite/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, direct-sqlite, exceptions, selda, stdenv 2 | , text 3 | }: 4 | mkDerivation { 5 | pname = "selda-sqlite"; 6 | version = "0.1.7.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base direct-sqlite exceptions selda text 10 | ]; 11 | homepage = "https://selda.link"; 12 | description = "SQLite backend for the Selda database EDSL"; 13 | license = stdenv.lib.licenses.mit; 14 | } 15 | -------------------------------------------------------------------------------- /selda-sqlite/selda-sqlite.cabal: -------------------------------------------------------------------------------- 1 | name: selda-sqlite 2 | version: 0.1.7.2 3 | synopsis: SQLite backend for the Selda database EDSL. 4 | description: Allows the Selda database EDSL to be used with SQLite 5 | databases. 6 | homepage: https://github.com/valderman/selda 7 | license: MIT 8 | author: Anton Ekblad 9 | maintainer: anton@ekblad.cc 10 | category: Database 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | flag haste 15 | default: False 16 | description: Package is being installed for Haste. 17 | 18 | library 19 | exposed-modules: 20 | Database.Selda.SQLite 21 | other-modules: 22 | Database.Selda.SQLite.Parser 23 | other-extensions: 24 | GADTs 25 | CPP 26 | build-depends: 27 | base >=4.9 && <5 28 | , selda >=0.5 && <0.6 29 | , text >=1.0 && <2.1 30 | if !flag(haste) 31 | build-depends: 32 | bytestring >=0.10 && <0.12 33 | , direct-sqlite >=2.2 && <2.4 34 | , directory >=1.2.2 && <1.4 35 | , exceptions >=0.8 && <0.11 36 | , time >=1.5 && <1.13 37 | , uuid-types >=1.0 && <1.1 38 | hs-source-dirs: 39 | src 40 | default-language: 41 | Haskell2010 42 | ghc-options: 43 | -Wall 44 | -------------------------------------------------------------------------------- /selda-sqlite/src/Database/Selda/SQLite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, CPP, OverloadedStrings #-} 2 | -- | SQLite3 backend for Selda. 3 | module Database.Selda.SQLite 4 | ( SQLite 5 | , withSQLite 6 | , sqliteOpen, seldaClose 7 | , sqliteBackend 8 | ) where 9 | import Database.Selda 10 | import Database.Selda.Backend 11 | import Database.Selda.SQLite.Parser 12 | import Data.Maybe (fromJust) 13 | #ifndef __HASTE__ 14 | import Control.Monad (void, when, unless) 15 | import Control.Monad.Catch 16 | import Data.ByteString.Lazy (toStrict) 17 | import Data.Dynamic 18 | import Data.Int (Int64) 19 | import Data.Text as Text (pack, toLower, take) 20 | import Data.Time (FormatTime, formatTime, defaultTimeLocale) 21 | import Data.UUID.Types (toByteString) 22 | import Database.SQLite3 23 | import System.Directory (makeAbsolute) 24 | #endif 25 | 26 | data SQLite 27 | 28 | -- | Open a new connection to an SQLite database. 29 | -- The connection is reusable across calls to `runSeldaT`, and must be 30 | -- explicitly closed using 'seldaClose' when no longer needed. 31 | sqliteOpen :: (MonadIO m, MonadMask m) => FilePath -> m (SeldaConnection SQLite) 32 | #ifdef __HASTE__ 33 | sqliteOpen _ = error "sqliteOpen called in JS context" 34 | #else 35 | sqliteOpen file = do 36 | mask $ \restore -> do 37 | edb <- try $ liftIO $ open (pack file) 38 | case edb of 39 | Left e@(SQLError{}) -> do 40 | throwM (DbError (show e)) 41 | Right db -> flip onException (liftIO (close db)) . restore $ do 42 | absFile <- liftIO $ pack <$> makeAbsolute file 43 | let backend = sqliteBackend db 44 | void . liftIO $ runStmt backend "PRAGMA foreign_keys = ON;" [] 45 | newConnection backend absFile 46 | #endif 47 | 48 | -- | Perform the given computation over an SQLite database. 49 | -- The database is guaranteed to be closed when the computation terminates. 50 | withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT SQLite m a -> m a 51 | #ifdef __HASTE__ 52 | withSQLite _ _ = return $ error "withSQLite called in JS context" 53 | 54 | sqliteBackend :: a -> SeldaBackend 55 | sqliteBackend _ = error "sqliteBackend called in JS context" 56 | #else 57 | withSQLite file m = bracket (sqliteOpen file) seldaClose (runSeldaT m) 58 | 59 | -- | Create a Selda backend using an already open database handle. 60 | -- This is useful for situations where you want to use some SQLite-specific 61 | -- functionality alongside Selda. 62 | -- 63 | -- Note that manipulating the underlying database handle directly voids 64 | -- any and all safety guarantees made by the Selda API. 65 | -- Caching functionality in particular WILL break. 66 | -- Proceed with extreme caution. 67 | sqliteBackend :: Database -> SeldaBackend SQLite 68 | sqliteBackend db = SeldaBackend 69 | { runStmt = \q ps -> snd <$> sqliteQueryRunner db q ps 70 | , runStmtWithPK = \q ps -> fst <$> sqliteQueryRunner db q ps 71 | , prepareStmt = \_ _ -> sqlitePrepare db 72 | , runPrepared = sqliteRunPrepared db 73 | , getTableInfo = sqliteGetTableInfo db . fromTableName 74 | , ppConfig = defPPConfig {ppMaxInsertParams = Just 999} 75 | , backendId = SQLite 76 | , closeConnection = \conn -> do 77 | stmts <- allStmts conn 78 | flip mapM_ stmts $ \(_, stm) -> do 79 | finalize $ fromDyn stm (error "BUG: non-statement SQLite statement") 80 | close db 81 | , disableForeignKeys = disableFKs db 82 | } 83 | 84 | sqliteGetTableInfo :: Database -> Text -> IO TableInfo 85 | sqliteGetTableInfo db tbl = do 86 | cols <- (snd . snd) <$> sqliteQueryRunner db tblinfo [] 87 | fks <- (snd . snd) <$> sqliteQueryRunner db fklist [] 88 | createQuery <- (snd . snd) <$> sqliteQueryRunner db autos [] 89 | let cs = case createQuery of 90 | [[SqlString q]] -> colsFromQuery q 91 | _ -> [] 92 | ixs <- mapM indexInfo . snd . snd =<< sqliteQueryRunner db indexes [] 93 | colInfos <- mapM (describe fks ixs cs) cols 94 | return $ TableInfo 95 | { tableInfoName = mkTableName tbl 96 | , tableColumnInfos = colInfos 97 | , tableUniqueGroups = 98 | [ map mkColName names 99 | | (names, "u") <- ixs 100 | ] 101 | , tablePrimaryKey = concat 102 | [ concat 103 | [ map mkColName names 104 | | (names, "pk") <- ixs 105 | ] 106 | , [ colName ci 107 | | ci <- colInfos 108 | , colIsAutoPrimary ci 109 | ] 110 | ] 111 | } 112 | where 113 | tblinfo = mconcat ["PRAGMA table_info(", tbl, ");"] 114 | indexes = mconcat ["PRAGMA index_list(", tbl, ");"] 115 | fklist = mconcat ["PRAGMA foreign_key_list(", tbl, ");"] 116 | autos = mconcat ["SELECT sql FROM sqlite_master WHERE name = ", tbl, ";"] 117 | ixinfo name = mconcat ["PRAGMA index_info(", name, ");"] 118 | 119 | toTypeRep _ "text" = Right TText 120 | toTypeRep _ "double precision" = Right TFloat 121 | toTypeRep _ "double" = Right TFloat 122 | toTypeRep _ "boolean" = Right TBool 123 | toTypeRep _ "datetime" = Right TDateTime 124 | toTypeRep _ "date" = Right TDate 125 | toTypeRep _ "time" = Right TTime 126 | toTypeRep _ "blob" = Right TBlob 127 | toTypeRep True "integer" = Right TRowID 128 | toTypeRep pk s | Text.take 6 s == "bigint" = Right $ if pk then TRowID else TInt64 129 | toTypeRep pk s | Text.take 3 s == "int" = Right $ if pk then TRowID else TInt32 130 | toTypeRep _ typ = Left typ 131 | 132 | indexInfo [_, SqlString ixname, _, SqlString itype, _] = do 133 | let q = ixinfo ixname 134 | info <- (snd . snd) <$> sqliteQueryRunner db q [] 135 | return $ (map (\[_,_,SqlString name] -> name) info, itype) 136 | indexInfo _ = do 137 | error "unreachable" 138 | 139 | describe fks ixs cs [_, SqlString name, SqlString ty, SqlInt64 nonnull, _, SqlInt64 pk] = do 140 | let ty' = Text.toLower ty 141 | return $ ColumnInfo 142 | { colName = mkColName name 143 | , colType = toTypeRep (pk == 1) ty' 144 | , colIsAutoPrimary = snd $ fromJust $ lookup name cs 145 | , colHasIndex = any (== ([name], "c")) ixs 146 | , colIsNullable = nonnull == 0 147 | , colFKs = 148 | [ (mkTableName reftbl, mkColName refkey) 149 | | (_:_:SqlString reftbl:SqlString key:SqlString refkey:_) <- fks 150 | , key == name 151 | ] 152 | } 153 | describe _ _ _ result = do 154 | throwM $ SqlError $ "bad result from PRAGMA table_info: " ++ show result 155 | 156 | disableFKs :: Database -> Bool -> IO () 157 | disableFKs db disable = do 158 | unless disable $ void $ sqliteQueryRunner db "COMMIT;" [] 159 | void $ sqliteQueryRunner db q [] 160 | when disable $ void $ sqliteQueryRunner db "BEGIN TRANSACTION;" [] 161 | where 162 | q | disable = "PRAGMA foreign_keys = OFF;" 163 | | otherwise = "PRAGMA foreign_keys = ON;" 164 | 165 | sqlitePrepare :: Database -> Text -> IO Dynamic 166 | sqlitePrepare db qry = do 167 | eres <- try $ prepare db qry 168 | case eres of 169 | Left e@(SQLError{}) -> throwM (SqlError (show e)) 170 | Right r -> return $ toDyn r 171 | 172 | sqliteRunPrepared :: Database -> Dynamic -> [Param] -> IO (Int, [[SqlValue]]) 173 | sqliteRunPrepared db hdl params = do 174 | eres <- try $ do 175 | let Just stm = fromDynamic hdl 176 | sqliteRunStmt db stm params `finally` do 177 | clearBindings stm 178 | reset stm 179 | case eres of 180 | Left e@(SQLError{}) -> throwM (SqlError (show e)) 181 | Right res -> return (snd res) 182 | 183 | sqliteQueryRunner :: Database -> QueryRunner (Int64, (Int, [[SqlValue]])) 184 | sqliteQueryRunner db qry params = do 185 | eres <- try $ do 186 | stm <- prepare db qry 187 | sqliteRunStmt db stm params `finally` do 188 | finalize stm 189 | case eres of 190 | Left e@(SQLError{}) -> throwM (SqlError (show e)) 191 | Right res -> return res 192 | 193 | sqliteRunStmt :: Database -> Statement -> [Param] -> IO (Int64, (Int, [[SqlValue]])) 194 | sqliteRunStmt db stm params = do 195 | bind stm [toSqlData p | Param p <- params] 196 | rows <- getRows stm [] 197 | rid <- lastInsertRowId db 198 | cs <- changes db 199 | return (fromIntegral rid, (cs, [map fromSqlData r | r <- rows])) 200 | 201 | getRows :: Statement -> [[SQLData]] -> IO [[SQLData]] 202 | getRows s acc = do 203 | res <- step s 204 | case res of 205 | Row -> do 206 | cs <- columns s 207 | getRows s (cs : acc) 208 | _ -> do 209 | return $ reverse acc 210 | 211 | toSqlData :: Lit a -> SQLData 212 | toSqlData (LInt32 i) = SQLInteger $ fromIntegral i 213 | toSqlData (LInt64 i) = SQLInteger $ fromIntegral i 214 | toSqlData (LDouble d) = SQLFloat d 215 | toSqlData (LText s) = SQLText s 216 | toSqlData (LDateTime t) = SQLText $ pack $ fmtTime sqlDateTimeFormat t 217 | toSqlData (LDate d) = SQLText $ pack $ fmtTime sqlDateFormat d 218 | toSqlData (LTime t) = SQLText $ pack $ fmtTime sqlTimeFormat t 219 | toSqlData (LBool b) = SQLInteger $ if b then 1 else 0 220 | toSqlData (LBlob b) = SQLBlob b 221 | toSqlData (LNull) = SQLNull 222 | toSqlData (LJust x) = toSqlData x 223 | toSqlData (LCustom _ l) = toSqlData l 224 | toSqlData (LUUID x) = SQLBlob (toStrict $ toByteString x) 225 | 226 | fromSqlData :: SQLData -> SqlValue 227 | fromSqlData (SQLInteger i) = SqlInt64 $ fromIntegral i 228 | fromSqlData (SQLFloat f) = SqlFloat f 229 | fromSqlData (SQLText s) = SqlString s 230 | fromSqlData (SQLBlob b) = SqlBlob b 231 | fromSqlData SQLNull = SqlNull 232 | 233 | fmtTime :: FormatTime t => String -> t -> String 234 | fmtTime = formatTime defaultTimeLocale 235 | #endif 236 | -------------------------------------------------------------------------------- /selda-sqlite/src/Database/Selda/SQLite/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Incomplete parser for SQL CREATE TABLE statements. 3 | -- Needed to figure out whether any given column is auto-incrementing 4 | -- or not. It's super inefficient, but doesn't really matter since it'll 5 | -- only ever be invoked during validation. 6 | module Database.Selda.SQLite.Parser (colsFromQuery) where 7 | import Control.Applicative 8 | import Control.Monad (void, msum, MonadPlus (..)) 9 | import Data.Char (isSpace, isAlpha, isAlphaNum) 10 | import Data.Maybe (isJust, catMaybes) 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | 14 | colsFromQuery :: Text -> [(Text, (Text, Bool))] 15 | colsFromQuery = parse' parseCreateQueryCols 16 | 17 | newtype Parser a = P { unP :: (Text -> Maybe (Text, a)) } 18 | 19 | instance Functor Parser where 20 | fmap f (P g) = P (fmap (fmap f) . g) 21 | 22 | instance Applicative Parser where 23 | pure x = P $ \t -> Just (t, x) 24 | f <*> x = f >>= \f' -> fmap f' x 25 | 26 | instance Alternative Parser where 27 | empty = P $ const Nothing 28 | P f <|> P g = P $ \s -> 29 | case f s of 30 | res@(Just _) -> res 31 | _ -> g s 32 | 33 | instance Monad Parser where 34 | return = pure 35 | P m >>= f = P $ \s -> do 36 | case m s of 37 | Just (rest, x) -> unP (f x) rest 38 | _ -> Nothing 39 | 40 | instance MonadPlus Parser where 41 | mzero = empty 42 | mplus = (<|>) 43 | 44 | parse :: Parser a -> Text -> Maybe a 45 | parse (P f) t = snd <$> f t 46 | 47 | parse' :: Parser a -> Text -> a 48 | parse' f t = maybe (error $ "no parse: '" ++ show t ++ "'") id $ parse f t 49 | 50 | lowerText :: Text -> Parser () 51 | lowerText prefix = P $ \s -> 52 | case Text.splitAt (Text.length prefix) s of 53 | (prefix', rest) | prefix == Text.toLower prefix' -> Just (rest, ()) 54 | _ -> Nothing 55 | 56 | charP :: (Char -> Bool) -> Parser Char 57 | charP p = P $ \s -> 58 | case Text.splitAt 1 s of 59 | (prefix, rest) | Text.any p prefix -> Just (rest, Text.head prefix) 60 | _ -> Nothing 61 | 62 | char :: Char -> Parser Char 63 | char c = charP (== c) 64 | 65 | space :: Parser () 66 | space = void $ charP isSpace 67 | 68 | spaces :: Parser () 69 | spaces = void $ some space 70 | 71 | sepBy1 :: Parser s -> Parser a -> Parser [a] 72 | sepBy1 sep p = do 73 | x <- p 74 | xs <- optional $ sep *> sepBy1 sep p 75 | case xs of 76 | Just xs' -> pure (x:xs') 77 | _ -> pure [x] 78 | 79 | commaSeparated :: Parser a -> Parser [a] 80 | commaSeparated = sepBy1 (many space >> char ',' >> many space) 81 | 82 | keywords :: [Text] 83 | keywords = ["constraint", "unique", "primary key"] 84 | 85 | parseCreateQueryCols :: Parser [(Text, (Text, Bool))] 86 | parseCreateQueryCols = do 87 | lowerText "create table" 88 | spaces 89 | void $ sqliteIdentifier 90 | void $ many space 91 | void $ char '(' 92 | cols <- commaSeparated parseCol <* many space 93 | void $ char ')' 94 | pure $ catMaybes cols 95 | 96 | parseCol :: Parser (Maybe (Text, (Text, Bool))) 97 | parseCol = do 98 | decl <- constraint <|> column 99 | pure $ case decl of 100 | Right col -> Just col 101 | _ -> Nothing 102 | where 103 | column = do 104 | name <- sqliteIdentifier 105 | spaces 106 | ty <- sqliteIdentifier 107 | void $ optional $ spaces *> lowerText "primary key" 108 | isAuto <- optional $ spaces *> lowerText "autoincrement" 109 | void $ many $ charP (\c -> isAlphaNum c || isSpace c) 110 | void $ optional $ do 111 | void $ char '(' 112 | void $ commaSeparated sqliteIdentifier 113 | void $ char ')' 114 | pure $ Right $ (name, (ty, isJust isAuto)) 115 | constraint = do 116 | msum (map lowerText keywords) 117 | void $ many $ msum 118 | [ void sqliteIdentifier 119 | , void $ do 120 | void $ char '(' 121 | void $ commaSeparated sqliteIdentifier 122 | void $ char ')' 123 | , spaces 124 | ] 125 | pure $ Left () 126 | 127 | sqliteIdentifier :: Parser Text 128 | sqliteIdentifier = Text.pack <$> (quoted <|> unquoted) 129 | where 130 | unquoted = do 131 | x <- charP $ \c -> isAlpha c || c == '_' 132 | xs <- many $ charP $ \c -> isAlphaNum c || c == '_' || c == '$' 133 | pure $ (x:xs) 134 | quoted = char '"' *> many quotedChar <* char '"' 135 | quotedChar = (char '"' >> char '"') <|> charP (/= '"') 136 | -------------------------------------------------------------------------------- /selda-tests/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Anton Ekblad 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /selda-tests/PGConnectInfo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module PGConnectInfo where 3 | import Database.Selda.PostgreSQL 4 | pgConnectInfo = "postgres" `on` "localhost" `auth` ("postgres", "password") 5 | -------------------------------------------------------------------------------- /selda-tests/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, directory, exceptions, HUnit, selda 2 | , selda-sqlite, stdenv, text, time 3 | }: 4 | mkDerivation { 5 | pname = "selda-tests"; 6 | version = "0.1.0.0"; 7 | src = ./.; 8 | testHaskellDepends = [ 9 | base directory exceptions HUnit selda selda-sqlite text time 10 | ]; 11 | description = "Tests for the Selda database DSL"; 12 | license = stdenv.lib.licenses.mit; 13 | } 14 | -------------------------------------------------------------------------------- /selda-tests/selda-tests.cabal: -------------------------------------------------------------------------------- 1 | name: selda-tests 2 | version: 0.1.0.0 3 | synopsis: Tests for the Selda database DSL. 4 | license: MIT 5 | license-file: LICENSE 6 | author: Anton Ekblad 7 | maintainer: anton@ekblad.cc 8 | category: Database 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | flag postgres 13 | default: False 14 | description: Run tests using PostgreSQL backend. 15 | 16 | library 17 | default-language: 18 | Haskell2010 19 | 20 | test-suite selda-testsuite 21 | type: 22 | exitcode-stdio-1.0 23 | main-is: 24 | RunTests.hs 25 | other-modules: 26 | Tables 27 | Utils 28 | Tests.JSON 29 | Tests.MultiConn 30 | Tests.Mutable 31 | Tests.NonDB 32 | Tests.Query 33 | Tests.Validation 34 | build-depends: 35 | aeson 36 | , base >=4.8 && <5 37 | , bytestring >=0.10 && <0.12 38 | , directory >=1.2 && <1.4 39 | , exceptions >=0.8 && <0.11 40 | , HUnit >=1.4 && <1.7 41 | , selda 42 | , selda-json 43 | , text >=1.1 && <2.1 44 | , time >=1.4 && <1.13 45 | , random >=1.1 && <1.3 46 | , uuid-types >=1.0 && <1.1 47 | if flag(postgres) 48 | other-modules: PGConnectInfo, Tests.PGConnectionString 49 | build-depends: selda-postgresql 50 | cpp-options: -DPOSTGRES -DTEST_JSON -DBACKEND=PG 51 | else 52 | build-depends: selda-sqlite 53 | cpp-options: -DSQLITE -DBACKEND=SQLite 54 | hs-source-dirs: 55 | test, . 56 | default-language: 57 | Haskell2010 58 | -------------------------------------------------------------------------------- /selda-tests/test/RunTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, OverloadedStrings, CPP, DeriveGeneric #-} 2 | module Main where 3 | import Control.Monad (when) 4 | import System.Directory (doesFileExist, removeFile, getTemporaryDirectory) 5 | import System.Exit (exitFailure) 6 | import Test.HUnit 7 | import Test.HUnit.Text 8 | import Database.Selda (SeldaM) 9 | import Tests.Query (queryTests) 10 | import Tests.Mutable (mutableTests) 11 | import Tests.Validation (validationTests) 12 | import Tests.NonDB (noDBTests) 13 | import Tests.MultiConn (multiConnTests) 14 | #ifdef POSTGRES 15 | import Tests.PGConnectionString (pgConnectionStringTests) 16 | #endif 17 | import Tables (teardown) 18 | 19 | #ifdef TEST_JSON 20 | import Tests.JSON (jsonQueryTests) 21 | #endif 22 | import Tests.JSON (jsonTests) 23 | 24 | #ifdef POSTGRES 25 | -- To test the PostgreSQL backend, specify the connection info for the server 26 | -- as PGConnectInfo.pgConnectInfo :: PGConnectInfo. 27 | import Database.Selda.PostgreSQL 28 | import PGConnectInfo (pgConnectInfo) 29 | #else 30 | import Database.Selda.SQLite 31 | #endif 32 | 33 | main = do 34 | tmpdir <- getTemporaryDirectory 35 | let dbfile = tmpdir ++ "/" ++ "__selda_test_tmp.sqlite" 36 | freshEnv dbfile $ teardown 37 | result <- runTestTT (allTests dbfile) 38 | case result of 39 | Counts cs tries 0 0 -> return () 40 | _ -> exitFailure 41 | 42 | -- | Run the given computation over the given SQLite file. If the file exists, 43 | -- it will be removed first. 44 | #ifdef POSTGRES 45 | freshEnv :: FilePath -> SeldaM PG a -> IO a 46 | freshEnv _ m = withPostgreSQL pgConnectInfo $ teardown >> m 47 | #else 48 | freshEnv :: FilePath -> SeldaM SQLite a -> IO a 49 | freshEnv file m = do 50 | exists <- doesFileExist file 51 | when exists $ removeFile file 52 | x <- withSQLite file m 53 | removeFile file 54 | return x 55 | #endif 56 | 57 | allTests f = TestList 58 | [ "non-database tests" ~: noDBTests 59 | , "query tests" ~: queryTests run 60 | , "validation tests" ~: validationTests (freshEnv f) 61 | , "mutable tests" ~: mutableTests (freshEnv f) 62 | , "multi-connection tests" ~: multiConnTests open 63 | , "mandatory json tests" ~: jsonTests (freshEnv f) 64 | #ifdef TEST_JSON 65 | , "json query tests" ~: jsonQueryTests (freshEnv f) 66 | #endif 67 | #ifdef POSTGRES 68 | , "pg connection string" ~: pgConnectionStringTests pgConnectInfo 69 | #endif 70 | ] 71 | where 72 | #ifdef POSTGRES 73 | open = pgOpen pgConnectInfo 74 | run = withPostgreSQL pgConnectInfo 75 | #else 76 | open = sqliteOpen f 77 | run = withSQLite f 78 | #endif 79 | -------------------------------------------------------------------------------- /selda-tests/test/Tables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TypeOperators, DeriveGeneric, CPP #-} 2 | #if MIN_VERSION_base(4, 9, 0) 3 | {-# LANGUAGE OverloadedLabels, FlexibleContexts, DataKinds, MonoLocalBinds #-} 4 | #endif 5 | -- | Tables for reuse by most tests, and functions for their setup and teardown. 6 | module Tables where 7 | import Database.Selda 8 | import Database.Selda.MakeSelectors 9 | 10 | data Person = Person 11 | { name :: Text 12 | , age :: Int 13 | , pet :: Maybe Text 14 | , cash :: Double 15 | } deriving (Generic, Show, Ord, Eq) 16 | instance SqlRow Person 17 | 18 | modPeople :: Table Person 19 | modPeople = tableFieldMod "modpeople" [Single pName :- primary] $ \name -> 20 | "mod_" <> name 21 | 22 | people :: Table Person 23 | people = table "people" 24 | [ Single pName :- primary 25 | , Single pName :- index 26 | , Single pCash :- indexUsing HashIndex 27 | , pName :+ Single pCash :- index 28 | ] 29 | 30 | pName = #name :: Selector Person Text 31 | pAge :: HasField "age" t => Selector t (FieldType "age" t) 32 | pAge = #age 33 | pPet = #pet :: Selector Person (Maybe Text) 34 | pCash = #cash :: HasField "cash" t => Selector t (FieldType "cash" t) 35 | 36 | addresses :: Table (Text, Text) 37 | (addresses, aName :*: aCity) = tableWithSelectors "addresses" [] 38 | 39 | comments, weakComments :: Table (RowID, Maybe Text, Text) 40 | comments = table "comments" [cId :- untypedAutoPrimary] 41 | weakComments = table "comments" [cId :- weakUntypedAutoPrimary] 42 | cId :*: cName :*: cComment = selectors comments 43 | 44 | peopleItems = 45 | [ Person "Link" 125 (Just "horse") 13506 46 | , Person "Velvet" 19 Nothing 5.55 47 | , Person "Kobayashi" 23 (Just "dragon") 103707.55 48 | , Person "Miyu" 10 Nothing (-500) 49 | ] 50 | 51 | addressItems = 52 | [ ("Link" , "Kakariko") 53 | , ("Kobayashi" , "Tokyo") 54 | , ("Miyu" , "Fuyukishi") 55 | ] 56 | 57 | commentItems = 58 | [ (def, Just "Link" , "Well, excuuuse me, princess!") 59 | , (def, Nothing , "Anonymous spam comment") 60 | ] 61 | 62 | resetup :: MonadSelda m => m () 63 | resetup = do 64 | tryCreateTable people 65 | tryCreateTable modPeople 66 | tryCreateTable addresses 67 | tryCreateTable comments 68 | 69 | setup :: MonadSelda m => m () 70 | setup = do 71 | createTable people 72 | createTable modPeople 73 | createTable addresses 74 | createTable comments 75 | insert_ (modPeople) peopleItems 76 | insert_ people peopleItems 77 | insert_ addresses addressItems 78 | insert_ comments commentItems 79 | 80 | teardown :: MonadSelda m => m () 81 | teardown = do 82 | tryDropTable people 83 | tryDropTable modPeople 84 | tryDropTable addresses 85 | tryDropTable comments 86 | -------------------------------------------------------------------------------- /selda-tests/test/Tests/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O0 #-} 2 | {-# LANGUAGE DeriveGeneric, OverloadedStrings, OverloadedLabels #-} 3 | module Tests.JSON (jsonTests, jsonQueryTests) where 4 | import Database.Selda hiding (Result) 5 | import Database.Selda.JSON 6 | import Database.Selda.Nullable (nonNull) 7 | import Control.Monad 8 | import Data.Aeson 9 | import qualified Data.ByteString.Lazy as BSL (fromStrict) 10 | import Data.Text.Encoding (encodeUtf8) 11 | import Data.List (sort) 12 | import Test.HUnit 13 | import Tables (Person (..), peopleItems) 14 | import Utils 15 | 16 | data JSONPerson = JSONPerson 17 | { id :: ID JSONPerson 18 | , nameKey :: Text 19 | , json :: Value 20 | } deriving Generic 21 | instance SqlRow JSONPerson 22 | 23 | instance ToJSON Person 24 | instance FromJSON Person 25 | 26 | flipWithM_ :: Monad m => [a] -> [b] -> (a -> b -> m c) -> m () 27 | flipWithM_ xs ys f = zipWithM_ f xs ys 28 | 29 | jsonPeople :: Table JSONPerson 30 | jsonPeople = table "jsonPeople" [#id :- autoPrimary] 31 | 32 | jsonTests :: (SeldaM b () -> IO ()) -> Test 33 | jsonTests freshEnv = test 34 | [ "json is properly inserted" ~: freshEnv insertJson 35 | , "json is properly returned" ~: freshEnv selectJson 36 | ] 37 | 38 | jsonQueryTests :: JSONBackend b => (SeldaM b () -> IO ()) -> Test 39 | jsonQueryTests freshEnv = test 40 | [ "can select json properties" ~: freshEnv selectJsonProp 41 | , "select dynamic json property" ~: freshEnv selectJsonPropDynamic 42 | , "convert json to string" ~: freshEnv json2String 43 | , "missing property yields null" ~: freshEnv missingProp 44 | , "chained lookup" ~: freshEnv chainedLookup 45 | ] 46 | 47 | 48 | numPeopleItems :: Int 49 | numPeopleItems = length peopleItems 50 | 51 | withJsonTable :: (Int -> SeldaM b a) -> SeldaM b a 52 | withJsonTable go = do 53 | tryDropTable jsonPeople 54 | createTable jsonPeople 55 | count <- insert jsonPeople $ map (JSONPerson def "name" . toJSON) peopleItems 56 | x <- go count 57 | dropTable jsonPeople 58 | return x 59 | 60 | withJsonTable' :: SeldaM b a -> SeldaM b a 61 | withJsonTable' go = withJsonTable (const go) 62 | 63 | insertJson = 64 | withJsonTable $ assEq "wrong number of rows inserted" numPeopleItems 65 | 66 | selectJson = withJsonTable' $ do 67 | vals <- query $ #json `from` select jsonPeople 68 | let vals' = [v | Success v <- map fromJSON vals] 69 | assEq "wrong number of rows returned" numPeopleItems (length vals) 70 | assEq "some json conversions failed" (length vals) (length vals') 71 | flipWithM_ (sort peopleItems) (sort vals') $ \expected actual -> do 72 | assEq "got wrong element from query" expected actual 73 | 74 | selectJsonProp :: JSONBackend b => SeldaM b () 75 | selectJsonProp = withJsonTable' $ do 76 | vals <- query $ do 77 | json_person <- #json `from` select jsonPeople 78 | return $ json_person ~> "name" 79 | let vals' = [s | Just (String s) <- vals] 80 | assEq "wrong number of rows returned" numPeopleItems (length vals) 81 | assEq "some json conversions failed" (length vals) (length vals') 82 | assEq "wrong list of names returned" (sort $ map name peopleItems) (sort vals') 83 | 84 | selectJsonPropDynamic :: JSONBackend b => SeldaM b () 85 | selectJsonPropDynamic = withJsonTable' $ do 86 | vals <- query $ do 87 | person <- select jsonPeople 88 | return $ person ! #json ~> person ! #nameKey 89 | let vals' = [s | Just (String s) <- vals] 90 | assEq "wrong number of rows returned" numPeopleItems (length vals) 91 | assEq "some json conversions failed" (length vals) (length vals') 92 | assEq "wrong list of names returned" (sort $ map name peopleItems) (sort vals') 93 | 94 | json2String :: JSONBackend b => SeldaM b () 95 | json2String = withJsonTable' $ do 96 | vals <- query $ do 97 | json_person <- #json `from` select jsonPeople 98 | return $ jsonToText json_person 99 | let vals' = [x | Just x <- map (decode . BSL.fromStrict . encodeUtf8) vals] 100 | assEq "wrong number of rows returned" numPeopleItems (length vals) 101 | assEq "some json conversions failed" (length vals) (length vals') 102 | assEq "wrong list of people returned" (sort peopleItems) (sort vals') 103 | 104 | missingProp :: JSONBackend b => SeldaM b () 105 | missingProp = withJsonTable' $ do 106 | vals <- query $ do 107 | json_person <- #json `from` select jsonPeople 108 | return $ json_person ~> "this property does not exist" 109 | assEq "wrong number of rows returned" numPeopleItems (length vals) 110 | forM_ vals $ \actual -> do 111 | assEq "some rows were not null" Nothing actual 112 | 113 | chainedLookup :: JSONBackend b => SeldaM b () 114 | chainedLookup = withJsonTable' $ do 115 | update jsonPeople (const true) (`with` [#json := literal newJson]) 116 | val <- fmap head . query $ do 117 | json_person <- #json `from` select jsonPeople 118 | x <- nonNull (json_person ~> "foo" ~> "bar") 119 | return (jsonToText x) 120 | assEq "wrong value returned" "42" val 121 | where 122 | Just newJson = decode "{\"foo\": {\"bar\": 42}}" :: Maybe Value 123 | -------------------------------------------------------------------------------- /selda-tests/test/Tests/MultiConn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Tests that need to open and close different connections to the database. 3 | module Tests.MultiConn (multiConnTests) where 4 | import Database.Selda 5 | import Database.Selda.Backend 6 | import Control.Concurrent 7 | import Control.Monad.Catch 8 | import Data.IORef 9 | import Test.HUnit 10 | import Utils 11 | import Tables 12 | 13 | multiConnTests :: IO (SeldaConnection b) -> Test 14 | multiConnTests open = test 15 | [ "setup with runSeldaT" ~: open >>= runSeldaT (teardown >> setup) 16 | , "connection unusable post-close" ~: postClose open 17 | , "connection is reusable" ~: reuse open 18 | , "simultaneous connections" ~: simultaneousConnections open 19 | , "simultaneous writes" ~: simultaneousConnections open 20 | , "connection access is serialized" ~: serialized open 21 | , "unrelated connections are not serialized" ~: twoConnsNotSerialized open 22 | , "connection reuse after exception" ~: reuseAfterException open 23 | , "prepared query across connections" ~: reusePrepared open 24 | , "teardown with runSeldaT" ~: open >>= runSeldaT teardown 25 | ] 26 | 27 | postClose :: IO (SeldaConnection b) -> IO () 28 | postClose open = do 29 | conn <- open 30 | seldaClose conn 31 | res <- try $ flip runSeldaT conn $ do 32 | query $ select people 33 | case res of 34 | Left (DbError{}) -> return () 35 | _ -> liftIO $ assertFailure "post-close error not thrown" 36 | 37 | reuse :: IO (SeldaConnection b) -> IO () 38 | reuse open = do 39 | conn <- open 40 | res1 <- flip runSeldaT conn $ do 41 | query $ (pName `from` select people) `suchThat` (.== "Link") 42 | assertEqual "wrong result from first query" ["Link"] res1 43 | 44 | res2 <- flip runSeldaT conn $ do 45 | query $ (pName `from` select people) `suchThat` (.== "Kobayashi") 46 | assertEqual "wrong result from second query" ["Kobayashi"] res2 47 | seldaClose conn 48 | 49 | simultaneousConnections :: IO (SeldaConnection b) -> IO () 50 | simultaneousConnections open = do 51 | [c1, c2] <- sequence [open, open] 52 | res1 <- flip runSeldaT c1 $ do 53 | query $ (pName `from` select people) `suchThat` (.== "Link") 54 | assertEqual "wrong result from first query" ["Link"] res1 55 | 56 | res2 <- flip runSeldaT c2 $ do 57 | query $ (pName `from` select people) `suchThat` (.== "Kobayashi") 58 | assertEqual "wrong result from second query" ["Kobayashi"] res2 59 | mapM_ seldaClose [c1, c2] 60 | 61 | simultaneousWrites :: IO (SeldaConnection b) -> IO () 62 | simultaneousWrites open = do 63 | c1 <- open 64 | c2 <- open 65 | withC c1 c2 $ runSeldaT (teardown >> setup) 66 | flip runSeldaT c1 $ do 67 | insert_ people [Person "Marina" 18 def def] 68 | flip runSeldaT c2 $ do 69 | insert_ people [Person "Amber" 19 def def] 70 | res1 <- flip runSeldaT c1 $ do 71 | query $ (pName `from` select people) `suchThat` (.== "Amber") 72 | res2 <- flip runSeldaT c1 $ do 73 | query $ (pName `from` select people) `suchThat` (.== "Marina") 74 | withC c1 c2 $ runSeldaT teardown 75 | withC c1 c2 $ seldaClose 76 | assertEqual "wrong result from first query" ["Amber"] res1 77 | assertEqual "wrong result from second query" ["Marina"] res2 78 | where 79 | withC c1 c2 f = f c1 >> f c2 80 | 81 | serialized :: IO (SeldaConnection b) -> IO () 82 | serialized open = do 83 | conn <- open 84 | ref <- newIORef 0 85 | 86 | forkIO $ do 87 | flip runSeldaT conn $ do 88 | liftIO $ atomicModifyIORef' ref $ \r -> (r+1, ()) 89 | liftIO $ threadDelay 200000 90 | liftIO $ atomicModifyIORef' ref $ \r -> (r-1, ()) 91 | 92 | threadDelay 100000 93 | res <- flip runSeldaT conn $ liftIO $ readIORef ref 94 | seldaClose conn 95 | assertEqual "concurrent use of the same connection" 0 res 96 | 97 | twoConnsNotSerialized :: IO (SeldaConnection b) -> IO () 98 | twoConnsNotSerialized open = do 99 | [c1, c2] <- sequence [open, open] 100 | ref <- newIORef 0 101 | 102 | forkIO $ do 103 | flip runSeldaT c1 $ do 104 | liftIO $ atomicModifyIORef' ref $ \r -> (r+1, ()) 105 | liftIO $ threadDelay 200000 106 | liftIO $ atomicModifyIORef' ref $ \r -> (r-1, ()) 107 | 108 | threadDelay 100000 109 | res <- flip runSeldaT c2 $ liftIO $ readIORef ref 110 | mapM_ seldaClose [c1, c2] 111 | assertEqual "unrelated connections were serialized" 1 res 112 | 113 | reuseAfterException :: IO (SeldaConnection b) -> IO () 114 | reuseAfterException open = do 115 | conn <- open 116 | res <- try $ flip runSeldaT conn $ do 117 | error "oh noes!" 118 | case res of 119 | Right _ -> do 120 | assertFailure "computation didn't fail" 121 | Left (SomeException{}) -> do 122 | res' <- flip runSeldaT conn $ do 123 | query $ (pName `from` select people) `suchThat` (.== "Miyu") 124 | assertEqual "got wrong result after exception" ["Miyu"] res' 125 | 126 | {-# NOINLINE allNamesLike #-} 127 | allNamesLike :: Int -> Text -> SeldaM b [Text] 128 | allNamesLike = prepared $ \len s -> do 129 | p <- select people 130 | restrict (length_ (p ! pName) .> 0) 131 | restrict (p ! pName `like` s) 132 | restrict (length_ (p ! pName) .> 1) 133 | restrict (length_ (p ! pName) .<= len) 134 | restrict (length_ (p ! pName) .<= 100) 135 | restrict (length_ (p ! pName) .<= 200) 136 | order (p ! pName) ascending 137 | return (p ! pName) 138 | 139 | reusePrepared :: IO (SeldaConnection b) -> IO () 140 | reusePrepared open = do 141 | [c1, c2] <- sequence [open, open] 142 | r11 <- runSeldaT (allNamesLike 4 "%L%") c1 143 | r21 <- runSeldaT (allNamesLike 4 "%L%") c2 144 | r12 <- runSeldaT (allNamesLike 4 "%L%") c1 145 | r22 <- runSeldaT (allNamesLike 4 "%L%") c2 146 | mapM_ seldaClose [c1, c2] 147 | assertEqual "wrong result from first query" ["Link"] r11 148 | assertBool "wrong result from subsequent queries" (all (==r11) [r21, r12, r22]) 149 | -------------------------------------------------------------------------------- /selda-tests/test/Tests/NonDB.hs: -------------------------------------------------------------------------------- 1 | -- | Misc. tests that don't touch the database. 2 | module Tests.NonDB where 3 | import Data.List hiding (groupBy, insert) 4 | import Data.Text (unpack) 5 | import Database.Selda 6 | import Database.Selda.Debug (compile) 7 | import Test.HUnit 8 | import Utils 9 | import Tables 10 | 11 | noDBTests = test 12 | [ "tableFieldMod modifies fields" ~: tfmModifiesFields 13 | ] 14 | 15 | tfmModifiesFields = 16 | assertBool "Field names are unchanged from underlying record" 17 | ("mod_" `isInfixOf` q) 18 | where 19 | q = unpack $ fst $ compile (select modPeople) 20 | -------------------------------------------------------------------------------- /selda-tests/test/Tests/PGConnectionString.hs: -------------------------------------------------------------------------------- 1 | module Tests.PGConnectionString (pgConnectionStringTests) where 2 | import Data.Text.Encoding (decodeUtf8) 3 | import Database.Selda 4 | import Database.Selda.PostgreSQL 5 | import Test.HUnit 6 | import Tables 7 | 8 | pgConnectionStringTests :: PGConnectInfo -> Test 9 | pgConnectionStringTests s@(PGConnectionString _ _) = 10 | test [ "setup" ~: withPostgreSQL s (teardown >> setup :: SeldaM PG ()) ] 11 | pgConnectionStringTests ci = 12 | pgConnectionStringTests (PGConnectionString (decodeUtf8 $ pgConnString ci) Nothing) 13 | -------------------------------------------------------------------------------- /selda-tests/test/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | -- | Utility functions that are useful for all tests. 3 | module Utils where 4 | import Control.Monad.Catch 5 | import Data.Text (unpack) 6 | import Database.Selda 7 | import Database.Selda.Debug (compile) 8 | import Test.HUnit 9 | 10 | -- | Assert that the given computation should fail. 11 | assertFail :: SeldaM b a -> SeldaM b () 12 | assertFail m = do 13 | res <- try m 14 | case res of 15 | Left (SomeException _) -> return () 16 | _ -> liftIO $ assertFailure "computation did not fail" 17 | 18 | -- | @SeldaT@ wrapper for 'assertEqual'. 19 | assEq :: (Show a, Eq a) => String -> a -> a -> SeldaM b () 20 | assEq s expect actual = liftIO $ assertEqual s expect actual 21 | 22 | -- | @SeldaT@ wrapper for 'assertEqual'. 23 | assQueryEq :: (Result a, Show (Res a), Eq (Res a)) => String -> [Res a] -> Query b a -> SeldaM b () 24 | assQueryEq s expect q = do 25 | eactual <- try $! query q >>= mapM (\x -> pure $! x) 26 | let msg = "Generated query:\n" ++ unpack (fst $ compile q) ++ "\n" 27 | case eactual of 28 | Right actual -> 29 | liftIO $ assertEqual (s ++ "\n" ++ msg) expect actual 30 | Left (SomeException e) -> 31 | ass (msg ++ "\nException thrown:\n" ++ show e ++ "\n") False 32 | 33 | -- | @SeldaT@ wrapper for 'assertBool'. 34 | ass :: String -> Bool -> SeldaM b () 35 | ass s pred = liftIO $ assertBool s pred 36 | -------------------------------------------------------------------------------- /selda/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /selda/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, exceptions, mtl, text, time, containers, random, uuid-types, stdenv 2 | }: 3 | mkDerivation { 4 | pname = "selda"; 5 | version = "0.5.0.0"; 6 | src = ./.; 7 | libraryHaskellDepends = [ 8 | base bytestring exceptions mtl text time containers random uuid-types 9 | ]; 10 | homepage = "https://selda.link"; 11 | description = "Type-safe, high-level EDSL for interacting with relational databases"; 12 | license = stdenv.lib.licenses.mit; 13 | } 14 | -------------------------------------------------------------------------------- /selda/selda.cabal: -------------------------------------------------------------------------------- 1 | name: selda 2 | version: 0.5.2.1 3 | synopsis: Multi-backend, high-level EDSL for interacting with SQL databases. 4 | description: This package provides an EDSL for writing portable, type-safe, high-level 5 | database code. Its feature set includes querying and modifying databases, 6 | automatic, in-process caching with consistency guarantees, and transaction 7 | support. 8 | 9 | See the project website for a comprehensive tutorial. 10 | 11 | To use this package you need at least one backend package, in addition to 12 | this package. There are currently two different backend packages: 13 | selda-sqlite and selda-postgresql. 14 | homepage: https://selda.link 15 | license: MIT 16 | author: Anton Ekblad 17 | maintainer: anton@ekblad.cc 18 | category: Database 19 | build-type: Simple 20 | cabal-version: >=1.10 21 | tested-with: GHC == 8.8.2, GHC == 8.10.1, GHC == 9.2.5, GHC == 9.4.4 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/valderman/selda.git 26 | 27 | library 28 | exposed-modules: 29 | Database.Selda 30 | Database.Selda.Backend 31 | Database.Selda.Backend.Internal 32 | Database.Selda.Debug 33 | Database.Selda.MakeSelectors 34 | Database.Selda.Migrations 35 | Database.Selda.Nullable 36 | Database.Selda.SqlType 37 | Database.Selda.Unsafe 38 | Database.Selda.Validation 39 | other-modules: 40 | Database.Selda.Column 41 | Database.Selda.Compile 42 | Database.Selda.Exp 43 | Database.Selda.Frontend 44 | Database.Selda.FieldSelectors 45 | Database.Selda.Generic 46 | Database.Selda.Inner 47 | Database.Selda.Prepared 48 | Database.Selda.Query 49 | Database.Selda.Query.Type 50 | Database.Selda.Selectors 51 | Database.Selda.SQL 52 | Database.Selda.SQL.Print 53 | Database.Selda.SQL.Print.Config 54 | Database.Selda.SqlRow 55 | Database.Selda.Table 56 | Database.Selda.Table.Compile 57 | Database.Selda.Table.Type 58 | Database.Selda.Table.Validation 59 | Database.Selda.Transform 60 | Database.Selda.Types 61 | other-extensions: 62 | OverloadedStrings 63 | GADTs 64 | CPP 65 | MultiParamTypeClasses 66 | UndecidableInstances 67 | ScopedTypeVariables 68 | RankNTypes 69 | TypeFamilies 70 | FlexibleInstances 71 | GeneralizedNewtypeDeriving 72 | FlexibleContexts 73 | build-depends: 74 | base >=4.10 && <5 75 | , bytestring >=0.10 && <0.12 76 | , exceptions >=0.8 && <0.11 77 | , mtl >=2.0 && <2.4 78 | , text >=1.0 && <2.1 79 | , time >=1.5 && <1.13 80 | , containers >=0.4 && <0.7 81 | , random >=1.1 && <1.3 82 | , uuid-types >=1.0 && <1.1 83 | hs-source-dirs: 84 | src 85 | default-language: 86 | Haskell2010 87 | ghc-options: 88 | -Wall 89 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Backend.hs: -------------------------------------------------------------------------------- 1 | -- | API for building Selda backends and adding support for more types 2 | -- in queries. 3 | module Database.Selda.Backend 4 | ( MonadSelda (..), SeldaT, SeldaM, SeldaError (..) 5 | , StmtID, BackendID (..), QueryRunner, SeldaBackend (..), SeldaConnection 6 | , SqlValue (..) 7 | , IndexMethod (..) 8 | , Param (..), ColAttr (..), AutoIncType (..) 9 | , PPConfig (..), defPPConfig 10 | , TableName, ColName, TableInfo (..), ColumnInfo (..) 11 | , isAutoPrimary, isPrimary, isUnique 12 | , tableInfo, fromColInfo 13 | , mkTableName, mkColName, fromTableName, fromColName, rawTableName 14 | , newConnection, allStmts, withBackend 15 | , runSeldaT, seldaClose 16 | , module SqlType 17 | ) where 18 | import Control.Monad ( unless ) 19 | import Control.Monad.Catch ( mask_ ) 20 | import Control.Monad.IO.Class ( MonadIO(..) ) 21 | import Data.IORef ( atomicModifyIORef' ) 22 | import Database.Selda.Backend.Internal 23 | ( Param(..), 24 | ColAttr(..), 25 | AutoIncType(..), 26 | isAutoPrimary, 27 | isPrimary, 28 | isUnique, 29 | PPConfig(..), 30 | defPPConfig, 31 | SeldaM, 32 | SeldaT, 33 | MonadSelda(..), 34 | SeldaBackend(..), 35 | ColumnInfo(..), 36 | TableInfo(..), 37 | SeldaConnection(connClosed, connBackend), 38 | QueryRunner, 39 | StmtID, 40 | SeldaError(..), 41 | BackendID(..), 42 | newConnection, 43 | allStmts, 44 | fromColInfo, 45 | tableInfo, 46 | withBackend, 47 | runSeldaT ) 48 | import Database.Selda.SqlType as SqlType 49 | ( UUID, 50 | UUID'(..), 51 | ID(..), 52 | RowID, 53 | SqlValue(..), 54 | Lit(..), 55 | SqlEnum(..), 56 | SqlType(..), 57 | SqlTypeRep(..), 58 | sqlDateTimeFormat, 59 | sqlDateFormat, 60 | sqlTimeFormat, 61 | litType, 62 | compLit, 63 | invalidRowId, 64 | isInvalidRowId, 65 | toRowId, 66 | fromRowId, 67 | typedUuid, 68 | toId, 69 | fromId, 70 | invalidId, 71 | isInvalidId ) 72 | import Database.Selda.Table.Type ( IndexMethod(..) ) 73 | import Database.Selda.Types 74 | ( TableName, 75 | ColName, 76 | fromColName, 77 | fromTableName, 78 | rawTableName, 79 | mkColName, 80 | mkTableName ) 81 | 82 | -- | Close a reusable Selda connection. 83 | -- Closing a connection while in use is undefined. 84 | -- Passing a closed connection to 'runSeldaT' results in a 'SeldaError' 85 | -- being thrown. Closing a connection more than once is a no-op. 86 | seldaClose :: MonadIO m => SeldaConnection b -> m () 87 | seldaClose c = liftIO $ mask_ $ do 88 | closed <- atomicModifyIORef' (connClosed c) $ \closed -> (True, closed) 89 | unless closed $ closeConnection (connBackend c) c 90 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Column.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds #-} 2 | {-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-} 3 | {-# LANGUAGE DataKinds, UndecidableInstances, MultiParamTypeClasses #-} 4 | -- | Columns and associated utility functions, specialized to 'SQL'. 5 | module Database.Selda.Column 6 | ( Columns, Same 7 | , Row (..), Col (..), SomeCol (..), UntypedCol (..) 8 | , Exp (..), NulOp (..), UnOp (..), BinOp (..) 9 | , toTup, fromTup, liftC, liftC2, liftC3 10 | , allNamesIn 11 | , hideRenaming 12 | , literal 13 | ) where 14 | import Database.Selda.Exp 15 | ( Names(allNamesIn), 16 | BinOp(..), 17 | UnOp(..), 18 | NulOp(..), 19 | Exp(..), 20 | UntypedCol(..), 21 | SomeCol(..), 22 | hideRenaming ) 23 | import Database.Selda.SQL ( SQL ) 24 | import Database.Selda.SqlType ( SqlType(mkLit) ) 25 | import Database.Selda.SqlRow ( SqlRow(nestedCols) ) 26 | import Database.Selda.Types ( type (:*:)(..), ColName ) 27 | import Data.Proxy ( Proxy(..) ) 28 | import Data.String ( IsString(..) ) 29 | import Data.Text (Text) 30 | import GHC.TypeLits as TL ( TypeError, ErrorMessage(Text) ) 31 | 32 | -- | Any column tuple. 33 | class Columns a where 34 | toTup :: [ColName] -> a 35 | fromTup :: a -> [UntypedCol SQL] 36 | 37 | instance (SqlType a, Columns b) => Columns (Col s a :*: b) where 38 | toTup (x:xs) = One (Col x) :*: toTup xs 39 | toTup [] = error "too few elements to toTup" 40 | fromTup (One x :*: xs) = Untyped x : fromTup xs 41 | 42 | instance (SqlRow a, Columns b) => Columns (Row s a :*: b) where 43 | toTup xs = 44 | case nestedCols (Proxy :: Proxy a) of 45 | n -> Many (map (Untyped . Col) (take n xs)) :*: toTup (drop n xs) 46 | fromTup (Many xs :*: xss) = xs ++ fromTup xss 47 | 48 | instance Columns (Col s a) where 49 | toTup [x] = One (Col x) 50 | toTup [] = error "too few elements to toTup" 51 | toTup _ = error "too many elements to toTup" 52 | fromTup (One x) = [Untyped x] 53 | 54 | instance Columns (Row s a) where 55 | toTup xs = Many (map (Untyped . Col) xs) 56 | fromTup (Many xs) = xs 57 | 58 | -- | A database column. A column is often a literal column table, but can also 59 | -- be an expression over such a column or a constant expression. 60 | newtype Col s a = One (Exp SQL a) 61 | 62 | -- | A database row. A row is a collection of one or more columns. 63 | newtype Row s a = Many [UntypedCol SQL] 64 | 65 | -- | A literal expression. 66 | literal :: SqlType a => a -> Col s a 67 | literal = One . Lit . mkLit 68 | 69 | instance IsString (Col s Text) where 70 | fromString = literal . fromString 71 | 72 | liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d) 73 | -> Col s a 74 | -> Col s b 75 | -> Col s c 76 | -> Col s d 77 | liftC3 f (One a) (One b) (One c) = One (f a b c) 78 | 79 | -- | Denotes that scopes @s@ and @t@ are identical. 80 | class s ~ t => Same s t where 81 | liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col t b -> Col s c 82 | liftC2 f (One a) (One b) = One (f a b) 83 | 84 | instance {-# OVERLAPPING #-} Same s s 85 | instance {-# OVERLAPPABLE #-} (s ~ t, TypeError 86 | ('TL.Text "An identifier from an outer scope may not be used in an inner query.")) 87 | => Same s t 88 | 89 | liftC :: (Exp SQL a -> Exp SQL b) -> Col s a -> Col s b 90 | liftC f (One x) = One (f x) 91 | 92 | instance (SqlType a, Num a) => Num (Col s a) where 93 | fromInteger = literal . fromInteger 94 | (+) = liftC2 $ BinOp Add 95 | (-) = liftC2 $ BinOp Sub 96 | (*) = liftC2 $ BinOp Mul 97 | negate = liftC $ UnOp Neg 98 | abs = liftC $ UnOp Abs 99 | signum = liftC $ UnOp Sgn 100 | 101 | instance Fractional (Col s Double) where 102 | fromRational = literal . fromRational 103 | (/) = liftC2 $ BinOp Div 104 | 105 | instance Fractional (Col s Int) where 106 | fromRational = literal . (truncate :: Double -> Int) . fromRational 107 | (/) = liftC2 $ BinOp Div 108 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | -- | Selda SQL compilation. 5 | module Database.Selda.Compile 6 | ( Result, Res 7 | , buildResult, compQuery, compQueryWithFreshScope 8 | , compile, compileWith 9 | , compileInsert, compileUpdate, compileDelete 10 | ) 11 | where 12 | import Control.Monad (liftM2) 13 | import Database.Selda.Column 14 | ( UntypedCol(Untyped), 15 | SomeCol(Some), 16 | Row(..), 17 | Col(..), 18 | Columns(toTup) ) 19 | import Database.Selda.Generic ( Relational, params ) 20 | import Database.Selda.Query.Type 21 | ( GenState(nameSupply), Query, Scope, runQueryM ) 22 | import Database.Selda.SQL ( Param, SQL(SQL), SqlSource(Product) ) 23 | import Database.Selda.SQL.Print ( compSql, compUpdate, compDelete ) 24 | import Database.Selda.SQL.Print.Config 25 | ( PPConfig(ppMaxInsertParams), defPPConfig ) 26 | import Database.Selda.SqlRow 27 | ( SqlRow(nextResult), ResultReader, runResultReader, next ) 28 | import Database.Selda.SqlType ( SqlValue, SqlType(fromSql) ) 29 | import Database.Selda.Table 30 | ( ColInfo(colName), Table(tableCols, tableName), tableExpr ) 31 | import Database.Selda.Table.Compile ( compInsert ) 32 | import Database.Selda.Transform 33 | ( removeDeadCols, implicitlyLiveCols, colNames, state2sql ) 34 | import Database.Selda.Types ( type (:*:)(..) ) 35 | import Data.Proxy ( Proxy(..) ) 36 | import Data.Text (Text, empty) 37 | import Data.Typeable (Typeable) 38 | 39 | -- For scope supply 40 | import Data.IORef ( IORef, atomicModifyIORef', newIORef ) 41 | import System.IO.Unsafe ( unsafePerformIO ) 42 | 43 | -- | Compile a query into a parameterised SQL statement. 44 | -- 45 | -- The types given are tailored for SQLite. To translate SQLite types into 46 | -- whichever types are used by your backend, use 'compileWith'. 47 | compile :: Result a => Query s a -> (Text, [Param]) 48 | compile = compileWith defPPConfig 49 | 50 | -- | Compile a query using the given type translation function. 51 | compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param]) 52 | compileWith cfg = compSql cfg . snd . compQuery 0 53 | 54 | -- | Compile an @INSERT@ query, given the keyword representing default values 55 | -- in the target SQL dialect, a table and a list of items corresponding 56 | -- to the table. 57 | compileInsert :: Relational a => PPConfig -> Table a -> [a] -> [(Text, [Param])] 58 | compileInsert _ _ [] = 59 | [(empty, [])] 60 | compileInsert cfg tbl rows = 61 | case ppMaxInsertParams cfg of 62 | Nothing -> [compInsert cfg tbl rows'] 63 | Just n -> map (compInsert cfg tbl) (chunk (n `div` rowlen) rows') 64 | where 65 | rows' = map params rows 66 | rowlen = length (head rows') 67 | chunk chunksize xs = 68 | case splitAt chunksize xs of 69 | ([], []) -> [] 70 | (x, []) -> [x] 71 | (x, xs') -> x : chunk chunksize xs' 72 | 73 | -- | Compile an @UPDATE@ query. 74 | compileUpdate :: forall s a. (Relational a, SqlRow a) 75 | => PPConfig 76 | -> Table a -- ^ Table to update. 77 | -> (Row s a -> Row s a) -- ^ Update function. 78 | -> (Row s a -> Col s Bool) -- ^ Predicate. 79 | -> (Text, [Param]) 80 | compileUpdate cfg tbl upd check = 81 | compUpdate cfg (tableName tbl) predicate updated 82 | where 83 | names = map colName (tableCols tbl) 84 | cs = tableExpr tbl 85 | updated = zip names (finalCols (upd cs)) 86 | One predicate = check cs 87 | 88 | -- | Compile a @DELETE FROM@ query. 89 | compileDelete :: Relational a 90 | => PPConfig 91 | -> Table a 92 | -> (Row s a -> Col s Bool) 93 | -> (Text, [Param]) 94 | compileDelete cfg tbl check = compDelete cfg (tableName tbl) predicate 95 | where One predicate = check $ toTup $ map colName $ tableCols tbl 96 | 97 | -- | Compile a query to an SQL AST. 98 | -- Groups are ignored, as they are only used by 'aggregate'. 99 | compQuery :: Result a => Scope -> Query s a -> (Int, SQL) 100 | compQuery ns q = 101 | (nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing [] False) 102 | where 103 | (cs, st) = runQueryM ns q 104 | final = finalCols cs 105 | sql = state2sql st 106 | live = colNames final ++ implicitlyLiveCols sql 107 | srcs = removeDeadCols live sql 108 | 109 | {-# NOINLINE scopeSupply #-} 110 | scopeSupply :: IORef Scope 111 | scopeSupply = unsafePerformIO $ newIORef 1 112 | 113 | -- | Get a fresh scope from the global scope supply, then use it to compile 114 | -- the given query. 115 | compQueryWithFreshScope :: Result a => Query s a -> (Int, SQL) 116 | compQueryWithFreshScope q = unsafePerformIO $ do 117 | s <- atomicModifyIORef' scopeSupply (\s -> (s+1, s)) 118 | return $ compQuery s q 119 | 120 | buildResult :: Result r => Proxy r -> [SqlValue] -> Res r 121 | buildResult p = runResultReader (toRes p) 122 | 123 | type family Res r where 124 | Res (Col s a :*: b) = a :*: Res b 125 | Res (Row s a :*: b) = a :*: Res b 126 | Res (Col s a) = a 127 | Res (Row s a) = a 128 | 129 | -- | An acceptable query result type; one or more columns stitched together 130 | -- with @:*:@. 131 | class Typeable (Res r) => Result r where 132 | -- | Converts the given list of @SqlValue@s into an tuple of well-typed 133 | -- results. 134 | -- See 'querySQLite' for example usage. 135 | toRes :: Proxy r -> ResultReader (Res r) 136 | 137 | -- | Produce a list of all columns present in the result. 138 | finalCols :: r -> [SomeCol SQL] 139 | 140 | instance (SqlType a, Result b) => Result (Col s a :*: b) where 141 | toRes _ = liftM2 (:*:) (fromSql <$> next) (toRes (Proxy :: Proxy b)) 142 | finalCols (a :*: b) = finalCols a ++ finalCols b 143 | 144 | instance (SqlRow a, Result b) => Result (Row s a :*: b) where 145 | toRes _ = liftM2 (:*:) nextResult (toRes (Proxy :: Proxy b)) 146 | finalCols (a :*: b) = finalCols a ++ finalCols b 147 | 148 | instance SqlType a => Result (Col s a) where 149 | toRes _ = fromSql <$> next 150 | finalCols (One c) = [Some c] 151 | 152 | instance SqlRow a => Result (Row s a) where 153 | toRes _ = nextResult 154 | finalCols (Many cs) = [Some c | Untyped c <- cs] 155 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Debug.hs: -------------------------------------------------------------------------------- 1 | -- | Functionality for inspecting and debugging Selda queries. 2 | module Database.Selda.Debug 3 | ( OnError (..), defPPConfig 4 | , compile 5 | , compileCreateTable, compileDropTable 6 | , compileInsert, compileUpdate 7 | ) where 8 | import Database.Selda.SQL.Print.Config ( defPPConfig ) 9 | import Database.Selda.Compile 10 | ( compile, compileInsert, compileUpdate ) 11 | import Database.Selda.Table.Compile 12 | ( OnError(..), compileCreateTable, compileDropTable ) 13 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Exp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances #-} 2 | {-# LANGUAGE CPP, DataKinds #-} 3 | -- | The expression type underlying 'Col'. 4 | module Database.Selda.Exp where 5 | import Database.Selda.SqlType ( Lit, SqlTypeRep ) 6 | import Database.Selda.Types ( ColName ) 7 | import Data.Text (Text) 8 | 9 | -- | A type-erased column, which may also be renamed. 10 | -- Only for internal use. 11 | data SomeCol sql where 12 | Some :: !(Exp sql a) -> SomeCol sql 13 | Named :: !ColName -> !(Exp sql a) -> SomeCol sql 14 | 15 | data UntypedCol sql where 16 | Untyped :: !(Exp sql a) -> UntypedCol sql 17 | 18 | -- | Turn a renamed column back into a regular one. 19 | -- If the column was renamed, it will be represented by a literal column, 20 | -- and not its original expression. 21 | hideRenaming :: SomeCol sql -> UntypedCol sql 22 | hideRenaming (Named n _) = Untyped (Col n) 23 | hideRenaming (Some c) = Untyped c 24 | 25 | -- | Underlying column expression type, parameterised over the type of 26 | -- SQL queries. 27 | data Exp sql a where 28 | Col :: !ColName -> Exp sql a 29 | Lit :: !(Lit a) -> Exp sql a 30 | BinOp :: !(BinOp a b c) -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c 31 | UnOp :: !(UnOp a b) -> !(Exp sql a) -> Exp sql b 32 | NulOp :: !(NulOp a) -> Exp sql a 33 | Fun2 :: !Text -> !(Exp sql a) -> !(Exp sql b) -> Exp sql c 34 | If :: !(Exp sql Bool) -> !(Exp sql a) -> !(Exp sql a) -> Exp sql a 35 | Cast :: !SqlTypeRep -> !(Exp sql a) -> Exp sql b 36 | Raw :: !Text -> Exp sql a 37 | AggrEx :: !Text -> !(Exp sql a) -> Exp sql b 38 | InList :: !(Exp sql a) -> ![Exp sql a] -> Exp sql Bool 39 | InQuery :: !(Exp sql a) -> !sql -> Exp sql Bool 40 | 41 | data NulOp a where 42 | Fun0 :: !Text -> NulOp a 43 | 44 | data UnOp a b where 45 | Abs :: UnOp a a 46 | Not :: UnOp Bool Bool 47 | Neg :: UnOp a a 48 | Sgn :: UnOp a a 49 | IsNull :: UnOp (Maybe a) Bool 50 | Fun :: !Text -> UnOp a b 51 | 52 | data BinOp a b c where 53 | Gt :: BinOp a a Bool 54 | Lt :: BinOp a a Bool 55 | Gte :: BinOp a a Bool 56 | Lte :: BinOp a a Bool 57 | Eq :: BinOp a a Bool 58 | Neq :: BinOp a a Bool 59 | And :: BinOp Bool Bool Bool 60 | Or :: BinOp Bool Bool Bool 61 | Add :: BinOp a a a 62 | Sub :: BinOp a a a 63 | Mul :: BinOp a a a 64 | Div :: BinOp a a a 65 | Like :: BinOp Text Text Bool 66 | CustomOp :: !Text -> BinOp a b c 67 | 68 | -- | Any type which may contain column names. 69 | class Names a where 70 | -- | Get all column names used in the given expression. 71 | allNamesIn :: a -> [ColName] 72 | 73 | instance Names a => Names [a] where 74 | allNamesIn = concatMap allNamesIn 75 | 76 | instance Names sql => Names (Exp sql a) where 77 | allNamesIn (Col n) = [n] 78 | allNamesIn (Lit _) = [] 79 | allNamesIn (BinOp _ a b) = allNamesIn a ++ allNamesIn b 80 | allNamesIn (UnOp _ a) = allNamesIn a 81 | allNamesIn (NulOp _) = [] 82 | allNamesIn (Fun2 _ a b) = allNamesIn a ++ allNamesIn b 83 | allNamesIn (If a b c) = allNamesIn a ++ allNamesIn b ++ allNamesIn c 84 | allNamesIn (Cast _ x) = allNamesIn x 85 | allNamesIn (AggrEx _ x) = allNamesIn x 86 | allNamesIn (InList x xs) = concatMap allNamesIn (x:xs) 87 | allNamesIn (InQuery x q) = allNamesIn x ++ allNamesIn q 88 | allNamesIn (Raw _) = [] 89 | 90 | instance Names sql => Names (SomeCol sql) where 91 | allNamesIn (Some c) = allNamesIn c 92 | allNamesIn (Named n c) = n : allNamesIn c 93 | 94 | instance Names sql => Names (UntypedCol sql) where 95 | allNamesIn (Untyped c) = allNamesIn c 96 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/FieldSelectors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, PolyKinds #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-} 4 | {-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-} 5 | {-# LANGUAGE TypeApplications, CPP #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | -- | Create Selda selectors from plain record field selectors. 8 | -- Requires the @OverloadedLabels@ language extension. 9 | module Database.Selda.FieldSelectors 10 | (FieldType, HasField, IsLabel 11 | ) where 12 | import Database.Selda.Generic (Relational) 13 | import Database.Selda.Selectors as S ( Selector, unsafeSelector ) 14 | import Database.Selda.SqlType (SqlType) 15 | import Data.Kind (Constraint) 16 | import GHC.Generics 17 | ( Generic(Rep), K1, M1, type (:*:), S, Meta(MetaSel) ) 18 | import GHC.TypeLits 19 | ( Symbol, TypeError, ErrorMessage(Text, (:<>:), ShowType) ) 20 | import GHC.OverloadedLabels ( IsLabel(..) ) 21 | 22 | -- | Get the next nested type. 23 | type family GetFieldType (f :: * -> *) :: * where 24 | GetFieldType (M1 c i f) = GetFieldType f 25 | GetFieldType (K1 i a) = a 26 | 27 | -- | Get the type of the field @name@ from the generic representation @a@, 28 | -- returning the default value @b@ if the field does not exist. 29 | type family GFieldType (a :: * -> *) (b :: *) (name :: Symbol) :: * where 30 | GFieldType (M1 S ('MetaSel ('Just name) su ss ds) f) b name = GetFieldType f 31 | GFieldType (M1 c i a) b name = GFieldType a b name 32 | GFieldType (a :*: b) c name = GFieldType a (GFieldType b c name) name 33 | GFieldType a b name = b 34 | 35 | -- | The type of the @name@ field, in the record type @t@. 36 | type FieldType name t = GFieldType (Rep t) (NoSuchSelector t name) name 37 | 38 | type family NonError (t :: k) :: Constraint where 39 | NonError (NoSuchSelector t s) = TypeError 40 | ( 'Text "Row type '" ':<>: 'ShowType t ':<>: 41 | 'Text "' has no selector " ':<>: 'ShowType s ':<>: 'Text "." 42 | ) 43 | NonError t = () 44 | 45 | -- | Internal representation of the "no such selector" error message. 46 | data NoSuchSelector (t :: *) (s :: Symbol) 47 | 48 | -- | Any table type @t@, which has a field named @name@. 49 | class ( Relational t 50 | , SqlType (FieldType name t) 51 | , GRSel name (Rep t) 52 | , NonError (FieldType name t)) => 53 | HasField (name :: Symbol) t 54 | 55 | instance ( Relational t 56 | , SqlType (FieldType name t) 57 | , GRSel name (Rep t) 58 | , NonError (FieldType name t)) => 59 | HasField (name :: Symbol) t 60 | 61 | instance (Relational t, HasField name t, FieldType name t ~ a) => 62 | IsLabel name (S.Selector t a) where 63 | 64 | fromLabel = field @name @t 65 | 66 | 67 | 68 | 69 | -- | Create a selector from a record selector and a type application. 70 | -- 71 | -- For example: 72 | -- > data Foo = Foo 73 | -- > { foo :: Int 74 | -- > , bar :: Text 75 | -- > } deriving Generic 76 | -- > instance SqlRow Foo 77 | -- > 78 | -- > fooTable :: Table Foo 79 | -- > fooTable = table "foo" 80 | -- > 81 | -- > getAllBars :: Query s (Col s Text) 82 | -- > getAllBars = do 83 | -- > t <- select fooTable 84 | -- > return (t ! field @"bar") 85 | field :: forall name t. 86 | (Relational t, HasField name t) 87 | => S.Selector t (FieldType name t) 88 | field = 89 | case gSel @name @(Rep t) 0 of 90 | Left n -> unsafeSelector n 91 | _ -> error "unreachable" 92 | 93 | class GRSel (s :: Symbol) (f :: * -> *) where 94 | gSel :: Int -> Either Int Int 95 | 96 | instance GRSel name (M1 S ('MetaSel ('Just name) su ss ds) f) where 97 | gSel = Left 98 | 99 | instance {-# OVERLAPPABLE #-} GRSel name f => GRSel name (M1 i s f) where 100 | gSel = gSel @name @f 101 | 102 | instance (GRSel name a, GRSel name b) => GRSel name (a :*: b) where 103 | gSel n = gSel @name @a n >>= gSel @name @b . succ 104 | 105 | instance GRSel name (K1 i a) where 106 | gSel = Right 107 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} 4 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-} 5 | {-# LANGUAGE GADTs, CPP, DataKinds #-} 6 | -- | Generics utilities. 7 | module Database.Selda.Generic 8 | ( Relational, Generic 9 | , tblCols, params, def, gNew, gRow 10 | ) where 11 | import Control.Monad.State 12 | ( liftM2, MonadState(put, get), evalState, State ) 13 | import Data.Dynamic ( Typeable ) 14 | import Data.Text as Text (Text, pack) 15 | 16 | import Data.Typeable ( Proxy(..), typeRep, typeRepTyCon ) 17 | 18 | import GHC.Generics 19 | ( Generic(from, Rep), Selector(selName), K1(K1), M1(M1), S ) 20 | import qualified GHC.Generics as G 21 | ( (:*:)(..), Selector, (:+:)(..) ) 22 | import qualified GHC.TypeLits as TL 23 | import qualified Database.Selda.Column as C (Col) 24 | import Control.Exception (Exception (..), try, throw) 25 | import System.IO.Unsafe ( unsafePerformIO ) 26 | import Database.Selda.Types ( ColName, modColName, mkColName ) 27 | import Database.Selda.SqlType 28 | ( Lit, SqlType(sqlType, defaultValue, mkLit) ) 29 | import Database.Selda.SqlRow (SqlRow) 30 | import Database.Selda.Table.Type 31 | ( ColAttr(Required, Optional), ColInfo(..) ) 32 | import Database.Selda.SQL (Param (..)) 33 | import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..)) 34 | 35 | 36 | 37 | 38 | -- | Any type which has a corresponding relation. 39 | -- To make a @Relational@ instance for some type, simply derive 'Generic'. 40 | -- 41 | -- Note that only types which have a single data constructor, and where all 42 | -- fields are instances of 'SqlValue' can be used with this module. 43 | -- Attempting to use functions in this module with any type which doesn't 44 | -- obey those constraints will result in a very confusing type error. 45 | type Relational a = 46 | ( Generic a 47 | , SqlRow a 48 | , GRelation (Rep a) 49 | ) 50 | 51 | -- | Extract all insert parameters from a generic value. 52 | params :: Relational a => a -> [Either Param Param] 53 | params = unsafePerformIO . gParams . from 54 | 55 | -- | Extract all column names from the given type. 56 | -- If the type is not a record, the columns will be named @col_1@, 57 | -- @col_2@, etc. 58 | tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo] 59 | tblCols _ fieldMod = 60 | evalState (gTblCols (Proxy :: Proxy (Rep a)) Nothing rename) 0 61 | where 62 | rename n Nothing = mkColName $ fieldMod ("col_" <> pack (show n)) 63 | rename _ (Just name) = modColName name fieldMod 64 | 65 | -- | Exception indicating the use of a default value. 66 | -- If any values throwing this during evaluation of @param xs@ will be 67 | -- replaced by their default value. 68 | data DefaultValueException = DefaultValueException 69 | deriving Show 70 | instance Exception DefaultValueException 71 | 72 | -- | The default value for a column during insertion. 73 | -- For an auto-incrementing primary key, the default value is the next key. 74 | -- 75 | -- Using @def@ in any other context than insertion results in a runtime error. 76 | def :: SqlType a => a 77 | def = throw DefaultValueException 78 | 79 | class GRelation f where 80 | -- | Generic worker for 'params'. 81 | gParams :: f a -> IO [Either Param Param] 82 | 83 | -- | Compute all columns needed to represent the given type. 84 | gTblCols :: Proxy f 85 | -> Maybe ColName 86 | -> (Int -> Maybe ColName -> ColName) 87 | -> State Int [ColInfo] 88 | 89 | -- | Create a new value with all default fields. 90 | gNew :: Proxy f -> [UntypedCol sql] 91 | 92 | -- | Create a new row from the given value. 93 | gRow :: f a -> [UntypedCol sql] 94 | 95 | instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where 96 | gParams (M1 x) = gParams x 97 | gTblCols _ = gTblCols (Proxy :: Proxy a) 98 | gNew _ = gNew (Proxy :: Proxy a) 99 | gRow (M1 x) = gRow x 100 | 101 | instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) => 102 | GRelation (M1 S c a) where 103 | gParams (M1 x) = gParams x 104 | gTblCols _ _ = gTblCols (Proxy :: Proxy a) name 105 | where 106 | name = 107 | case selName ((M1 undefined) :: M1 S c a b) of 108 | "" -> Nothing 109 | s -> Just (mkColName $ pack s) 110 | gNew _ = gNew (Proxy :: Proxy a) 111 | gRow (M1 x) = gRow x 112 | 113 | instance (Typeable a, SqlType a) => GRelation (K1 i a) where 114 | gParams (K1 x) = do 115 | res <- try $ return $! x 116 | return $ case res of 117 | Right x' -> [Right $ Param (mkLit x')] 118 | Left DefaultValueException -> [Left $ Param (defaultValue :: Lit a)] 119 | 120 | gTblCols _ name rename = do 121 | n <- get 122 | put (n+1) 123 | let name' = rename n name 124 | return 125 | [ ColInfo 126 | { colName = name' 127 | , colType = sqlType (Proxy :: Proxy a) 128 | , colAttrs = optReq 129 | , colFKs = [] 130 | , colExpr = Untyped (Col name') 131 | } 132 | ] 133 | where 134 | -- workaround for GHC 8.2 not resolving overlapping instances properly 135 | maybeTyCon = typeRepTyCon (typeRep (Proxy :: Proxy (Maybe ()))) 136 | optReq 137 | | typeRepTyCon (typeRep (Proxy :: Proxy a)) == maybeTyCon = [Optional] 138 | | otherwise = [Required] 139 | 140 | gNew _ = [Untyped (Lit (defaultValue :: Lit a))] 141 | gRow (K1 x) = [Untyped (Lit (mkLit x))] 142 | 143 | instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where 144 | gParams (a G.:*: b) = liftM2 (++) (gParams a) (gParams b) 145 | gTblCols _ _ rename = do 146 | as <- gTblCols a Nothing rename 147 | bs <- gTblCols b Nothing rename 148 | return (as ++ bs) 149 | where 150 | a = Proxy :: Proxy a 151 | b = Proxy :: Proxy b 152 | gNew _ = gNew (Proxy :: Proxy a) ++ gNew (Proxy :: Proxy b) 153 | gRow (a G.:*: b) = gRow a ++ gRow b 154 | 155 | instance 156 | (TL.TypeError 157 | ( 'TL.Text "Selda currently does not support creating tables from sum types." 158 | 'TL.:$$: 159 | 'TL.Text "Restrict your table type to a single data constructor." 160 | )) => GRelation (a G.:+: b) where 161 | gParams = error "unreachable" 162 | gTblCols = error "unreachable" 163 | gNew = error "unreachable" 164 | gRow = error "unreachable" 165 | 166 | instance {-# OVERLAPS #-} 167 | (TL.TypeError 168 | ( 'TL.Text "Columns are now allowed to nest other columns." 169 | 'TL.:$$: 170 | 'TL.Text "Remove any fields of type 'Col s a' from your table type." 171 | )) => GRelation (K1 i (C.Col s a)) where 172 | gParams = error "unreachable" 173 | gTblCols = error "unreachable" 174 | gNew = error "unreachable" 175 | gRow = error "unreachable" 176 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Inner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, FlexibleContexts #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE CPP, DataKinds, UndecidableInstances #-} 4 | -- | Helpers for working with inner queries. 5 | module Database.Selda.Inner where 6 | import Database.Selda.Column 7 | ( Exp(AggrEx), UntypedCol(..), Row, Col(..) ) 8 | import Database.Selda.SQL (SQL) 9 | import Database.Selda.SqlType (SqlType) 10 | import Database.Selda.Types ( type (:*:)(..) ) 11 | import Data.Text (Text) 12 | import Data.Typeable ( Typeable ) 13 | import GHC.TypeLits as TL ( TypeError, ErrorMessage(Text, (:$$:)) ) 14 | 15 | -- | A single aggregate column. 16 | -- Aggregate columns may not be used to restrict queries. 17 | -- When returned from an 'aggregate' subquery, an aggregate column is 18 | -- converted into a non-aggregate column. 19 | newtype Aggr s a = Aggr {unAggr :: Exp SQL a} 20 | 21 | -- | Lift a function over columns to aggregates. 22 | liftAggr :: (Col s a -> Col s b) -> Aggr s a -> Aggr s b 23 | liftAggr f = Aggr . unOne . f . One . unAggr 24 | where unOne (One x) = x 25 | 26 | -- | Denotes an inner query. 27 | -- For aggregation, treating sequencing as the cartesian product of queries 28 | -- does not work well. 29 | -- Instead, we treat the sequencing of 'aggregate' with other 30 | -- queries as the cartesian product of the aggregated result of the query, 31 | -- a small but important difference. 32 | -- 33 | -- However, for this to work, the aggregate query must not depend on any 34 | -- columns in the outer product. Therefore, we let the aggregate query be 35 | -- parameterized over @Inner s@ if the parent query is parameterized over @s@, 36 | -- to enforce this separation. 37 | data Inner s 38 | deriving Typeable 39 | 40 | -- | Create a named aggregate function. 41 | -- Like 'fun', this function is generally unsafe and should ONLY be used 42 | -- to implement missing backend-specific functionality. 43 | aggr :: SqlType a => Text -> Col s a -> Aggr s b 44 | aggr f (One x) = Aggr (AggrEx f x) 45 | 46 | -- | Convert one or more inner column to equivalent columns in the outer query. 47 | -- @OuterCols (Aggr (Inner s) a :*: Aggr (Inner s) b) = Col s a :*: Col s b@, 48 | -- for instance. 49 | type family OuterCols a where 50 | OuterCols (Col (Inner s) a :*: b) = Col s a :*: OuterCols b 51 | OuterCols (Col (Inner s) a) = Col s a 52 | OuterCols (Row (Inner s) a :*: b) = Row s a :*: OuterCols b 53 | OuterCols (Row (Inner s) a) = Row s a 54 | OuterCols (Col s a) = TypeError 55 | ( 'TL.Text "An inner query can only return rows and columns from its own scope." 56 | ) 57 | OuterCols (Row s a) = TypeError 58 | ( 'TL.Text "An inner query can only return rows and columns from its own scope." 59 | ) 60 | OuterCols a = TypeError 61 | ( 'TL.Text "Only (inductive tuples of) row and columns can be returned from" ':$$: 62 | 'TL.Text "an inner query." 63 | ) 64 | 65 | type family AggrCols a where 66 | AggrCols (Aggr (Inner s) a :*: b) = Col s a :*: AggrCols b 67 | AggrCols (Aggr (Inner s) a) = Col s a 68 | AggrCols (Aggr s a) = TypeError 69 | ( 'TL.Text "An aggregate query can only return columns from its own" ':$$: 70 | 'TL.Text "scope." 71 | ) 72 | AggrCols a = TypeError 73 | ( 'TL.Text "Only (inductive tuples of) aggregates can be returned from" ':$$: 74 | 'TL.Text "an aggregate query." 75 | ) 76 | 77 | -- | The results of a left join are always nullable, as there is no guarantee 78 | -- that all joined columns will be non-null. 79 | -- @JoinCols a@ where @a@ is an extensible tuple is that same tuple, but in 80 | -- the outer query and with all elements nullable. 81 | -- For instance: 82 | -- 83 | -- > LeftCols (Col (Inner s) Int :*: Col (Inner s) Text) 84 | -- > = Col s (Maybe Int) :*: Col s (Maybe Text) 85 | type family LeftCols a where 86 | LeftCols (Col (Inner s) (Maybe a) :*: b) = Col s (Maybe a) :*: LeftCols b 87 | LeftCols (Col (Inner s) a :*: b) = Col s (Maybe a) :*: LeftCols b 88 | LeftCols (Col (Inner s) (Maybe a)) = Col s (Maybe a) 89 | LeftCols (Col (Inner s) a) = Col s (Maybe a) 90 | 91 | LeftCols (Row (Inner s) (Maybe a) :*: b) = Row s (Maybe a) :*: LeftCols b 92 | LeftCols (Row (Inner s) a :*: b) = Row s (Maybe a) :*: LeftCols b 93 | LeftCols (Row (Inner s) (Maybe a)) = Row s (Maybe a) 94 | LeftCols (Row (Inner s) a) = Row s (Maybe a) 95 | LeftCols a = TypeError 96 | ( 'TL.Text "Only (inductive tuples of) rows and columns can be returned" ':$$: 97 | 'TL.Text "from a join." 98 | ) 99 | 100 | -- | One or more aggregate columns. 101 | class Aggregates a where 102 | unAggrs :: a -> [UntypedCol SQL] 103 | instance Aggregates (Aggr (Inner s) a) where 104 | unAggrs (Aggr x) = [Untyped x] 105 | instance Aggregates b => Aggregates (Aggr (Inner s) a :*: b) where 106 | unAggrs (Aggr a :*: b) = Untyped a : unAggrs b 107 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/MakeSelectors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TypeOperators #-} 2 | {-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} 4 | -- | Utilities for creating selectors for non-record types. 5 | -- In general, you should really use record types for your tables and 6 | -- their record labels (i.e. #label) as selectors using 7 | -- the @OverloadedLabels@ extension instead. 8 | module Database.Selda.MakeSelectors 9 | ( Selectors, GSelectors 10 | , selectors, tableWithSelectors 11 | ) where 12 | import Control.Monad.State.Strict 13 | ( MonadState(state), State, evalState ) 14 | import Data.Proxy ( Proxy(..) ) 15 | import GHC.Generics ( Generic(Rep), K1, M1 ) 16 | import qualified GHC.Generics as G 17 | import Database.Selda.Generic (Relational) 18 | import Database.Selda.Selectors ( Selector, unsafeSelector ) 19 | import Database.Selda.SqlRow ( SqlRow ) 20 | import Database.Selda.SqlType ( SqlType ) 21 | import Database.Selda.Table ( Table, Attr, table ) 22 | import Database.Selda.Types ( type (:*:)(..), TableName ) 23 | 24 | -- | Generate selector functions for the given table. 25 | -- Selectors can be used to access the fields of a query result tuple, avoiding 26 | -- the need to pattern match on the entire tuple. 27 | -- 28 | -- > tbl :: Table (Int, Text) 29 | -- > tbl = table "foo" [] 30 | -- > (tblBar :*: tblBaz) = selectors tbl 31 | -- > 32 | -- > q :: Query s Text 33 | -- > q = do 34 | -- > row <- select tbl 35 | -- > return (row ! tblBaz) 36 | selectors :: forall a. (Relational a, GSelectors a (Rep a)) 37 | => Table a 38 | -> Selectors a 39 | selectors _ = selectorsFor (Proxy :: Proxy a) 40 | 41 | -- | A pair of the table with the given name and columns, and all its selectors. 42 | -- For example: 43 | -- 44 | -- > tbl :: Table (Int, Text) 45 | -- > (tbl, tblBar :*: tblBaz) 46 | -- > = tableWithSelectors "foo" [] 47 | -- > 48 | -- > q :: Query s Text 49 | -- > q = tblBaz `from` select tbl 50 | tableWithSelectors :: forall a. (Relational a, GSelectors a (Rep a)) 51 | => TableName 52 | -> [Attr a] 53 | -> (Table a, Selectors a) 54 | tableWithSelectors name cs = (t, s) 55 | where 56 | t = table name cs 57 | s = selectors t 58 | 59 | -- | Generate selectors for the given type. 60 | selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r 61 | selectorsFor = flip evalState 0 . mkSel (Proxy :: Proxy (Rep r)) 62 | 63 | -- | An inductive tuple of selectors for the given relation. 64 | type Selectors r = Sels r (Rep r) 65 | 66 | type family Sels t f where 67 | Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c)) 68 | Sels t (a G.:*: b) = Sels t a :*: Sels t b 69 | Sels t (M1 x y f) = Sels t f 70 | Sels t (K1 i a) = Selector t a 71 | 72 | -- | Any table type that can have selectors generated. 73 | class GSelectors t (f :: * -> *) where 74 | mkSel :: Proxy f -> Proxy t -> State Int (Sels t f) 75 | 76 | instance (SqlRow t, SqlType a) => GSelectors t (K1 i a) where 77 | mkSel _ _ = unsafeSelector <$> state (\n -> (n, n+1)) 78 | 79 | instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) => 80 | GSelectors t (M1 x y f) where 81 | mkSel _ = mkSel (Proxy :: Proxy f) 82 | 83 | instance GSelectors t (a G.:*: (b G.:*: c)) => 84 | GSelectors t ((a G.:*: b) G.:*: c) where 85 | mkSel _ = mkSel (Proxy :: Proxy (a G.:*: (b G.:*: c))) 86 | 87 | instance {-# OVERLAPPABLE #-} 88 | ( GSelectors t a 89 | , GSelectors t b 90 | , Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b) 91 | ) => GSelectors t (a G.:*: b) where 92 | mkSel _ p = do 93 | x <- mkSel (Proxy :: Proxy a) p 94 | xs <- mkSel (Proxy :: Proxy b) p 95 | return (x :*: xs) 96 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Migrations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} 2 | -- | Functionality for upgrading a table from one schema to another. 3 | module Database.Selda.Migrations 4 | ( Migration (..) 5 | , migrate, migrateM, migrateAll, autoMigrate 6 | ) where 7 | import Control.Monad (void, when) 8 | import Control.Monad.Catch ( MonadMask, MonadThrow(..) ) 9 | import Database.Selda.Backend.Internal 10 | ( MonadSelda(..), SeldaBackend(runStmt), withBackend ) 11 | import Database.Selda.Column ( Row ) 12 | import Database.Selda.Frontend 13 | ( MonadIO(liftIO), 14 | queryInto, 15 | transaction, 16 | withoutForeignKeyEnforcement, 17 | OnError(..), 18 | createTableWithoutIndexes, 19 | createTableIndexes ) 20 | import Database.Selda.Generic ( Relational ) 21 | import Database.Selda.Query ( select ) 22 | import Database.Selda.Query.Type ( Query ) 23 | import Database.Selda.Table.Type ( Table(..) ) 24 | import Database.Selda.Table.Validation (ValidationError (..)) 25 | import Database.Selda.Types (mkTableName, fromTableName, rawTableName) 26 | import Database.Selda.Validation 27 | ( TableDiff(TableOK), validateTable, validateSchema, diffTable ) 28 | 29 | -- | Wrapper for user with 'migrateAll', enabling multiple migrations to be 30 | -- packed into the same list: 31 | -- 32 | -- > migrateAll 33 | -- > [ Migration m1_from m1_to m1_upgrade 34 | -- > , Migration m2_from m2_to m2_upgrade 35 | -- > , ... 36 | -- > ] 37 | data Migration backend where 38 | Migration :: (Relational a, Relational b) 39 | => Table a 40 | -> Table b 41 | -> (Row backend a -> Query backend (Row backend b)) 42 | -> Migration backend 43 | 44 | -- | A migration step is zero or more migrations that need to be performed in 45 | -- a single transaction in order to keep the database consistent. 46 | type MigrationStep backend = [Migration backend] 47 | 48 | -- | Migrate the first table into the second, using the given function to 49 | -- migrate all records to the new schema. 50 | -- Both table schemas are validated before starting the migration, and the 51 | -- source table is validated against what's currently in the database. 52 | -- 53 | -- The migration is performed as a transaction, ensuring that either the 54 | -- entire migration passes, or none of it does. 55 | migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b) 56 | => Table a -- ^ Table to migrate from. 57 | -> Table b -- ^ Table to migrate to. 58 | -> (Row (Backend m) a -> Row (Backend m) b) 59 | -- ^ Mapping from old to new table. 60 | -> m () 61 | migrate t1 t2 upg = migrateM t1 t2 (pure . upg) 62 | 63 | -- | Like 'migrate', but allows the column upgrade to access 64 | -- the entire database. 65 | migrateM :: (MonadSelda m, MonadMask m, Relational a, Relational b) 66 | => Table a 67 | -> Table b 68 | -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)) 69 | -> m () 70 | migrateM t1 t2 upg = migrateAll True [Migration t1 t2 upg] 71 | 72 | wrap :: (MonadSelda m, MonadMask m) => Bool -> m a -> m a 73 | wrap enforceFKs 74 | | enforceFKs = transaction 75 | | otherwise = withoutForeignKeyEnforcement 76 | 77 | -- | Perform all given migrations as a single transaction. 78 | migrateAll :: (MonadSelda m, MonadMask m) 79 | => Bool -- ^ Enforce foreign keys during migration? 80 | -> MigrationStep (Backend m) -- ^ Migration step to perform. 81 | -> m () 82 | migrateAll fks = 83 | wrap fks . mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg) 84 | 85 | -- | Given a list of migration steps in ascending chronological order, finds 86 | -- the latest migration step starting state that matches the current database, 87 | -- and performs all migrations from that point until the end of the list. 88 | -- The whole operation is performed as a single transaction. 89 | -- 90 | -- If no matching starting state is found, a 'ValidationError' is thrown. 91 | -- If the database is already in the state specified by the end state of the 92 | -- final step, no migration is performed. 93 | -- 94 | -- Note that when looking for a matching starting state, index methods for 95 | -- indexed columns are not taken into account. Two columns @c1@ and @c2@ are 96 | -- considered to be identical if @c1@ is indexed with index method @foo@ and 97 | -- @c2@ is indexed with index method @bar@. 98 | autoMigrate :: (MonadSelda m, MonadMask m) 99 | => Bool -- ^ Enforce foreign keys during migration? 100 | -> [MigrationStep (Backend m)] -- ^ Migration steps to perform. 101 | -> m () 102 | autoMigrate _ [] = do 103 | return () 104 | autoMigrate fks steps = wrap fks $ do 105 | diffs <- sequence finalState 106 | when (any (/= TableOK) diffs) $ do 107 | steps' <- reverse <$> calculateSteps revSteps 108 | mapM_ performStep steps' 109 | where 110 | revSteps = reverse steps 111 | finalState = [diffTable to | Migration _ to _ <- head revSteps] 112 | 113 | calculateSteps (step:ss) = do 114 | diffs <- mapM (\(Migration from _ _) -> diffTable from) step 115 | if all (== TableOK) diffs 116 | then return [step] 117 | else (step:) <$> calculateSteps ss 118 | calculateSteps [] = do 119 | throwM $ ValidationError "no starting state matches the current state of the database" 120 | 121 | performStep = mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg) 122 | 123 | -- | Workhorse for migration. 124 | -- Is NOT performed as a transaction, so exported functions need to 125 | -- properly wrap calls this function. 126 | migrateInternal :: (MonadSelda m, MonadThrow m, Relational a, Relational b) 127 | => Table a 128 | -> Table b 129 | -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)) 130 | -> m () 131 | migrateInternal t1 t2 upg = withBackend $ \b -> do 132 | validateTable t1 133 | validateSchema t2 134 | createTableWithoutIndexes Fail t2' 135 | void . queryInto t2' $ select t1 >>= upg 136 | void . liftIO $ runStmt b (dropQuery (tableName t1)) [] 137 | void . liftIO $ runStmt b renameQuery [] 138 | createTableIndexes Fail t2 139 | where 140 | t2' = t2 {tableName = mkTableName newName} `asTypeOf` t2 141 | newName = mconcat ["__selda_migration_", rawTableName (tableName t2)] 142 | renameQuery = mconcat 143 | [ "ALTER TABLE ", newName 144 | , " RENAME TO ", fromTableName (tableName t2), ";" 145 | ] 146 | dropQuery t = mconcat ["DROP TABLE ", fromTableName t, ";"] 147 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Nullable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, ConstraintKinds, FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | -- | Convenience facilities for working with nullable columns. 4 | module Database.Selda.Nullable 5 | ( NonNull, (:?~) 6 | , nonNull, restrict', (?!) 7 | , (?==), (?/=), (?>), (?<), (?>=), (?<=), (?+), (?-), (?*), (?/) 8 | ) where 9 | import Database.Selda 10 | ( SqlType, 11 | Same, 12 | Row, 13 | Col, 14 | Selector, 15 | Coalesce, 16 | Query, 17 | restrict, 18 | SqlOrd, 19 | (.==), 20 | (./=), 21 | (.>), 22 | (.<), 23 | (.>=), 24 | (.<=), 25 | isNull, 26 | not_ ) 27 | import Database.Selda.Unsafe (cast) 28 | import Database.Selda.Selectors ( Selector(selectorIndex) ) 29 | import Database.Selda.Column 30 | ( UntypedCol(Untyped), Row(Many), Col(One) ) 31 | import Unsafe.Coerce ( unsafeCoerce ) 32 | 33 | -- | Two SQL types which are identical modulo nullability. 34 | type a :?~ b = 35 | ( NonNull a ~ NonNull b 36 | , SqlType (NonNull a) 37 | , SqlType (NonNull b) 38 | ) 39 | 40 | type family NonNull a where 41 | NonNull (Maybe a) = a 42 | NonNull a = a 43 | 44 | -- | Unconditionally convert a nullable value into a non-nullable one, 45 | -- using the standard SQL null-coalescing behavior. 46 | fromNullable :: SqlType (NonNull a) => Col s a -> Col s (NonNull a) 47 | fromNullable = unsafeCoerce 48 | 49 | (?==), (?/=) :: (a :?~ b, SqlType a, Same s t) => Col s a -> Col t b -> Col s (Maybe Bool) 50 | 51 | (?>), (?<), (?>=), (?<=) :: (a :?~ b, SqlOrd (NonNull a), Same s t) 52 | => Col s a -> Col t b -> Col s (Maybe Bool) 53 | 54 | (?+), (?-), (?*) :: (a :?~ b, Num (NonNull a), Same s t) 55 | => Col s a -> Col t b -> Col s (Maybe (NonNull a)) 56 | 57 | (?/) :: (a :?~ b, Fractional (Col s (NonNull a)), Same s t) 58 | => Col s a -> Col t b -> Col s (Maybe (NonNull a)) 59 | 60 | a ?== b = cast $ fromNullable a .== fromNullable b 61 | a ?/= b = cast $ fromNullable a ./= fromNullable b 62 | a ?> b = cast $ fromNullable a .> fromNullable b 63 | a ?< b = cast $ fromNullable a .< fromNullable b 64 | a ?>= b = cast $ fromNullable a .>= fromNullable b 65 | a ?<= b = cast $ fromNullable a .<= fromNullable b 66 | a ?+ b = cast $ fromNullable a + fromNullable b 67 | a ?- b = cast $ fromNullable a - fromNullable b 68 | a ?* b = cast $ fromNullable a * fromNullable b 69 | a ?/ b = cast $ fromNullable a / fromNullable b 70 | infixl 4 ?== 71 | infixl 4 ?/= 72 | infixl 4 ?> 73 | infixl 4 ?< 74 | infixl 4 ?>= 75 | infixl 4 ?<= 76 | infixl 6 ?+ 77 | infixl 6 ?- 78 | infixl 7 ?* 79 | infixl 7 ?/ 80 | 81 | -- | Selector indexing, overloaded to work on nullable as well as non-nullable 82 | -- rows. 83 | (?!) :: forall s t a. SqlType a 84 | => Row s t -> Selector (NonNull t) a -> Col s (Coalesce (Maybe a)) 85 | (Many xs) ?! i = case xs !! (selectorIndex i) of Untyped x -> One (unsafeCoerce x) 86 | infixl 9 ?! 87 | 88 | -- | Converts a nullable column into a non-nullable one, yielding the empty 89 | -- result set if the column is null. 90 | nonNull :: (Same s t, SqlType a) => Col s (Maybe a) -> Query t (Col t a) 91 | nonNull x = do 92 | restrict (not_ $ isNull x) 93 | return (fromNullable x) 94 | 95 | -- | Restrict a query using a nullable expression. 96 | -- Equivalent to @restrict . ifNull false@. 97 | restrict' :: Same s t => Col s (Maybe Bool) -> Query t () 98 | restrict' = restrict . fromNullable 99 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Prepared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- | Building and executing prepared statements. 5 | module Database.Selda.Prepared (Preparable, Prepare, prepared) where 6 | import Database.Selda.Backend.Internal 7 | ( Lit(LCustom), 8 | SqlType(sqlType), 9 | SqlTypeRep, 10 | Param(..), 11 | MonadSelda(Backend, withConnection), 12 | SeldaBackend(ppConfig, runPrepared, backendId, prepareStmt), 13 | SeldaConnection(connBackend, connStmts), 14 | SeldaStmt(SeldaStmt, stmtHandle, stmtParams, stmtText), 15 | StmtID(..), 16 | BackendID, 17 | freshStmtId, 18 | withBackend ) 19 | import Database.Selda.Column ( Exp(Lit), Col(..) ) 20 | import Database.Selda.Compile 21 | ( Result, Res, compileWith, buildResult ) 22 | import Database.Selda.Query.Type ( Query ) 23 | import Database.Selda.SQL (param, paramType) 24 | import Control.Exception ( Exception, try, throw, mask ) 25 | import Control.Monad.IO.Class ( MonadIO(liftIO) ) 26 | import qualified Data.IntMap as M 27 | import Data.IORef 28 | ( IORef, atomicModifyIORef', newIORef, readIORef, writeIORef ) 29 | import Data.Proxy ( Proxy(..) ) 30 | import Data.Text (Text) 31 | import Data.Typeable ( Typeable ) 32 | import System.IO.Unsafe ( unsafePerformIO ) 33 | 34 | data Placeholder = Placeholder Int 35 | deriving Show 36 | instance Exception Placeholder 37 | 38 | -- | Index of first argument parameter to a query. 39 | firstParamIx :: Int 40 | firstParamIx = 0 41 | 42 | -- | Result type of a monadic computation. 43 | type family ResultT f where 44 | ResultT (a -> b) = ResultT b 45 | ResultT (m a) = a 46 | 47 | type family Equiv q f where 48 | Equiv (Col s a -> q) (a -> f) = Equiv q f 49 | Equiv (Query s a) (m [b]) = (Res a ~ b, Backend m ~ s) 50 | 51 | type CompResult = (Text, [Either Int Param], [SqlTypeRep]) 52 | 53 | class Preparable q where 54 | -- | Prepare the query and parameter list. 55 | mkQuery :: MonadSelda m 56 | => Int -- ^ Next argument index. 57 | -> q -- ^ The query. 58 | -> [SqlTypeRep] -- ^ The list of param types so far. 59 | -> m CompResult 60 | 61 | -- | Some parameterized query @q@ that can be prepared into a function @f@ 62 | -- in some @MonadSelda@. 63 | class Prepare q f where 64 | -- | Build the function that prepares and execute the query. 65 | mkFun :: Preparable q 66 | => IORef (Maybe (BackendID, CompResult)) 67 | -> StmtID 68 | -> q 69 | -> [Param] 70 | -> f 71 | 72 | instance (SqlType a, Prepare q b) => Prepare q (a -> b) where 73 | mkFun ref sid qry ps x = mkFun ref sid qry (param x : ps) 74 | 75 | instance (Typeable a, MonadSelda m, a ~ Res (ResultT q), Result (ResultT q)) => 76 | Prepare q (m [a]) where 77 | -- This function uses read/writeIORef instead of atomicModifyIORef. 78 | -- For once, this is actually safe: the IORef points to a single compiled 79 | -- statement, so the only consequence of a race between the read and the write 80 | -- is that the statement gets compiled (note: NOT prepared) twice. 81 | mkFun ref (StmtID sid) qry arguments = withConnection $ \conn -> do 82 | let backend = connBackend conn 83 | args = reverse arguments 84 | stmts <- liftIO $ readIORef (connStmts conn) 85 | case M.lookup sid stmts of 86 | Just stm -> do 87 | -- Statement already prepared for this connection; just execute it. 88 | liftIO $ runQuery conn stm args 89 | _ -> do 90 | -- Statement wasn't prepared for this connection; check if it was at 91 | -- least previously compiled for this backend. 92 | compiled <- liftIO $ readIORef ref 93 | (q, params, reps) <- case compiled of 94 | Just (bid, comp) | bid == backendId backend -> do 95 | return comp 96 | _ -> do 97 | comp <- mkQuery firstParamIx qry [] 98 | liftIO $ writeIORef ref (Just (backendId backend, comp)) 99 | return comp 100 | 101 | -- Prepare and execute 102 | liftIO $ mask $ \restore -> do 103 | hdl <- prepareStmt backend (StmtID sid) reps q 104 | let stm = SeldaStmt 105 | { stmtHandle = hdl 106 | , stmtParams = params 107 | , stmtText = q 108 | } 109 | atomicModifyIORef' (connStmts conn) $ \m -> (M.insert sid stm m, ()) 110 | restore $ runQuery conn stm args 111 | where 112 | runQuery conn stm args = do 113 | let ps = replaceParams (stmtParams stm) args 114 | hdl = stmtHandle stm 115 | res <- runPrepared (connBackend conn) hdl ps 116 | return $ map (buildResult (Proxy :: Proxy (ResultT q))) (snd res) 117 | 118 | instance (SqlType a, Preparable b) => Preparable (Col s a -> b) where 119 | mkQuery n f ts = mkQuery (n+1) (f x) (t : ts) 120 | where 121 | t = sqlType (Proxy :: Proxy a) 122 | x = One $ Lit $ LCustom t (throw (Placeholder n) :: Lit a) 123 | 124 | instance Result a => Preparable (Query s a) where 125 | mkQuery _ q types = withBackend $ \b -> do 126 | case compileWith (ppConfig b) q of 127 | (q', ps) -> do 128 | (ps', types') <- liftIO $ inspectParams (reverse types) ps 129 | return (q', ps', types') 130 | 131 | -- | Create a prepared Selda function. A prepared function has zero or more 132 | -- arguments, and will get compiled into a prepared statement by the first 133 | -- backend to execute it. Any subsequent calls to the function for the duration 134 | -- of the connection to the database will reuse the prepared statement. 135 | -- 136 | -- Preparable functions are of the form 137 | -- @(SqlType a, SqlType b, ...) => Col s a -> Col s b -> ... -> Query s r@. 138 | -- The resulting prepared function will be of the form 139 | -- @MonadSelda m => a -> b -> ... -> m [Res r]@. 140 | -- Note, however, that when using @prepared@, you must give a concrete type 141 | -- for @m@ due to how Haskell's type class resolution works. 142 | -- 143 | -- Prepared functions rely on memoization for just-in-time preparation and 144 | -- caching. This means that if GHC accidentally inlines your prepared function, 145 | -- it may get prepared twice. 146 | -- While this does not affect the correctness of your program, and is 147 | -- fairly unlikely to happen, if you want to be absolutely sure that your 148 | -- queries aren't re-prepared more than absolutely necessary, 149 | -- consider adding a @NOINLINE@ annotation to each prepared function. 150 | -- 151 | -- Note that when using a constrained backend type variable (i.e. 152 | -- @foo :: Bar b => SeldaM b [Int]@), optimizations must be enabled for 153 | -- prepared statements to be effective. 154 | -- 155 | -- A usage example: 156 | -- 157 | -- > persons :: Table (Text, Int) 158 | -- > (persons, name :*: age) = tableWithSelectors "ages" [name :- primary] 159 | -- > 160 | -- > {-# NOINLINE ageOf #-} 161 | -- > ageOf :: Text -> SeldaM [Int] 162 | -- > ageOf = prepared $ \n -> do 163 | -- > person <- select ages 164 | -- > restrict $ (person!name .== n) 165 | -- > return age 166 | {-# NOINLINE prepared #-} 167 | prepared :: (Preparable q, Prepare q f, Equiv q f) => q -> f 168 | prepared q = unsafePerformIO $ do 169 | ref <- newIORef Nothing 170 | sid <- freshStmtId 171 | return $ mkFun ref sid q [] 172 | 173 | -- | Replace every indexed parameter with the corresponding provided parameter. 174 | -- Keep all non-indexed parameters in place. 175 | replaceParams :: [Either Int Param] -> [Param] -> [Param] 176 | replaceParams params = map fromRight . go firstParamIx params 177 | where 178 | go n ps (x:xs) = go (n+1) (map (subst n x) ps) xs 179 | go _ ps _ = ps 180 | 181 | subst n x (Left n') | n == n' = Right x 182 | subst _ _ old = old 183 | 184 | fromRight (Right x) = x 185 | fromRight _ = error "BUG: query parameter not substituted!" 186 | 187 | -- | Inspect a list of parameters, denoting each parameter with either a 188 | -- placeholder index or a literal parameter. 189 | inspectParams :: [SqlTypeRep] -> [Param] -> IO ([Either Int Param], [SqlTypeRep]) 190 | inspectParams ts (x:xs) = do 191 | res <- try $ pure $! forceParam x 192 | let (x', t) = case res of 193 | Right p -> (Right p, paramType p) 194 | Left (Placeholder ix) -> (Left ix, ts !! ix) 195 | (xs', ts') <- inspectParams ts xs 196 | return (x' : xs', t : ts') 197 | inspectParams _ [] = do 198 | return ([], []) 199 | 200 | -- | Force a parameter deep enough to determine whether it is a placeholder. 201 | forceParam :: Param -> Param 202 | forceParam p@(Param (LCustom _ x)) | x `seq` True = p 203 | forceParam p = p 204 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Query/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, CPP #-} 2 | module Database.Selda.Query.Type where 3 | import Control.Monad.State.Strict 4 | ( StateT(StateT), MonadState(put, get), State, runState ) 5 | import Data.Text (pack) 6 | import Database.Selda.SQL ( SQL ) 7 | import Database.Selda.Exp 8 | ( Exp(Col), UntypedCol(..), SomeCol(Named) ) 9 | import Database.Selda.Types (ColName, mkColName, addColSuffix) 10 | 11 | type Scope = Int 12 | type Ident = Int 13 | 14 | -- | A name, consisting of a scope and an identifier. 15 | data Name = Name Scope Ident 16 | 17 | instance Show Name where 18 | show (Name 0 n) = concat [show n] 19 | show (Name s n) = concat [show s, "s_", show n] 20 | 21 | -- | An SQL query. 22 | newtype Query s a = Query {unQ :: State GenState a} 23 | deriving (Functor, Applicative, Monad) 24 | 25 | -- | Run a query computation from an initial state. 26 | runQueryM :: Scope -> Query s a -> (a, GenState) 27 | runQueryM scope = flip runState (initState scope) . unQ 28 | 29 | -- | Run a query computation in isolation, but reusing the current name supply. 30 | isolate :: Query s a -> State GenState (GenState, a) 31 | isolate (Query q) = do 32 | st <- get 33 | put $ (initState (nameScope st)) {nameSupply = nameSupply st} 34 | x <- q 35 | st' <- get 36 | put $ st {nameSupply = nameSupply st'} 37 | return (st', x) 38 | 39 | -- | SQL generation internal state. 40 | -- Contains the subqueries and static (i.e. not dependent on any subqueries) 41 | -- restrictions of the query currently being built, as well as a name supply 42 | -- for column renaming. 43 | data GenState = GenState 44 | { sources :: ![SQL] 45 | , staticRestricts :: ![Exp SQL Bool] 46 | , groupCols :: ![SomeCol SQL] 47 | , nameSupply :: !Int 48 | , nameScope :: !Int 49 | } 50 | 51 | -- | Initial state: no subqueries, no restrictions. 52 | initState :: Int -> GenState 53 | initState scope = GenState 54 | { sources = [] 55 | , staticRestricts = [] 56 | , groupCols = [] 57 | , nameSupply = 0 58 | , nameScope = scope 59 | } 60 | 61 | renameAll :: [UntypedCol sql] -> State GenState [SomeCol sql] 62 | renameAll = fmap concat . mapM rename 63 | 64 | -- | Generate a unique name for the given column. 65 | rename :: UntypedCol sql -> State GenState [SomeCol sql] 66 | rename (Untyped col) = do 67 | n <- freshId 68 | return [Named (newName n) col] 69 | where 70 | newName ns = 71 | case col of 72 | Col n -> addColSuffix n $ "_" <> pack (show ns) 73 | _ -> mkColName $ "tmp_" <> pack (show ns) 74 | 75 | -- | Get a guaranteed unique identifier. 76 | freshId :: State GenState Name 77 | freshId = do 78 | st <- get 79 | put $ st {nameSupply = succ $ nameSupply st} 80 | return (Name (nameScope st) (nameSupply st)) 81 | 82 | -- | Get a guaranteed unique column name. 83 | freshName :: State GenState ColName 84 | freshName = do 85 | n <- freshId 86 | return $ mkColName $ "tmp_" <> pack (show n) 87 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/SQL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} 2 | {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} 3 | {-# LANGUAGE RankNTypes, CPP, MultiParamTypeClasses #-} 4 | -- | SQL AST and parameters for prepared statements. 5 | module Database.Selda.SQL where 6 | import Data.String ( IsString(..) ) 7 | import Data.Text (Text) 8 | import Database.Selda.Exp ( Names(..), Exp, SomeCol ) 9 | import Database.Selda.SqlType 10 | ( Lit, SqlType(mkLit), SqlTypeRep, litType, compLit ) 11 | import Database.Selda.Types ( TableName ) 12 | 13 | instance Semigroup QueryFragment where 14 | (<>) = RawCat 15 | 16 | data QueryFragment where 17 | RawText :: !Text -> QueryFragment 18 | RawExp :: !(Exp SQL a) -> QueryFragment 19 | RawCat :: !QueryFragment -> !QueryFragment -> QueryFragment 20 | 21 | instance IsString QueryFragment where 22 | fromString = RawText . fromString 23 | 24 | -- | A source for an SQL query. 25 | data SqlSource 26 | = TableName !TableName 27 | | Product ![SQL] 28 | | Union !Bool !SQL !SQL 29 | | Join !JoinType !(Exp SQL Bool) !SQL !SQL 30 | | Values ![SomeCol SQL] ![[Param]] 31 | | RawSql !QueryFragment 32 | | EmptyTable 33 | 34 | -- | Type of join to perform. 35 | data JoinType = InnerJoin | LeftJoin 36 | 37 | -- | AST for SQL queries. 38 | data SQL = SQL 39 | { cols :: ![SomeCol SQL] 40 | , source :: !SqlSource 41 | , restricts :: ![Exp SQL Bool] 42 | , groups :: ![SomeCol SQL] 43 | , ordering :: ![(Order, SomeCol SQL)] 44 | , limits :: !(Maybe (Int, Int)) 45 | , liveExtras :: ![SomeCol SQL] -- ^ Columns which are never considered dead. 46 | , distinct :: !Bool 47 | } 48 | 49 | instance Names QueryFragment where 50 | allNamesIn (RawText _) = [] 51 | allNamesIn (RawExp e) = allNamesIn e 52 | allNamesIn (RawCat a b) = allNamesIn a ++ allNamesIn b 53 | 54 | instance Names SqlSource where 55 | allNamesIn (Product qs) = concatMap allNamesIn qs 56 | allNamesIn (Join _ e l r) = allNamesIn e ++ concatMap allNamesIn [l, r] 57 | allNamesIn (Values vs _) = allNamesIn vs 58 | allNamesIn (TableName _) = [] 59 | allNamesIn (RawSql r) = allNamesIn r 60 | allNamesIn (EmptyTable) = [] 61 | allNamesIn (Union _ l r) = concatMap allNamesIn [l, r] 62 | 63 | instance Names SQL where 64 | -- Note that we don't include @cols@ here: the names in @cols@ are not 65 | -- necessarily used, only declared. 66 | allNamesIn (SQL{..}) = concat 67 | [ allNamesIn groups 68 | , concatMap (allNamesIn . snd) ordering 69 | , allNamesIn restricts 70 | , allNamesIn source 71 | ] 72 | 73 | -- | Build a plain SQL query with the given columns and source, with no filters, 74 | -- ordering, etc. 75 | sqlFrom :: [SomeCol SQL] -> SqlSource -> SQL 76 | sqlFrom cs src = SQL 77 | { cols = cs 78 | , source = src 79 | , restricts = [] 80 | , groups = [] 81 | , ordering = [] 82 | , limits = Nothing 83 | , liveExtras = [] 84 | , distinct = False 85 | } 86 | 87 | -- | The order in which to sort result rows. 88 | data Order = Asc | Desc 89 | deriving (Show, Ord, Eq) 90 | 91 | -- | A parameter to a prepared SQL statement. 92 | data Param where 93 | Param :: !(Lit a) -> Param 94 | 95 | instance Show Param where 96 | show (Param l) = "Param " <> show l 97 | 98 | instance Eq Param where 99 | Param a == Param b = compLit a b == EQ 100 | instance Ord Param where 101 | compare (Param a) (Param b) = compLit a b 102 | 103 | -- | Create a parameter from the given value. 104 | param :: SqlType a => a -> Param 105 | param = Param . mkLit 106 | 107 | -- | The SQL type of the given parameter. 108 | paramType :: Param -> SqlTypeRep 109 | paramType (Param p) = litType p 110 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/SQL/Print/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Database.Selda.SQL.Print.Config (PPConfig (..), defPPConfig) where 3 | import Data.Text (Text) 4 | import qualified Data.Text as T 5 | import Database.Selda.SqlType ( SqlTypeRep(..) ) 6 | import Database.Selda.Table.Type 7 | ( IndexMethod, ColAttr(..), AutoIncType(Weak, Strong) ) 8 | 9 | -- | Backend-specific configuration for the SQL pretty-printer. 10 | data PPConfig = PPConfig 11 | { -- | The SQL type name of the given type. 12 | -- 13 | -- This function should be used everywhere a type is needed to be printed but in primary 14 | -- keys position. This is due to the fact that some backends might have a special 15 | -- representation of primary keys (using sequences are such). If you have such a need, 16 | -- please use the 'ppTypePK' record instead. 17 | ppType :: SqlTypeRep -> Text 18 | 19 | -- | Hook that allows you to modify 'ppType' output. 20 | , ppTypeHook :: SqlTypeRep -> [ColAttr] -> (SqlTypeRep -> Text) -> Text 21 | 22 | -- | The SQL type name of the given type for primary keys uses. 23 | , ppTypePK :: SqlTypeRep -> Text 24 | 25 | -- | Parameter placeholder for the @n@th parameter. 26 | , ppPlaceholder :: Int -> Text 27 | 28 | -- | List of column attributes. 29 | , ppColAttrs :: [ColAttr] -> Text 30 | 31 | -- | Hook that allows you to modify 'ppColAttrs' output. 32 | , ppColAttrsHook :: SqlTypeRep -> [ColAttr] -> ([ColAttr] -> Text) -> Text 33 | 34 | -- | The value used for the next value for an auto-incrementing column. 35 | -- For instance, @DEFAULT@ for PostgreSQL, and @NULL@ for SQLite. 36 | , ppAutoIncInsert :: Text 37 | 38 | -- | Insert queries may have at most this many parameters; if an insertion 39 | -- has more parameters than this, it will be chunked. 40 | -- 41 | -- Note that only insertions of multiple rows are chunked. If your table 42 | -- has more than this many columns, you should really rethink 43 | -- your database design. 44 | , ppMaxInsertParams :: Maybe Int 45 | 46 | -- | @CREATE INDEX@ suffix to indicate that the index should use the given 47 | -- index method. 48 | , ppIndexMethodHook :: IndexMethod -> Text 49 | } 50 | 51 | -- | Default settings for pretty-printing. 52 | -- Geared towards SQLite. 53 | -- 54 | -- The default definition of 'ppTypePK' is 'defType, so that you don’t have to do anything 55 | -- special if you don’t use special types for primary keys. 56 | defPPConfig :: PPConfig 57 | defPPConfig = PPConfig 58 | { ppType = defType 59 | , ppTypeHook = \ty _ _ -> defType ty 60 | , ppTypePK = defType 61 | , ppPlaceholder = T.cons '$' . T.pack . show 62 | , ppColAttrs = T.unwords . map defColAttr 63 | , ppColAttrsHook = \_ ats _ -> T.unwords $ map defColAttr ats 64 | , ppAutoIncInsert = "NULL" 65 | , ppMaxInsertParams = Nothing 66 | , ppIndexMethodHook = const "" 67 | } 68 | 69 | -- | Default compilation for SQL types. 70 | -- By default, anything we don't know is just a blob. 71 | defType :: SqlTypeRep -> Text 72 | defType TText = "TEXT" 73 | defType TRowID = "INTEGER" 74 | defType TInt32 = "INT" 75 | defType TInt64 = "BIGINT" 76 | defType TFloat = "DOUBLE PRECISION" 77 | defType TBool = "BOOLEAN" 78 | defType TDateTime = "DATETIME" 79 | defType TDate = "DATE" 80 | defType TTime = "TIME" 81 | defType TBlob = "BLOB" 82 | defType TUUID = "BLOB" 83 | defType TJSON = "BLOB" 84 | 85 | -- | Default compilation for a column attribute. 86 | defColAttr :: ColAttr -> Text 87 | defColAttr Primary = "" 88 | defColAttr (AutoPrimary Strong) = "PRIMARY KEY AUTOINCREMENT" 89 | defColAttr (AutoPrimary Weak) = "PRIMARY KEY" 90 | defColAttr Required = "NOT NULL" 91 | defColAttr Optional = "NULL" 92 | defColAttr Unique = "UNIQUE" 93 | defColAttr (Indexed _) = "" 94 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Selectors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, CPP #-} 2 | module Database.Selda.Selectors 3 | ( Assignment ((:=)), Selector, Coalesce 4 | , (!), (?), with, ($=) 5 | , selectorIndex, unsafeSelector 6 | ) where 7 | import Database.Selda.SqlRow (SqlRow) 8 | import Database.Selda.SqlType ( SqlType ) 9 | import Database.Selda.Column 10 | ( UntypedCol(Untyped), Row(..), Col(..) ) 11 | import Data.List (foldl') 12 | import Unsafe.Coerce ( unsafeCoerce ) 13 | 14 | -- | Coalesce nested nullable column into a single level of nesting. 15 | type family Coalesce a where 16 | Coalesce (Maybe (Maybe a)) = Coalesce (Maybe a) 17 | Coalesce a = a 18 | 19 | -- | A selector indicating the nth (zero-based) column of a table. 20 | -- 21 | -- Will cause errors in queries during compilation, execution, or both, 22 | -- unless handled with extreme care. You really shouldn't use it at all. 23 | unsafeSelector :: (SqlRow a, SqlType b) => Int -> Selector a b 24 | unsafeSelector = Selector 25 | 26 | -- | Extract the given column from the given row. 27 | (!) :: SqlType a => Row s t -> Selector t a -> Col s a 28 | (Many xs) ! (Selector i) = case xs !! i of Untyped x -> One (unsafeCoerce x) 29 | infixl 9 ! 30 | 31 | -- | Extract the given column from the given nullable row. 32 | -- Nullable rows usually result from left joins. 33 | -- If a nullable column is extracted from a nullable row, the resulting 34 | -- nested @Maybe@s will be squashed into a single level of nesting. 35 | (?) :: SqlType a => Row s (Maybe t) -> Selector t a -> Col s (Coalesce (Maybe a)) 36 | (Many xs) ? (Selector i) = case xs !! i of Untyped x -> One (unsafeCoerce x) 37 | infixl 9 ? 38 | 39 | upd :: Row s a -> Assignment s a -> Row s a 40 | upd (Many xs) (Selector i := (One x')) = 41 | case splitAt i xs of 42 | (left, _:right) -> Many (left ++ Untyped x' : right) 43 | _ -> error "BUG: too few columns in row!" 44 | upd (Many xs) (Modify (Selector i) f) = 45 | case splitAt i xs of 46 | (left, Untyped x:right) -> Many (left ++ f' (unsafeCoerce x) : right) 47 | _ -> error "BUG: too few columns in row!" 48 | where 49 | f' x = case f (One x) of 50 | One y -> Untyped y 51 | 52 | -- | A selector-value assignment pair. 53 | data Assignment s a where 54 | -- | Set the given column to the given value. 55 | (:=) :: Selector t a -> Col s a -> Assignment s t 56 | 57 | -- | Modify the given column by the given function. 58 | Modify :: Selector t a -> (Col s a -> Col s a) -> Assignment s t 59 | infixl 2 := 60 | 61 | -- | Apply the given function to the given column. 62 | ($=) :: Selector t a -> (Col s a -> Col s a) -> Assignment s t 63 | ($=) = Modify 64 | infixl 2 $= 65 | 66 | -- | For each selector-value pair in the given list, on the given tuple, 67 | -- update the field pointed out by the selector with the corresponding value. 68 | with :: Row s a -> [Assignment s a] -> Row s a 69 | with = foldl' upd 70 | 71 | -- | A column selector. Column selectors can be used together with the '!' and 72 | -- 'with' functions to get and set values on rows, or to specify 73 | -- foreign keys. 74 | newtype Selector t a = Selector {selectorIndex :: Int} 75 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/SqlRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds #-} 2 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} 3 | {-# LANGUAGE TypeOperators, DefaultSignatures, ScopedTypeVariables, CPP #-} 4 | {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} 5 | module Database.Selda.SqlRow 6 | ( SqlRow (..), ResultReader 7 | , GSqlRow 8 | , runResultReader, next 9 | ) where 10 | import Control.Monad.State.Strict 11 | ( liftM2, 12 | StateT(StateT), 13 | MonadState(state, get), 14 | State, 15 | evalState ) 16 | import Database.Selda.SqlType 17 | ( SqlValue(SqlNull), SqlType(fromSql) ) 18 | import Data.Typeable ( Typeable, Proxy(..) ) 19 | import GHC.Generics 20 | ( Generic(Rep, to), K1(K1), M1(M1), type (:+:), type (:*:)(..) ) 21 | import qualified GHC.TypeLits as TL 22 | 23 | newtype ResultReader a = R (State [SqlValue] a) 24 | deriving (Functor, Applicative, Monad) 25 | 26 | runResultReader :: ResultReader a -> [SqlValue] -> a 27 | runResultReader (R m) = evalState m 28 | 29 | next :: ResultReader SqlValue 30 | next = R . state $ \s -> (head s, tail s) 31 | 32 | class Typeable a => SqlRow a where 33 | -- | Read the next, potentially composite, result from a stream of columns. 34 | nextResult :: ResultReader a 35 | default nextResult :: (Generic a, GSqlRow (Rep a)) => ResultReader a 36 | nextResult = to <$> gNextResult 37 | 38 | -- | The number of nested columns contained in this type. 39 | nestedCols :: Proxy a -> Int 40 | default nestedCols :: (Generic a, GSqlRow (Rep a)) => Proxy a -> Int 41 | nestedCols _ = gNestedCols (Proxy :: Proxy (Rep a)) 42 | 43 | 44 | -- * Generic derivation for SqlRow 45 | class GSqlRow f where 46 | gNextResult :: ResultReader (f x) 47 | gNestedCols :: Proxy f -> Int 48 | 49 | instance SqlType a => GSqlRow (K1 i a) where 50 | gNextResult = K1 <$> fromSql <$> next 51 | gNestedCols _ = 1 52 | 53 | instance GSqlRow f => GSqlRow (M1 c i f) where 54 | gNextResult = M1 <$> gNextResult 55 | gNestedCols _ = gNestedCols (Proxy :: Proxy f) 56 | 57 | instance (GSqlRow a, GSqlRow b) => GSqlRow (a :*: b) where 58 | gNextResult = liftM2 (:*:) gNextResult gNextResult 59 | gNestedCols _ = gNestedCols (Proxy :: Proxy a) + gNestedCols (Proxy :: Proxy b) 60 | 61 | instance 62 | (TL.TypeError 63 | ( 'TL.Text "Selda currently does not support creating tables from sum types." 64 | 'TL.:$$: 65 | 'TL.Text "Restrict your table type to a single data constructor." 66 | )) => GSqlRow (a :+: b) where 67 | gNextResult = error "unreachable" 68 | gNestedCols = error "unreachable" 69 | 70 | -- * Various instances 71 | instance SqlRow a => SqlRow (Maybe a) where 72 | nextResult = do 73 | xs <- R get 74 | if all isNull (take (nestedCols (Proxy :: Proxy a)) xs) 75 | then return Nothing 76 | else Just <$> nextResult 77 | where 78 | isNull SqlNull = True 79 | isNull _ = False 80 | nestedCols _ = nestedCols (Proxy :: Proxy a) 81 | 82 | instance 83 | ( Typeable (a, b) 84 | , GSqlRow (Rep (a, b)) 85 | ) => SqlRow (a, b) 86 | instance 87 | ( Typeable (a, b, c) 88 | , GSqlRow (Rep (a, b, c)) 89 | ) => SqlRow (a, b, c) 90 | instance 91 | ( Typeable (a, b, c, d) 92 | , GSqlRow (Rep (a, b, c, d)) 93 | ) => SqlRow (a, b, c, d) 94 | instance 95 | ( Typeable (a, b, c, d, e) 96 | , GSqlRow (Rep (a, b, c, d, e)) 97 | ) => SqlRow (a, b, c, d, e) 98 | instance 99 | ( Typeable (a, b, c, d, e, f) 100 | , GSqlRow (Rep (a, b, c, d, e, f)) 101 | ) => SqlRow (a, b, c, d, e, f) 102 | instance 103 | ( Typeable (a, b, c, d, e, f, g) 104 | , GSqlRow (Rep (a, b, c, d, e, f, g)) 105 | ) => SqlRow (a, b, c, d, e, f, g) 106 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Table.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-} 4 | {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-} 5 | {-# LANGUAGE GADTs, CPP, DataKinds #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | module Database.Selda.Table 8 | ( SelectorLike, Group (..), Attr (..), Table (..), Attribute 9 | , ColInfo (..), AutoIncType (..), ColAttr (..), IndexMethod (..) 10 | , ForeignKey (..) 11 | , table, tableFieldMod 12 | , primary, autoPrimary, weakAutoPrimary 13 | , untypedAutoPrimary, weakUntypedAutoPrimary 14 | , unique 15 | , index, indexUsing 16 | , tableExpr 17 | , isAutoPrimary, isPrimary, isUnique 18 | ) where 19 | import Data.Text (Text) 20 | import Data.Typeable ( Proxy(..) ) 21 | import Database.Selda.Types ( type (:*:), TableName, ColName ) 22 | import Database.Selda.Selectors ( Selector(..) ) 23 | import Database.Selda.SqlType ( ID, RowID ) 24 | import Database.Selda.Column (Row (..)) 25 | import Database.Selda.Generic ( Relational, tblCols ) 26 | import Database.Selda.Table.Type 27 | ( IndexMethod(..), 28 | ColAttr(..), 29 | AutoIncType(..), 30 | ColInfo(..), 31 | Table(..), 32 | isAutoPrimary, 33 | isPrimary, 34 | isUnique ) 35 | import Database.Selda.Table.Validation (snub) 36 | import GHC.OverloadedLabels ( IsLabel(..) ) 37 | 38 | instance forall x t a. IsLabel x (Selector t a) => IsLabel x (Group t a) where 39 | fromLabel = Single (fromLabel @x) 40 | 41 | -- | A non-empty list of selectors, where the element selectors need not have 42 | -- the same type. Used to specify constraints, such as uniqueness or primary 43 | -- key, potentially spanning multiple columns. 44 | data Group t a where 45 | (:+) :: Selector t a -> Group t b -> Group t (a :*: b) 46 | Single :: Selector t a -> Group t a 47 | infixr 1 :+ 48 | 49 | -- | A generic column attribute. 50 | -- Essentially a pair or a record selector over the type @a@ and a column 51 | -- attribute. An attribute may be either a 'Group' attribute, meaning that 52 | -- it can span multiple columns, or a 'Selector' -- single column -- attribute. 53 | data Attr a where 54 | (:-) :: SelectorLike g => g t a -> Attribute g t a -> Attr t 55 | infixl 0 :- 56 | 57 | -- | Generate a table from the given table name and list of column attributes. 58 | -- All @Maybe@ fields in the table's type will be represented by nullable 59 | -- columns, and all non-@Maybe@ fields fill be represented by required 60 | -- columns. 61 | -- For example: 62 | -- 63 | -- > data Person = Person 64 | -- > { id :: ID Person 65 | -- > , name :: Text 66 | -- > , age :: Int 67 | -- > , pet :: Maybe Text 68 | -- > } 69 | -- > deriving Generic 70 | -- > 71 | -- > people :: Table Person 72 | -- > people = table "people" [#id :- autoPrimary] 73 | -- 74 | -- This will result in a table of @Person@s, with an auto-incrementing primary 75 | -- key. 76 | -- 77 | -- If the given type does not have record selectors, the column names will be 78 | -- @col_1@, @col_2@, etc. 79 | table :: forall a. Relational a 80 | => TableName 81 | -> [Attr a] 82 | -> Table a 83 | table tn attrs = tableFieldMod tn attrs id 84 | 85 | -- | Generate a table from the given table name, 86 | -- a list of column attributes and a function 87 | -- that maps from field names to column names. 88 | -- Ex.: 89 | -- 90 | -- > data Person = Person 91 | -- > { personId :: Int 92 | -- > , personName :: Text 93 | -- > , personAge :: Int 94 | -- > , personPet :: Maybe Text 95 | -- > } 96 | -- > deriving Generic 97 | -- > 98 | -- > people :: Table Person 99 | -- > people = tableFieldMod "people" 100 | -- > [#personName :- autoPrimary] 101 | -- > (fromJust . stripPrefix "person") 102 | -- 103 | -- This will create a table with the columns named 104 | -- @Id@, @Name@, @Age@ and @Pet@. 105 | tableFieldMod :: forall a. Relational a 106 | => TableName 107 | -> [Attr a] 108 | -> (Text -> Text) 109 | -> Table a 110 | tableFieldMod tn attrs fieldMod = Table 111 | { tableName = tn 112 | , tableCols = map tidy cols 113 | , tableHasAutoPK = apk 114 | , tableAttrs = concat [combinedAttrs, pkAttrs] 115 | } 116 | where 117 | combinedAttrs = 118 | [ (ixs, a) 119 | | sel :- Attribute [a] <- attrs 120 | , let ixs = indices sel 121 | , case ixs of 122 | (_:_:_) -> True 123 | [_] | a == Unique -> True 124 | [_] | Indexed _ <- a -> True 125 | _ -> False 126 | ] 127 | pkAttrs = concat 128 | [ [(ixs, Primary), (ixs, Required)] 129 | | sel :- Attribute [Primary,Required] <- attrs 130 | , let ixs = indices sel 131 | ] 132 | cols = zipWith addAttrs [0..] (tblCols (Proxy :: Proxy a) fieldMod) 133 | apk = or [any isAutoPrimary as | _ :- Attribute as <- attrs] 134 | addAttrs n ci = ci 135 | { colAttrs = colAttrs ci ++ concat 136 | [ as 137 | | sel :- Attribute as <- attrs 138 | , case indices sel of 139 | [colIx] -> colIx == n 140 | _ -> False 141 | ] 142 | , colFKs = colFKs ci ++ 143 | [ thefk 144 | | sel :- ForeignKey thefk <- attrs 145 | , case indices sel of 146 | [colIx] -> colIx == n 147 | _ -> False 148 | ] 149 | } 150 | 151 | class SelectorLike g where 152 | indices :: g t a -> [Int] 153 | 154 | instance SelectorLike Selector where 155 | indices s = [selectorIndex s] 156 | instance SelectorLike Group where 157 | indices (s :+ ss) = selectorIndex s : indices ss 158 | indices (Single s) = [selectorIndex s] 159 | 160 | -- | Remove duplicate attributes. 161 | tidy :: ColInfo -> ColInfo 162 | tidy ci = ci {colAttrs = snub $ colAttrs ci} 163 | 164 | -- | Some attribute that may be set on a column of type @c@, in a table of 165 | -- type @t@. 166 | data Attribute (g :: * -> * -> *) t c 167 | = Attribute [ColAttr] 168 | | ForeignKey (Table (), ColName) 169 | 170 | -- | A primary key which does not auto-increment. 171 | primary :: Attribute Group t a 172 | primary = Attribute [Primary, Required] 173 | 174 | -- | Create an index on these column(s). 175 | index :: Attribute Group t c 176 | index = Attribute [Indexed Nothing] 177 | 178 | -- | Create an index using the given index method on this column. 179 | indexUsing :: IndexMethod -> Attribute Group t c 180 | indexUsing m = Attribute [Indexed (Just m)] 181 | 182 | -- | An auto-incrementing primary key. 183 | autoPrimary :: Attribute Selector t (ID t) 184 | autoPrimary = Attribute [AutoPrimary Strong, Required] 185 | 186 | -- | A "weakly auto-incrementing" primary key. 187 | -- Behaves like 'autoPrimary', but the sequence of generated keys is not 188 | -- guaranteed to be monotonically increasing. 189 | -- 190 | -- This gives better performance on some backends, but means that 191 | -- the relation @a > b <=> a was inserted at a later point in time than b@ 192 | -- does not hold. 193 | weakAutoPrimary :: Attribute Selector t (ID t) 194 | weakAutoPrimary = Attribute [AutoPrimary Weak, Required] 195 | 196 | -- | An untyped auto-incrementing primary key. 197 | -- You should really only use this for ad hoc tables, such as tuples. 198 | untypedAutoPrimary :: Attribute Selector t RowID 199 | untypedAutoPrimary = Attribute [AutoPrimary Strong, Required] 200 | 201 | -- | Like 'weakAutoPrimary', but for untyped IDs. 202 | weakUntypedAutoPrimary :: Attribute Selector t RowID 203 | weakUntypedAutoPrimary = Attribute [AutoPrimary Weak, Required] 204 | 205 | -- | A table-unique value. 206 | unique :: Attribute Group t a 207 | unique = Attribute [Unique] 208 | 209 | mkFK :: Table t -> Selector a b -> Attribute Selector c d 210 | mkFK (Table tn tcs tapk tas) sel = 211 | ForeignKey (Table tn tcs tapk tas, colName (tcs !! selectorIndex sel)) 212 | 213 | class ForeignKey a b where 214 | -- | A foreign key constraint referencing the given table and column. 215 | foreignKey :: Table t -> Selector t a -> Attribute Selector self b 216 | 217 | instance ForeignKey a a where 218 | foreignKey = mkFK 219 | instance ForeignKey (Maybe a) a where 220 | foreignKey = mkFK 221 | instance ForeignKey a (Maybe a) where 222 | foreignKey = mkFK 223 | 224 | -- | An expression representing the given table. 225 | tableExpr :: Table a -> Row s a 226 | tableExpr = Many . map colExpr . tableCols 227 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Table/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, CPP #-} 2 | -- | Generating SQL for creating and deleting tables. 3 | module Database.Selda.Table.Compile where 4 | import Database.Selda.Table.Type 5 | ( IndexMethod, 6 | ColAttr(Indexed, Primary, Unique), 7 | ColInfo(colFKs, colType, colName, colAttrs), 8 | Table(Table, tableAttrs, tableName, tableCols), 9 | isAutoPrimary ) 10 | import Database.Selda.Table.Validation ( validateOrThrow ) 11 | import Data.IntMap (IntMap) 12 | import qualified Data.IntMap as IntMap 13 | import Data.List (foldl') 14 | import Data.Text (Text, intercalate, pack) 15 | import qualified Data.Text as Text 16 | import Database.Selda.SQL ( Param ) 17 | import Database.Selda.SQL.Print.Config 18 | ( PPConfig(ppIndexMethodHook, ppTypeHook, ppColAttrsHook, 19 | ppColAttrs, ppTypePK, ppType, ppAutoIncInsert) ) 20 | import Database.Selda.SqlType (SqlTypeRep(..)) 21 | import Database.Selda.Types 22 | ( TableName, 23 | ColName, 24 | modColName, 25 | addColPrefix, 26 | fromColName, 27 | intercalateColNames, 28 | fromTableName, 29 | rawTableName ) 30 | 31 | data OnError = Fail | Ignore 32 | deriving (Eq, Ord, Show) 33 | 34 | -- | Compile a sequence of queries to create the given table, including indexes. 35 | -- The first query in the sequence is always @CREATE TABLE@. 36 | compileCreateTable :: PPConfig -> OnError -> Table a -> Text 37 | compileCreateTable cfg ifex tbl = 38 | ensureValid `seq` createTable 39 | where 40 | createTable = mconcat 41 | [ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "(" 42 | , intercalate ", " (map (compileTableCol cfg) (tableCols tbl) ++ multiUniques ++ multiPrimary) 43 | , case allFKs of 44 | [] -> "" 45 | _ -> ", " <> intercalate ", " compFKs 46 | , ")" 47 | ] 48 | multiPrimary = 49 | [ mconcat ["PRIMARY KEY(", intercalate ", " (colNames ixs), ")"] 50 | | (ixs, Primary) <- tableAttrs tbl 51 | ] 52 | multiUniques = 53 | [ mconcat ["UNIQUE(", intercalate ", " (colNames ixs), ")"] 54 | | (ixs, Unique) <- tableAttrs tbl 55 | ] 56 | colNames ixs = [fromColName (colName (tableCols tbl !! ix)) | ix <- ixs] 57 | ifNotExists Fail = "" 58 | ifNotExists Ignore = "IF NOT EXISTS " 59 | allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci] 60 | compFKs = zipWith (uncurry compileFK) allFKs [0..] 61 | ensureValid = validateOrThrow (tableName tbl) (tableCols tbl) 62 | 63 | -- | Compile the @CREATE INDEX@ queries for all indexes on the given table. 64 | compileCreateIndexes :: PPConfig -> OnError -> Table a -> [Text] 65 | compileCreateIndexes cfg ifex tbl = 66 | [ compileCreateIndex cfg ifex (tableName tbl) (colNameOfIdx <$> idxs) mmethod 67 | | (idxs, Indexed mmethod) <- tableAttrs tbl 68 | ] 69 | where 70 | idxMap :: IntMap ColName 71 | idxMap = IntMap.fromList (zip [0..] (colName <$> tableCols tbl)) 72 | colNameOfIdx :: Int -> ColName 73 | colNameOfIdx colIdx = 74 | case IntMap.lookup colIdx idxMap of 75 | Nothing -> error "Impossible: Index has non-existant column-index." 76 | Just name -> name 77 | 78 | -- | Get the name to use for an index on the given column(s) in the given table. 79 | -- 80 | -- To ensure uniqueness 81 | -- 82 | -- 1. Name multi-column indexes by connecting column names 83 | -- with underscores. 84 | -- 2. Escape underscores in column names. 85 | -- 86 | -- Thus the index of columns @["foo","bar"]@ becomes @ixTable_foo_bar@ while 87 | -- the index @["foo_bar"]@ receives an extra underscore to become 88 | -- @ixTable_foo__bar@. 89 | indexNameFor :: TableName -> [ColName] -> Text 90 | indexNameFor t cs = 91 | let escUnderscore c = modColName c (Text.replace "_" "__") in 92 | let ixPrefix partial = "ix" <> rawTableName t <> "_" <> partial 93 | in ixPrefix (intercalateColNames "_" (escUnderscore <$> cs)) 94 | 95 | -- | Compile a @CREATE INDEX@ query for the given index. 96 | compileCreateIndex :: PPConfig 97 | -> OnError 98 | -> TableName 99 | -> [ColName] 100 | -> Maybe IndexMethod 101 | -> Text 102 | compileCreateIndex cfg ifex tbl cols mmethod = mconcat 103 | [ "CREATE INDEX" 104 | , if ifex == Ignore then " IF NOT EXISTS " else " " 105 | , indexNameFor tbl cols, " ON ", fromTableName tbl 106 | , case mmethod of 107 | Just method -> " " <> ppIndexMethodHook cfg method 108 | Nothing -> "" 109 | , " (", Text.intercalate ", " (map fromColName cols), ")" 110 | ] 111 | 112 | -- | Compile a foreign key constraint. 113 | compileFK :: ColName -> (Table (), ColName) -> Int -> Text 114 | compileFK col (Table ftbl _ _ _, fcol) n = mconcat 115 | [ "CONSTRAINT ", fkName, " FOREIGN KEY (", fromColName col, ") " 116 | , "REFERENCES ", fromTableName ftbl, "(", fromColName fcol, ")" 117 | ] 118 | where 119 | fkName = fromColName $ addColPrefix col ("fk" <> pack (show n) <> "_") 120 | 121 | -- | Compile a table column. 122 | compileTableCol :: PPConfig -> ColInfo -> Text 123 | compileTableCol cfg ci = Text.unwords 124 | [ fromColName (colName ci) 125 | , typeHook <> " " <> colAttrsHook 126 | ] 127 | where 128 | typeHook = ppTypeHook cfg cty attrs (ppType' cfg) 129 | colAttrsHook = ppColAttrsHook cfg cty attrs (ppColAttrs cfg) 130 | cty = colType ci 131 | attrs = colAttrs ci 132 | ppType' 133 | | cty == TRowID && any isAutoPrimary attrs = ppTypePK 134 | | otherwise = ppType 135 | 136 | -- | Compile a @DROP TABLE@ query. 137 | compileDropTable :: OnError -> Table a -> Text 138 | compileDropTable Fail t = 139 | Text.unwords ["DROP TABLE",fromTableName (tableName t)] 140 | compileDropTable _ t = 141 | Text.unwords ["DROP TABLE IF EXISTS",fromTableName (tableName t)] 142 | 143 | -- | Compile an @INSERT INTO@ query inserting @m@ rows with @n@ cols each. 144 | -- Note that backends expect insertions to NOT have a semicolon at the end. 145 | -- In addition to the compiled query, this function also returns the list of 146 | -- parameters to be passed to the backend. 147 | compInsert :: PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param]) 148 | compInsert cfg tbl defs = 149 | (query, parameters) 150 | where 151 | colNames = map colName $ tableCols tbl 152 | values = Text.intercalate ", " vals 153 | (vals, parameters) = mkRows 1 defs [] [] 154 | query = Text.unwords 155 | [ "INSERT INTO" 156 | , fromTableName (tableName tbl) 157 | , "(" <> Text.intercalate ", " (map fromColName colNames) <> ")" 158 | , "VALUES" 159 | , values 160 | ] 161 | 162 | -- Build all rows: just recurse over the list of defaults (which encodes 163 | -- the # of elements in total as well), building each row, keeping track 164 | -- of the next parameter identifier. 165 | mkRows n (ps:pss) rts paramss = 166 | case mkRow n ps (tableCols tbl) of 167 | (n', names, params) -> mkRows n' pss (rowText:rts) (params:paramss) 168 | where rowText = "(" <> Text.intercalate ", " (reverse names) <> ")" 169 | mkRows _ _ rts ps = 170 | (reverse rts, reverse $ concat ps) 171 | 172 | -- Build a row: use the NULL/DEFAULT keyword for default rows, otherwise 173 | -- use a parameter. 174 | mkRow n ps names = foldl' mkCols (n, [], []) (zip ps names) 175 | 176 | -- Build a column: default values only available for for auto-incrementing 177 | -- primary keys. 178 | mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param]) 179 | mkCol n (Left def) col ps 180 | | any isAutoPrimary (colAttrs col) = 181 | (n, ppAutoIncInsert cfg, ps) 182 | | otherwise = 183 | (n+1, pack ('$':show n), def:ps) 184 | mkCol n (Right val) _ ps = 185 | (n+1, pack ('$':show n), val:ps) 186 | 187 | -- Create a colum and return the next parameter id, plus the column itself. 188 | mkCols :: (Int, [Text], [Param]) -> (Either Param Param, ColInfo) -> (Int, [Text], [Param]) 189 | mkCols (n, names, params) (param, col) = 190 | case mkCol n param col params of 191 | (n', name, params') -> (n', name:names, params') 192 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Table/Type.hs: -------------------------------------------------------------------------------- 1 | module Database.Selda.Table.Type where 2 | import Database.Selda.SqlType (SqlTypeRep) 3 | import Database.Selda.SQL (SQL) 4 | import Database.Selda.Types ( TableName, ColName ) 5 | import Database.Selda.Exp ( UntypedCol ) 6 | 7 | -- | A database table, based on some Haskell data type. 8 | -- Any single constructor type can form the basis of a table, as long as 9 | -- it derives @Generic@ and all of its fields are instances of @SqlType@. 10 | data Table a = Table 11 | { -- | Name of the table. NOT guaranteed to be a valid SQL name. 12 | tableName :: TableName 13 | 14 | -- | All table columns. 15 | -- Invariant: the 'colAttrs' list of each column is sorted and contains 16 | -- no duplicates. 17 | , tableCols :: [ColInfo] 18 | 19 | -- | Does the given table have an auto-incrementing primary key? 20 | , tableHasAutoPK :: Bool 21 | 22 | -- | Attributes involving multiple columns. 23 | , tableAttrs :: [([Int], ColAttr)] 24 | } 25 | 26 | -- | A complete description of a database column. 27 | data ColInfo = ColInfo 28 | { colName :: ColName 29 | , colType :: SqlTypeRep 30 | , colAttrs :: [ColAttr] 31 | , colFKs :: [(Table (), ColName)] 32 | , colExpr :: UntypedCol SQL 33 | } 34 | 35 | -- | Strongly or weakly auto-incrementing primary key? 36 | data AutoIncType = Weak | Strong 37 | deriving (Show, Eq, Ord) 38 | 39 | -- | Column attributes such as nullability, auto increment, etc. 40 | -- When adding elements, make sure that they are added in the order 41 | -- required by SQL syntax, as this list is only sorted before being 42 | -- pretty-printed. 43 | data ColAttr 44 | = Primary 45 | | AutoPrimary AutoIncType 46 | | Required 47 | | Optional 48 | | Unique 49 | | Indexed (Maybe IndexMethod) 50 | deriving (Show, Eq, Ord) 51 | 52 | isAutoPrimary :: ColAttr -> Bool 53 | isAutoPrimary (AutoPrimary _) = True 54 | isAutoPrimary _ = False 55 | 56 | isPrimary :: ColAttr -> Bool 57 | isPrimary Primary = True 58 | isPrimary attr = isAutoPrimary attr 59 | 60 | isUnique :: ColAttr -> Bool 61 | isUnique Unique = True 62 | isUnique (Indexed _) = True 63 | isUnique attr = isPrimary attr 64 | 65 | -- | Method to use for indexing with 'indexedUsing'. 66 | -- Index methods are ignored by the SQLite backend, as SQLite doesn't support 67 | -- different index methods. 68 | data IndexMethod 69 | = BTreeIndex 70 | | HashIndex 71 | -- Omitted until the operator class business is sorted out 72 | -- | GistIndex 73 | -- | GinIndex 74 | deriving (Show, Eq, Ord) 75 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Table/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, CPP #-} 2 | module Database.Selda.Table.Validation where 3 | import Control.Exception ( Exception, throw ) 4 | import Data.List (group, sort) 5 | import Data.Text (Text, any, intercalate, unpack) 6 | import Data.Typeable ( Typeable ) 7 | import Database.Selda.Table.Type 8 | ( ColAttr(Required, Optional), 9 | ColInfo(colFKs, colName, colAttrs), 10 | Table(Table), 11 | isPrimary, 12 | isUnique ) 13 | import Database.Selda.Types 14 | ( TableName, fromColName, fromTableName ) 15 | 16 | -- | An error occurred when validating a database table. 17 | -- If this error is thrown, there is a bug in your database schema, and the 18 | -- particular table that triggered the error is unusable. 19 | -- Since validation is deterministic, this error will be thrown on every 20 | -- consecutive operation over the offending table. 21 | -- 22 | -- Therefore, it is not meaningful to handle this exception in any way, 23 | -- just fix your bug instead. 24 | data ValidationError = ValidationError String 25 | deriving (Show, Eq, Typeable) 26 | instance Exception ValidationError 27 | 28 | -- | Ensure that there are no duplicate column names or primary keys. 29 | -- Returns a list of validation errors encountered. 30 | validate :: TableName -> [ColInfo] -> [Text] 31 | validate name cis = errs 32 | where 33 | colIdents = map (fromColName . colName) cis 34 | allIdents = fromTableName name : colIdents 35 | errs = concat 36 | [ dupes 37 | , pkDupes 38 | , optionalRequiredMutex 39 | , nulIdents 40 | , emptyIdents 41 | , emptyTableName 42 | , nonPkFks 43 | ] 44 | emptyTableName 45 | | fromTableName name == "\"\"" = ["table name is empty"] 46 | | otherwise = [] 47 | emptyIdents 48 | | "\"\"" `elem` colIdents = 49 | ["table has columns with empty names"] 50 | | otherwise = 51 | [] 52 | nulIdents = 53 | [ "table or column name contains \\NUL: " <> n 54 | | n <- allIdents 55 | , Data.Text.any (== '\NUL') n 56 | ] 57 | dupes = 58 | ["duplicate column: " <> fromColName x | (x:_:_) <- soup $ map colName cis] 59 | pkDupes = 60 | ["multiple primary keys" | moreThanOne pkAttrs] 61 | nonPkFks = 62 | [ "column is used as a foreign key, but is not primary or unique: " 63 | <> fromTableName ftn <> "." <> fromColName fcn 64 | | ci <- cis 65 | , (Table ftn fcs _ _, fcn) <- colFKs ci 66 | , fc <- fcs 67 | , colName fc == fcn 68 | , not $ Prelude.any isUnique (colAttrs fc) 69 | ] 70 | 71 | -- This should be impossible, but... 72 | optionalRequiredMutex = 73 | [ "BUG: column " <> fromColName (colName ci) 74 | <> " is both optional and required" 75 | | ci <- cis 76 | , Optional `elem` colAttrs ci && Required `elem` colAttrs ci 77 | ] 78 | 79 | moreThanOne [] = False 80 | moreThanOne [_] = False 81 | moreThanOne _ = True 82 | pkAttrs = 83 | [ attr 84 | | attr <- concatMap colAttrs cis 85 | , isPrimary attr 86 | ] 87 | 88 | -- | Return all columns of the given table if the table schema is valid, 89 | -- otherwise throw a 'ValidationError'. 90 | validateOrThrow :: TableName -> [ColInfo] -> [ColInfo] 91 | validateOrThrow name cols = 92 | case validate name cols of 93 | [] -> cols 94 | errors -> throw $ ValidationError $ concat 95 | [ "validation of table `", unpack $ fromTableName name 96 | , "' failed:\n " 97 | , unpack $ intercalate "\n " errors 98 | ] 99 | 100 | -- | Sort a list and remove all duplicates from it. 101 | snub :: (Ord a, Eq a) => [a] -> [a] 102 | snub = map head . soup 103 | 104 | -- | Sort a list, then group all identical elements. 105 | soup :: Ord a => [a] -> [[a]] 106 | soup = group . sort 107 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Transform.hs: -------------------------------------------------------------------------------- 1 | -- | Analysis and transformation of SQL queries. 2 | module Database.Selda.Transform where 3 | import Database.Selda.Exp 4 | ( allNamesIn, Exp(Col, AggrEx), SomeCol(..) ) 5 | import Database.Selda.SQL 6 | ( SQL(SQL, groups, ordering, liveExtras, source, restricts, cols), 7 | SqlSource(Product, EmptyTable, TableName, Values, RawSql, Union, 8 | Join) ) 9 | import Database.Selda.Query.Type ( GenState(GenState) ) 10 | import Database.Selda.Types ( ColName ) 11 | 12 | -- | Remove all dead columns recursively, assuming that the given list of 13 | -- column names contains all names present in the final result. 14 | removeDeadCols :: [ColName] -> SQL -> SQL 15 | removeDeadCols live sql = 16 | case source sql' of 17 | EmptyTable -> sql' 18 | TableName _ -> sql' 19 | Values _ _ -> sql' 20 | RawSql _ -> sql' 21 | Product qs -> sql' {source = Product $ map noDead qs} 22 | Join jt on l r -> sql' {source = Join jt on (noDead l) (noDead r)} 23 | Union union_all l r -> sql' {source = Union union_all (noDead l) (noDead r)} 24 | where 25 | noDead = removeDeadCols live' 26 | sql' = keepCols (implicitlyLiveCols sql ++ live) sql 27 | live' = allColNames sql' 28 | 29 | -- | Return the names of all columns in the given top-level query. 30 | -- Subqueries are not traversed. 31 | allColNames :: SQL -> [ColName] 32 | allColNames sql = colNames (cols sql) ++ implicitlyLiveCols sql 33 | 34 | -- | Return the names of all non-output (i.e. 'cols') columns in the given 35 | -- top-level query. Subqueries are not traversed. 36 | implicitlyLiveCols :: SQL -> [ColName] 37 | implicitlyLiveCols sql = concat 38 | [ concatMap allNamesIn (restricts sql) 39 | , colNames (groups sql) 40 | , colNames (map snd $ ordering sql) 41 | , colNames (liveExtras sql) 42 | , case source sql of 43 | Join _ on _ _ -> allNamesIn on 44 | _ -> [] 45 | ] 46 | 47 | -- | Get all column names appearing in the given list of (possibly complex) 48 | -- columns. 49 | colNames :: [SomeCol SQL] -> [ColName] 50 | colNames cs = concat 51 | [ [n | Some c <- cs, n <- allNamesIn c] 52 | , [n | Named _ c <- cs, n <- allNamesIn c] 53 | , [n | Named n _ <- cs] 54 | ] 55 | 56 | -- | Remove all columns but the given, named ones and aggregates, from a query's 57 | -- list of outputs. 58 | -- If we want to refer to a column in an outer query, it must have a name. 59 | -- If it doesn't, then it's either not referred to by an outer query, or 60 | -- the outer query duplicates the expression, thereby referring directly 61 | -- to the names of its components. 62 | keepCols :: [ColName] -> SQL -> SQL 63 | keepCols live sql = sql {cols = filtered} 64 | where 65 | filtered = filter (`oneOf` live) (cols sql) 66 | oneOf (Some (AggrEx _ _)) _ = True 67 | oneOf (Named _ (AggrEx _ _)) _ = True 68 | oneOf (Some (Col n)) ns = n `elem` ns 69 | oneOf (Named n _) ns = n `elem` ns 70 | oneOf _ _ = False 71 | 72 | -- | Build the outermost query from the SQL generation state. 73 | -- Groups are ignored, as they are only used by 'aggregate'. 74 | state2sql :: GenState -> SQL 75 | state2sql (GenState [sql] srs _ _ _) = 76 | sql {restricts = restricts sql ++ srs} 77 | state2sql (GenState ss srs _ _ _) = 78 | SQL (allCols ss) (Product ss) srs [] [] Nothing [] False 79 | 80 | -- | Get all output columns from a list of SQL ASTs. 81 | allCols :: [SQL] -> [SomeCol SQL] 82 | allCols sqls = [outCol col | sql <- sqls, col <- cols sql] 83 | where 84 | outCol (Named n _) = Some (Col n) 85 | outCol c = c 86 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Types.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 2 | {-# LANGUAGE GADTs, TypeOperators, TypeFamilies, FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances, DeriveGeneric, OverloadedStrings #-} 5 | {-# LANGUAGE CPP #-} 6 | -- | Basic Selda types. 7 | module Database.Selda.Types 8 | ( (:*:)(..), Head, Tup (..) 9 | , first, second, third, fourth, fifth 10 | , ColName, TableName 11 | , modColName, mkColName, mkTableName, addColSuffix, addColPrefix 12 | , fromColName, fromTableName, rawTableName, intercalateColNames 13 | ) where 14 | import Data.Dynamic ( Typeable ) 15 | import Data.String ( IsString ) 16 | import Data.Text (Text, replace, append, intercalate) 17 | import GHC.Generics (Generic) 18 | 19 | -- | Name of a database column. 20 | newtype ColName = ColName { unColName :: Text } 21 | deriving (Ord, Eq, Show, IsString) 22 | 23 | -- | Name of a database table. 24 | newtype TableName = TableName Text 25 | deriving (Ord, Eq, Show, IsString) 26 | 27 | -- | Modify the given column name using the given function. 28 | modColName :: ColName -> (Text -> Text) -> ColName 29 | modColName (ColName cn) f = ColName (f cn) 30 | 31 | -- | Add a prefix to a column name. 32 | addColPrefix :: ColName -> Text -> ColName 33 | addColPrefix (ColName cn) s = ColName $ Data.Text.append s cn 34 | 35 | -- | Add a suffix to a column name. 36 | addColSuffix :: ColName -> Text -> ColName 37 | addColSuffix (ColName cn) s = ColName $ Data.Text.append cn s 38 | 39 | -- | Convert a column name into a string, with quotes. 40 | fromColName :: ColName -> Text 41 | fromColName (ColName cn) = mconcat ["\"", escapeQuotes cn, "\""] 42 | 43 | -- | Convert column names into a string, without quotes, intercalating the given 44 | -- string. 45 | -- 46 | -- @ 47 | -- intercalateColNames "_" [ColName "a", ColName "b"] == "a_b" 48 | -- @ 49 | intercalateColNames :: Text -> [ColName] -> Text 50 | intercalateColNames inter cs = intercalate inter (escapeQuotes . unColName <$> cs) 51 | 52 | -- | Convert a table name into a string, with quotes. 53 | fromTableName :: TableName -> Text 54 | fromTableName (TableName tn) = mconcat ["\"", escapeQuotes tn, "\""] 55 | 56 | -- | Convert a table name into a string, without quotes. 57 | rawTableName :: TableName -> Text 58 | rawTableName (TableName tn) = escapeQuotes tn 59 | 60 | -- | Create a column name. 61 | mkColName :: Text -> ColName 62 | mkColName = ColName 63 | 64 | -- | Create a column name. 65 | mkTableName :: Text -> TableName 66 | mkTableName = TableName 67 | 68 | -- | Escape double quotes in an SQL identifier. 69 | escapeQuotes :: Text -> Text 70 | escapeQuotes = Data.Text.replace "\"" "\"\"" 71 | 72 | -- | An inductively defined "tuple", or heterogeneous, non-empty list. 73 | data a :*: b where 74 | (:*:) :: a -> b -> a :*: b 75 | deriving (Typeable, Generic) 76 | infixr 1 :*: 77 | 78 | instance (Show a, Show b) => Show (a :*: b) where 79 | show (a :*: b) = show a ++ " :*: " ++ show b 80 | 81 | instance (Eq a, Eq b) => Eq (a :*: b) where 82 | (a :*: b) == (a' :*: b') = a == a' && b == b' 83 | 84 | instance (Ord a, Ord b) => Ord (a :*: b) where 85 | (a :*: b) `compare` (a' :*: b') = 86 | case a `compare` a' of 87 | EQ -> b `compare` b' 88 | o -> o 89 | 90 | type family Head a where 91 | Head (a :*: b) = a 92 | Head a = a 93 | 94 | class Tup a where 95 | tupHead :: a -> Head a 96 | 97 | instance {-# OVERLAPPING #-} Tup (a :*: b) where 98 | tupHead (a :*: _) = a 99 | 100 | instance Head a ~ a => Tup a where 101 | tupHead a = a 102 | 103 | -- | Get the first element of an inductive tuple. 104 | first :: Tup a => a -> Head a 105 | first = tupHead 106 | 107 | -- | Get the second element of an inductive tuple. 108 | second :: Tup b => (a :*: b) -> Head b 109 | second (_ :*: b) = tupHead b 110 | 111 | -- | Get the third element of an inductive tuple. 112 | third :: Tup c => (a :*: b :*: c) -> Head c 113 | third (_ :*: _ :*: c) = tupHead c 114 | 115 | -- | Get the fourth element of an inductive tuple. 116 | fourth :: Tup d => (a :*: b :*: c :*: d) -> Head d 117 | fourth (_ :*: _ :*: _ :*: d) = tupHead d 118 | 119 | -- | Get the fifth element of an inductive tuple. 120 | fifth :: Tup e => (a :*: b :*: c :*: d :*: e) -> Head e 121 | fifth (_ :*: _ :*: _ :*: _ :*: e) = tupHead e 122 | -------------------------------------------------------------------------------- /selda/src/Database/Selda/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- | Unsafe operations giving the user unchecked low-level control over 3 | -- the generated SQL. 4 | module Database.Selda.Unsafe 5 | ( fun, fun2, fun0, operator 6 | , aggr 7 | , cast, castAggr, sink, sink2 8 | , unsafeSelector 9 | , QueryFragment, inj, injLit, rawName, rawExp, rawStm, rawQuery, rawQuery1 10 | ) where 11 | import Control.Exception (throw) 12 | import Control.Monad.State.Strict 13 | ( MonadIO(liftIO), void, MonadState(put, get) ) 14 | import Database.Selda.Backend.Internal 15 | ( SqlType(mkLit, sqlType), 16 | MonadSelda, 17 | SeldaBackend(runStmt, ppConfig), 18 | SeldaError(UnsafeError), 19 | withBackend ) 20 | import Database.Selda.Column 21 | ( BinOp(CustomOp), 22 | UnOp(Fun), 23 | NulOp(Fun0), 24 | Exp(Col, Cast, UnOp, Fun2, BinOp, NulOp, Lit, Raw), 25 | UntypedCol(Untyped), 26 | SomeCol(Named), 27 | hideRenaming, 28 | Same(liftC2), 29 | Row(..), 30 | Col(..), 31 | liftC ) 32 | import Database.Selda.Inner (Inner, Aggr, aggr, liftAggr) 33 | import Database.Selda.Selectors (unsafeSelector) 34 | import Database.Selda.Query.Type (Query (..), sources, renameAll, rename) 35 | import Database.Selda.SQL (QueryFragment (..), SqlSource (RawSql), sqlFrom) 36 | import Database.Selda.SQL.Print (compRaw) 37 | import Database.Selda.SqlRow (SqlRow (..)) 38 | import Database.Selda.Types (ColName) 39 | import Data.Text (Text) 40 | import Data.Proxy ( Proxy(..) ) 41 | import Unsafe.Coerce ( unsafeCoerce ) 42 | 43 | -- | Cast a column to another type, using whichever coercion semantics are used 44 | -- by the underlying SQL implementation. 45 | cast :: forall s a b. SqlType b => Col s a -> Col s b 46 | cast = liftC $ Cast (sqlType (Proxy :: Proxy b)) 47 | 48 | -- | Cast an aggregate to another type, using whichever coercion semantics 49 | -- are used by the underlying SQL implementation. 50 | castAggr :: forall s a b. SqlType b => Aggr s a -> Aggr s b 51 | castAggr = liftAggr cast 52 | 53 | -- | Sink the given function into an inner scope. 54 | -- 55 | -- Be careful not to use this function with functions capturing rows or columns 56 | -- from an outer scope. For instance, the following usage will likely 57 | -- lead to disaster: 58 | -- 59 | -- > query $ do 60 | -- > x <- #age `from` select person 61 | -- > inner $ sink (\p -> x + (p ! #age)) <$> select person 62 | -- 63 | -- Really, if you have to use this function, ONLY do so in the global scope. 64 | sink :: (f s a -> f s b) -> f (Inner s) a -> f (Inner s) b 65 | sink = unsafeCoerce 66 | 67 | -- | Like 'sink', but with two arguments. 68 | sink2 :: (f s a -> f s b -> f s c) -> f (Inner s) a -> f (Inner s) b -> f (Inner s) c 69 | sink2 = unsafeCoerce 70 | 71 | -- | A unary operation. Note that the provided function name is spliced 72 | -- directly into the resulting SQL query. Thus, this function should ONLY 73 | -- be used to implement well-defined functions that are missing from Selda's 74 | -- standard library, and NOT in an ad hoc manner during queries. 75 | fun :: Text -> Col s a -> Col s b 76 | fun = liftC . UnOp . Fun 77 | 78 | -- | Like 'fun', but with two arguments. 79 | fun2 :: Text -> Col s a -> Col s b -> Col s c 80 | fun2 = liftC2 . Fun2 81 | 82 | -- | A custom operator. @operator "~>" a b@ will compile down to 83 | -- @a ~> b@, with parentheses around @a@ and @b@ iff they are not atomic. 84 | -- This means that SQL operator precedence is disregarded, as all 85 | -- subexpressions are parenthesized. In the following example for instance, 86 | -- @foo a b c@ will compile down to @(a ~> b) ~> c@. 87 | -- 88 | -- > (~>) = operator "~>" 89 | -- > infixl 5 ~> 90 | -- > foo a b c = a ~> b ~> c 91 | operator :: Text -> Col s a -> Col s b -> Col s c 92 | operator = liftC2 . BinOp . CustomOp 93 | 94 | -- | Like 'fun', but with zero arguments. 95 | fun0 :: Text -> Col s a 96 | fun0 = One . NulOp . Fun0 97 | 98 | -- | Create a raw SQL query fragment from the given column. 99 | inj :: Col s a -> QueryFragment 100 | inj (One x) = RawExp x 101 | 102 | -- | Create a raw SQL query fragment from the given value. 103 | injLit :: SqlType a => a -> QueryFragment 104 | injLit = RawExp . Lit . mkLit 105 | 106 | -- | Create a column referring to a name of your choice. 107 | -- Use this to refer to variables not exposed by Selda. 108 | rawName :: SqlType a => ColName -> Col s a 109 | rawName = One . Col 110 | 111 | -- | Create an expression from the given text. 112 | -- The expression will be inserted verbatim into your query, so you should 113 | -- NEVER pass user-provided text to this function. 114 | rawExp :: SqlType a => Text -> Col s a 115 | rawExp = One . Raw 116 | 117 | -- | Execute a raw SQL statement. 118 | rawStm :: MonadSelda m => QueryFragment -> m () 119 | rawStm q = withBackend $ \b -> liftIO $ do 120 | void $ uncurry (runStmt b) $ compRaw (ppConfig b) q 121 | 122 | -- | Execute a raw SQL statement, returning a row consisting of columns by the 123 | -- given names. 124 | -- Will fail if the number of names given does not match up with 125 | -- the type of the returned row. 126 | -- Will generate invalid SQL if the given names don't match up with the 127 | -- column names in the given query. 128 | rawQuery :: forall a s. SqlRow a => [ColName] -> QueryFragment -> Query s (Row s a) 129 | rawQuery names q 130 | | length names /= nestedCols (Proxy :: Proxy a) = do 131 | let err = concat 132 | [ "rawQuery: return type has ", show (nestedCols (Proxy :: Proxy a)) 133 | , " columns, but only ", show (length names), " names were given" 134 | ] 135 | throw (UnsafeError err) 136 | | otherwise = Query $ do 137 | rns <- renameAll [Untyped (Col name) | name <- names] 138 | st <- get 139 | put $ st { sources = sqlFrom rns (RawSql q) : sources st } 140 | return (Many (map hideRenaming rns)) 141 | 142 | -- | As 'rawQuery', but returns only a single column. Same warnings still apply. 143 | rawQuery1 :: SqlType a => ColName -> QueryFragment -> Query s (Col s a) 144 | rawQuery1 name q = Query $ do 145 | name' <- head <$> rename (Untyped (Col name)) 146 | st <- get 147 | put $ st { sources = sqlFrom [name'] (RawSql q) : sources st } 148 | case name' of 149 | Named n _ -> return (One (Col n)) 150 | _ -> error "BUG: renaming did not rename" 151 | -------------------------------------------------------------------------------- /stack-ghc-9.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.9 2 | 3 | packages: 4 | - selda 5 | - selda-postgresql 6 | - selda-sqlite 7 | - selda-tests 8 | - selda-json 9 | 10 | extra-deps: [] 11 | -------------------------------------------------------------------------------- /stack-ghc-9.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2022-06-04 2 | 3 | packages: 4 | - selda 5 | - selda-postgresql 6 | - selda-sqlite 7 | - selda-tests 8 | - selda-json 9 | 10 | extra-deps: [] 11 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | 3 | packages: 4 | - selda 5 | - selda-postgresql 6 | - selda-sqlite 7 | - selda-tests 8 | - selda-json 9 | 10 | extra-deps: [] 11 | -------------------------------------------------------------------------------- /website/assets/prism.css: -------------------------------------------------------------------------------- 1 | /* PrismJS 1.15.0 2 | https://prismjs.com/download.html#themes=prism&languages=bash+haskell+sql&plugins=line-numbers */ 3 | /** 4 | * prism.js default theme for JavaScript, CSS and HTML 5 | * Based on dabblet (http://dabblet.com) 6 | * @author Lea Verou 7 | */ 8 | 9 | code[class*="language-"], 10 | pre[class*="language-"] { 11 | color: black; 12 | background: none; 13 | text-shadow: 0 1px white; 14 | font-family: Consolas, Monaco, 'Andale Mono', 'Ubuntu Mono', monospace; 15 | text-align: left; 16 | white-space: pre; 17 | word-spacing: normal; 18 | word-break: normal; 19 | word-wrap: normal; 20 | line-height: 1.5; 21 | 22 | -moz-tab-size: 4; 23 | -o-tab-size: 4; 24 | tab-size: 4; 25 | 26 | -webkit-hyphens: none; 27 | -moz-hyphens: none; 28 | -ms-hyphens: none; 29 | hyphens: none; 30 | } 31 | 32 | pre[class*="language-"]::-moz-selection, pre[class*="language-"] ::-moz-selection, 33 | code[class*="language-"]::-moz-selection, code[class*="language-"] ::-moz-selection { 34 | text-shadow: none; 35 | background: #b3d4fc; 36 | } 37 | 38 | pre[class*="language-"]::selection, pre[class*="language-"] ::selection, 39 | code[class*="language-"]::selection, code[class*="language-"] ::selection { 40 | text-shadow: none; 41 | background: #b3d4fc; 42 | } 43 | 44 | @media print { 45 | code[class*="language-"], 46 | pre[class*="language-"] { 47 | text-shadow: none; 48 | } 49 | } 50 | 51 | /* Code blocks */ 52 | pre[class*="language-"] { 53 | padding: 1em; 54 | padding-top: 0; 55 | padding-bottom: 0; 56 | margin: .5em 0; 57 | overflow: auto; 58 | } 59 | 60 | :not(pre) > code[class*="language-"], 61 | pre[class*="language-"] { 62 | background: #f0f0f0; 63 | border-radius: 0.5em; 64 | } 65 | 66 | /* Inline code */ 67 | :not(pre) > code[class*="language-"] { 68 | padding: .1em; 69 | border-radius: .3em; 70 | white-space: normal; 71 | } 72 | 73 | .token.comment, 74 | .token.prolog, 75 | .token.doctype, 76 | .token.cdata { 77 | color: slategray; 78 | } 79 | 80 | .token.punctuation { 81 | color: #999; 82 | } 83 | 84 | .namespace { 85 | opacity: .7; 86 | } 87 | 88 | .token.property, 89 | .token.tag, 90 | .token.boolean, 91 | .token.number, 92 | .token.constant, 93 | .token.symbol, 94 | .token.deleted { 95 | color: #905; 96 | } 97 | 98 | .token.selector, 99 | .token.attr-name, 100 | .token.string, 101 | .token.char, 102 | .token.builtin, 103 | .token.inserted { 104 | color: #690; 105 | } 106 | 107 | .token.operator, 108 | .token.entity, 109 | .token.url, 110 | .language-css .token.string, 111 | .style .token.string { 112 | color: #9a6e3a; 113 | } 114 | 115 | .token.atrule, 116 | .token.attr-value, 117 | .token.keyword { 118 | color: #07a; 119 | } 120 | 121 | .token.function, 122 | .token.class-name { 123 | color: #DD4A68; 124 | } 125 | 126 | .token.regex, 127 | .token.important, 128 | .token.variable { 129 | color: #e90; 130 | } 131 | 132 | .token.important, 133 | .token.bold { 134 | font-weight: bold; 135 | } 136 | .token.italic { 137 | font-style: italic; 138 | } 139 | 140 | .token.entity { 141 | cursor: help; 142 | } 143 | 144 | pre[class*="language-"].line-numbers { 145 | position: relative; 146 | padding-left: 3.8em; 147 | counter-reset: linenumber; 148 | } 149 | 150 | pre[class*="language-"].line-numbers > code { 151 | position: relative; 152 | white-space: inherit; 153 | } 154 | 155 | .line-numbers .line-numbers-rows { 156 | position: absolute; 157 | pointer-events: none; 158 | top: 0; 159 | font-size: 100%; 160 | left: -3.8em; 161 | width: 3em; /* works for line-numbers below 1000 lines */ 162 | letter-spacing: -1px; 163 | border-right: 1px solid #999; 164 | 165 | -webkit-user-select: none; 166 | -moz-user-select: none; 167 | -ms-user-select: none; 168 | user-select: none; 169 | 170 | } 171 | 172 | .line-numbers-rows > span { 173 | pointer-events: none; 174 | display: block; 175 | counter-increment: linenumber; 176 | } 177 | 178 | .line-numbers-rows > span:before { 179 | content: counter(linenumber); 180 | color: #999; 181 | display: block; 182 | padding-right: 0.8em; 183 | text-align: right; 184 | } 185 | 186 | -------------------------------------------------------------------------------- /website/assets/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | Disallow: 3 | 4 | SITEMAP: https://selda.link/sitemap.txt 5 | -------------------------------------------------------------------------------- /website/assets/selda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/valderman/selda/ab9619db13b93867d1a244441bb4de03d3e1dadb/website/assets/selda.png -------------------------------------------------------------------------------- /website/assets/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | line-height: 1.5em; 3 | font-family: sans-serif; 4 | } 5 | 6 | .biglink { 7 | display: inline-block; 8 | width: 100%; 9 | text-align: center; 10 | margin-top: 2em; 11 | } 12 | 13 | .biglink a { 14 | background-color: black; 15 | padding: 0.8em; 16 | color: white; 17 | font-size: large; 18 | font-weight: bold; 19 | border-radius: 0.3em; 20 | text-decoration: none; 21 | } 22 | 23 | .biglink a:hover { 24 | background-color: #202020; 25 | } 26 | 27 | /* Logo and headings */ 28 | h1 { 29 | text-align: center; 30 | padding: 0.5em; 31 | margin: 0; 32 | line-height: 1.2em; 33 | } 34 | 35 | :not(.tinylogo) > a > #logo { 36 | position: absolute; 37 | width: 20em; 38 | left: 0; 39 | right: 0; 40 | max-width: 90%; 41 | margin: auto; 42 | } 43 | 44 | .tinylogo > a > #logo { 45 | position: fixed; 46 | z-index: 1000; 47 | filter: invert(100%); 48 | -webkit-filter: invert(100%); 49 | height: 2.5rem; 50 | right: 2rem; 51 | } 52 | 53 | .tinylogo > h1 { 54 | position: fixed; 55 | color: white; 56 | z-index: 1000; 57 | font-size: 0.6rem; 58 | display: inline-block; 59 | padding-top: 0.7rem; 60 | width: 6rem; 61 | } 62 | 63 | .tinylogo > h1 > a { 64 | color: white; 65 | text-decoration: none; 66 | } 67 | 68 | :not(.tinylogo) > h1 > a { 69 | color: black; 70 | text-decoration: none; 71 | } 72 | 73 | @media (max-width: 510px) { 74 | .tinylogo > h1 { 75 | display: none; 76 | } 77 | .tinylogo > #logo { 78 | display: none; 79 | } 80 | } 81 | 82 | /* The menu (non-mobile) */ 83 | ul.menu { 84 | left: 0; 85 | padding: 0; 86 | margin: 0; 87 | width: 100%; 88 | list-style-type: none; 89 | background-color: black; 90 | text-align: center; 91 | } 92 | 93 | :not(.tinylogo) > ul.menu { 94 | position: absolute; 95 | top: 20em; 96 | } 97 | 98 | .tinylogo > .menu { 99 | top: 0; 100 | position: fixed; 101 | } 102 | 103 | .menu li { 104 | display: inline-block; 105 | padding: 0; 106 | font-size: large; 107 | } 108 | 109 | .menu li a { 110 | color: white; 111 | display: block; 112 | padding: 1em; 113 | text-decoration: none; 114 | font-weight: bold; 115 | font-family: sans-serif; 116 | } 117 | 118 | .menu li a:hover { 119 | background-color: #202020; 120 | } 121 | 122 | /* Lower half of page */ 123 | #content { 124 | position: absolute; 125 | left: 0; 126 | right: 0; 127 | margin: auto; 128 | z-index: -10; 129 | } 130 | 131 | .tinylogo > #content { 132 | top: 4em; 133 | } 134 | 135 | :not(.tinylogo) > #content { 136 | top: 25em; 137 | } 138 | 139 | .pane { 140 | display: inline; 141 | width: 45%; 142 | padding: 1em; 143 | } 144 | 145 | pre code { 146 | font-size: 0.8rem; 147 | padding-top: 1em; 148 | padding-bottom: 1em; 149 | display: block; 150 | } 151 | 152 | @media (min-width: 950px) { 153 | code.narrowcode {display: none;} 154 | #content { 155 | width: 80%; 156 | min-width: 60em; 157 | } 158 | #left { 159 | float: left; 160 | } 161 | #right:not(.fixed) { 162 | right: 0; 163 | position: absolute; 164 | } 165 | #right.fixed { 166 | position: fixed; 167 | width: 36%; 168 | right: 10%; 169 | } 170 | } 171 | 172 | @media (max-width: 949px) { 173 | code.widecode {display: none;} 174 | .menu li a { 175 | padding-left: 0.5em; 176 | padding-right: 0.5em; 177 | font-size: 0.8em; 178 | } 179 | 180 | h1 { 181 | font-size: 1.5em; 182 | } 183 | 184 | #content { 185 | top: 23em; 186 | width: 80%; 187 | } 188 | 189 | .tinylogo > h1 { 190 | padding-top: 0.5rem; 191 | } 192 | } 193 | -------------------------------------------------------------------------------- /website/cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | -------------------------------------------------------------------------------- /website/compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | module Main where 3 | import Control.Monad 4 | import Data.Aeson (Value (..)) 5 | import Data.String 6 | import Data.Text (Text, pack, unpack) 7 | import Data.Text.Lazy (toStrict, fromStrict) 8 | import qualified Data.Text as Text 9 | import System.Directory 10 | import System.FilePath 11 | import Text.Blaze.Html.Renderer.Text (renderHtml) 12 | import Text.Markdown 13 | import Text.Mustache 14 | 15 | import BaseUrl (baseUrl) 16 | 17 | tagline :: Text 18 | tagline = "A Haskell SQL Library" 19 | 20 | tutorialTagline :: Text 21 | tutorialTagline = "The Tutorial of Selda | " <> tagline 22 | 23 | metaAuthor :: Text 24 | metaAuthor = "Anton Ekblad" 25 | 26 | 27 | -- Implementation details from here on 28 | 29 | data Link = Link 30 | { linkURL :: Text 31 | , linkText :: Text 32 | } 33 | 34 | (|>) :: Text -> Text -> Link 35 | (|>) = Link 36 | 37 | data Page = Page 38 | { pageTitle :: Text 39 | , pageFileName :: FilePath 40 | , pageSubdirectory :: FilePath 41 | , pageTemplate :: FilePath 42 | , pageDescription :: Text 43 | , pageBigLogo :: Bool 44 | } 45 | 46 | allPages :: [Page] 47 | allPages = 48 | [ Page ("Selda: " <> tagline) 49 | "" 50 | "." 51 | "default" 52 | "Selda is a monadic SQL library for Haskell. It uses advanced type magic to enable seamless prepared statements, well-scoped, fully general inner queries, automatic in-process caching, and much more." 53 | True 54 | 55 | , Page ("The Tutorial of Selda | " <> tagline) 56 | "tutorial" 57 | "." 58 | "default" 59 | "Learn how to build database applications with Selda, starting from basics and gradually progressing towards advanced concepts." 60 | False 61 | 62 | , Page ("Chapter 1: An Example, Explained | " <> tutorialTagline) 63 | "ch1-example-explained" 64 | "tutorial" 65 | "default" 66 | "Learn how to create a simple database application with Selda." 67 | False 68 | 69 | , Page ("Chapter 1: Destructive Operations | " <> tutorialTagline) 70 | "ch2-destructive-operations" 71 | "tutorial" 72 | "default" 73 | "Learn how to update, delete and modify table rows with Selda." 74 | False 75 | 76 | , Page ("Chapter 3: Advanced Queries | " <> tutorialTagline) 77 | "ch3-advanced-queries" 78 | "tutorial" 79 | "default" 80 | "Master database queries using Selda." 81 | False 82 | ] 83 | 84 | loadPage :: Page -> IO (PageCtx, Template) 85 | loadPage page = do 86 | let templateFile = "templates" pageTemplate page <.> "html" 87 | pageFile = "pages" pageSubdirectory page maybeIndex (pageFileName page) <.> "md" 88 | Right template <- localAutomaticCompile templateFile 89 | content <- pack <$> readFile pageFile 90 | let render = toStrict . renderHtml . markdown def . fromStrict 91 | ctx = PageCtx 92 | { siteContent = render content 93 | , siteTitle = pageTitle page 94 | , siteDescription = pageDescription page 95 | , siteAuthor = metaAuthor 96 | , siteBaseUrl = baseUrl 97 | , siteBigLogo = pageBigLogo page 98 | } 99 | return (ctx, template) 100 | where 101 | maybeIndex "" = "index" 102 | maybeIndex f = f 103 | 104 | data PageCtx = PageCtx 105 | { siteContent :: Text 106 | , siteTitle :: Text 107 | , siteDescription :: Text 108 | , siteAuthor :: Text 109 | , siteBaseUrl :: Text 110 | , siteBigLogo :: Bool 111 | } 112 | 113 | instance ToMustache Link where 114 | toMustache (Link url text) = object ["url" ~> url, "text" ~> text] 115 | 116 | instance ToMustache PageCtx where 117 | toMustache ctx = object 118 | [ "description" ~> siteDescription ctx 119 | , "author" ~> siteAuthor ctx 120 | , "title" ~> siteTitle ctx 121 | , "content" ~> siteContent ctx 122 | , "base" ~> siteBaseUrl ctx 123 | , "biglogo" ~> siteBigLogo ctx 124 | ] 125 | 126 | copyFilesIn :: FilePath -> FilePath -> IO () 127 | copyFilesIn from to = do 128 | fs <- getDirectoryContents from 129 | forM_ [f | f <- fs, take 1 f /= "."] $ \f -> do 130 | copyFile (from f) (to f) 131 | 132 | writePage :: Page -> IO () 133 | writePage page = do 134 | (ctx, template) <- loadPage page 135 | let content = substitute template ctx 136 | path = pageSubdirectory page pageFileName page 137 | outFile = siteDirectory path "index.html" 138 | createDirectoryIfMissing True (siteDirectory path) 139 | writeFile outFile (unpack content) 140 | addToSiteMap page 141 | 142 | addToSiteMap :: Page -> IO () 143 | addToSiteMap Page{..} = do 144 | appendFile sitemapFile (pageUrl <> "\n") 145 | where 146 | base = unpack baseUrl 147 | subdir 148 | | pageSubdirectory == "." = "" 149 | | otherwise = pageSubdirectory 150 | pageUrl = base subdir pageFileName 151 | 152 | 153 | sitemapFile :: FilePath 154 | sitemapFile = siteDirectory "sitemap.txt" 155 | 156 | siteDirectory :: FilePath 157 | siteDirectory = "_site" 158 | 159 | main :: IO () 160 | main = do 161 | dirExists <- doesDirectoryExist siteDirectory 162 | when dirExists $ removeDirectoryRecursive siteDirectory 163 | createDirectoryIfMissing True siteDirectory 164 | 165 | copyFilesIn "assets" siteDirectory 166 | mapM_ writePage allPages 167 | -------------------------------------------------------------------------------- /website/pages/index.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | ## What is Selda? 4 | 5 | Selda is an EDSL — an *embedded domain-specific language* 6 | — for defining, querying and modifying relational databases 7 | from Haskell. 8 | The same type-safe Selda query can be executed unmodified on 9 | either PostgreSQL or SQLite, making Selda ideal for prototyping 10 | as well as for taking the step from prototype to real application. 11 | 12 | Through its monadic interface, Selda supports writing queries in a 13 | linear, natural style. The generated SQL code is guaranteed to be 14 | correct, type-safe and executable on all supported backends. 15 | With a minimalist approach to dependencies, Selda is lightweight 16 | enough to be suitable for inclusion in libraries as well as full 17 | applications. 18 | All non-essential features are optional, either through configuration 19 | flags or through separate add-on packages. 20 | 21 | ## Features 22 | * Type-safe queries, inserts, updates and deletes 23 | * Monadic query language with general inner queries 24 | * Seamless prepared statements 25 | * Typed migrations 26 | * Upserts, transactions, indexes and constraints 27 | * Minimal dependencies 28 | * Backends for PostgreSQL and SQLite 29 | * JSON processing on supported backends 30 | * ...and much more! 31 | 32 |
33 | 34 | 35 | 86 | -------------------------------------------------------------------------------- /website/pages/tutorial.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | ## The Tutorial of Selda 4 | 5 | As Selda uses a lot of fancy type magic to achieve a safe yet flexible 6 | programming model, figuring out how to use it from type signatures alone 7 | can be hard. While the types keep queries nice and safe, Haskell's type errors 8 | can be a bit daunting even under the best circumstances. 9 | 10 | This tutorial aims to give the reader a thorough intuition of how Selda works 11 | and why, to make those type errors more manageable and to help the reader avoid 12 | making them in the first place. 13 | 14 | Selda uses GHC's custom type error mechanism to make type errors more helpful, 15 | so if you encounter an error that confuses you even after reading this tutorial, 16 | please [file a bug](https://github.com/valderman/selda/issues/new) and we'll see 17 | what we can do about it. 18 | 19 | This tutorial assumes that the reader is already familiar with 20 | relational databases and can write and understand simple SQL queries. 21 | It is structured around a series of progressively more advanced Selda examples, 22 | which are dissected and discussed in depth, concept by concept. 23 | 24 | 25 | Get started! 26 | 27 | 28 |
29 | 30 | 52 | -------------------------------------------------------------------------------- /website/pages/tutorial/ch1-example-explained.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | ## Chapter 1: An Example, Explained 4 | 5 | To start learning the basics of Selda, let's dissect the example from 6 | the front page of the website, and use it to illustrate the core concepts 7 | of the Selda library. 8 | 9 | After reading this chapter, you will be able to define and create tables, 10 | insert new rows, and perform simple queries against those tables. 11 | 12 | ```language-haskell 13 | {-# LANGUAGE DeriveGeneric, OverloadedStrings, OverloadedLabels #-} 14 | import Database.Selda 15 | import Database.Selda.SQLite 16 | ``` 17 | 18 | We start off by declaring the language extensions we'll need to use, and 19 | importing the core Selda library and the SQLite backend. 20 | `Database.Selda` houses the Selda DSL itself, whereas 21 | `Database.Selda.SQLite` allows us to run Selda programs over SQLite databases. 22 | 23 | The `DeriveGeneric` extension lets us derive the `Generic` type class, which 24 | is important since Selda uses generics heavily to map Haskell types to database 25 | tables. `OverloadedStrings` is not strictly required, but highly recommended 26 | to reduce boilerplate when working with `Text` fields. 27 | `OverloadedLabels` is used to specify *field selectors*, which 28 | will be explained in greater detail [a few paragraphs down](tutorial/ch1-example-explained#selectors). 29 | 30 | ```language-haskell 31 | data Pet = Dog | Horse | Dragon 32 | deriving (Show, Read, Bounded, Enum) 33 | instance SqlType Pet 34 | ``` 35 | 36 | Here, we declare a `Pet` *enumeration type*, to represent the various types 37 | of pets one might have. Selda is able to map enumeration types — any type 38 | implementing `Enum` and `Bounded` — if we just add an `SqlType` instance 39 | for it. In this case, we also derive `Show` and `Read` which automatically 40 | gives us the appropriate conversions between our `Pet` type and its database 41 | representation. 42 | 43 | The `SqlType` type class denotes types which are representable as a single 44 | database column. These types include various numeric types, `Text`, 45 | date and time types, etc. 46 | 47 | ```language-haskell 48 | data Person = Person 49 | { name :: Text 50 | , age :: Int 51 | , pet :: Maybe Pet 52 | } deriving Generic 53 | instance SqlRow Person 54 | ``` 55 | 56 | Now it's time to create a data type to describe our table. 57 | Any product type — a type with a single data constructor — where all fields 58 | are instances of `SqlType` can be used for tables and as results from queries 59 | if they implement the `SqlRow` type class. 60 | By deriving `Generic` for our type, we can use the default `SqlRow` instance. 61 | In fact, you should never need to implement `SqlRow` yourself. 62 | 63 | 64 | 65 | ```language-haskell 66 | people :: Table Person 67 | people = table "people" [#name :- primary] 68 | ``` 69 | 70 | Once we have the `Person` type and its `SqlRow` instance, building a table 71 | from it is easy. 72 | The `table` function accepts a table name, and a list of column attributes where 73 | things like indexes, foreign keys and other constraints can be declared. 74 | Such attributes are specified by linking *selectors* of the table 75 | — such as `#name` in this example — to various attribute 76 | definitions. 77 | In our example, we want to specify the `name` field as the primary key of our 78 | table. 79 | 80 | Field selectors work by passing the *name* of a plain Haskell record selector, 81 | using the `OverloadedLabels` extension, to the `field` function *as a type*, 82 | which then performs some type-level magic to 83 | ensure that the selector is valid for the row we want to use it on. 84 | If this makes your head spin, don't worry; the only thing you need to remember 85 | about field selectors is `#-sign + record selector = field selector`. 86 | 87 | There also exists a handy function `selectors`, which generates 88 | all selectors for some table in one go. 89 | In fact, since the `#...` syntax requires the presence of an actual 90 | record selector, using `selectors` is the *only* way to define selectors for 91 | non-record types, such as `(Int, Int)` or `data Foo = Foo Text Bool Double`. 92 | 93 | 94 | ```language-haskell 95 | main = withSQLite "people.sqlite" $ do 96 | ... 97 | ``` 98 | 99 | To run a Selda program, we need to specify a database to run it over. 100 | In our example, we use the SQLite database and specify `people.sqlite` as the 101 | file in which our database will be stored. 102 | 103 | Selda computations are written in some monad which implements the 104 | `MonadSelda` type class. For most Selda programs — including our example — the 105 | built-in `SeldaM` monad is just fine. 106 | Unless you really want to, you'll never need to bother with implementing 107 | a Selda monad of your own. 108 | 109 | ```language-haskell 110 | createTable people 111 | insert_ people 112 | [ Person "Velvet" 19 (Just Dog) 113 | , Person "Kobayashi" 23 (Just Dragon) 114 | , Person "Miyu" 10 Nothing 115 | ] 116 | ``` 117 | 118 | Before we can store any data in a table, we need to create it. 119 | The `createTable` function will attempt to create its given table, and throw 120 | a `SeldaError` if the table already exists. 121 | 122 | Once we've created our table, we use `insert_` to insert three rows into 123 | our newly created table. Each row is represented by a plain Haskell value of 124 | the table's type. 125 | 126 | ```language-haskell 127 | adultsAndTheirPets <- query $ do 128 | ... 129 | ``` 130 | 131 | The main meat of the Selda library is, of course, queries. 132 | Within a Selda computation the database can be queried using the `query` 133 | function, which takes a query computation as its input. 134 | 135 | Queries are written in the `Query` monad, which is parameterised over a 136 | *scope parameter* `s`. 137 | This parameter ensures that queries are always well-scoped (i.e. do not access 138 | columns which are not in scope). 139 | While this parameter makes type errors more complicated, it is a necessary evil 140 | as it lets us reconcile the differences in scoping between SQL and Haskell 141 | in a safe and (more or less) elegant way. 142 | 143 | 144 | ```language-haskell 145 | person <- select people 146 | ``` 147 | 148 | The `select` function is used to draw data rows from a table. 149 | In this example `person` has the type `Row s Person`, and represents a single 150 | row from the `people` table. 151 | 152 | ```language-haskell 153 | restrict (person ! #age .>= 18) 154 | ``` 155 | 156 | The columns of a row can be accessed using the table's selectors. 157 | The syntax for this is `row ! selector`. The column thus obtained can then be 158 | arbitrarily used in expressions. 159 | 160 | In this example, we use the `restrict` function (roughly equivalent 161 | to SQL `WHERE`) to filter out all persons who have an `age` lower than 18. 162 | 163 | ```language-haskell 164 | return (person ! #name :*: person ! #pet) 165 | ``` 166 | 167 | Once we're done fetching rows and filtering, we can return any number of rows 168 | or columns, grouped together as an *inductive tuple* — 169 | one or more values separated by the `:*:` data constructor. 170 | 171 | Whatever we return from a query will, upon execution, be converted to 172 | the corresponding Haskell type and returned from the `query` call we just 173 | returned from. 174 | 175 | The rows from a query are returned as a list, which each element corresponding 176 | to a single result row. For instance, a query of type `Query s (Row s Person)` 177 | will return `[Person]` when executed, and a query of 178 | type `Query s (Row s Person :*: Col s Int)` will return `[Person :*: Int]`. 179 | 180 | In this particular example, the `name` field of the person table has type 181 | `Text` and the `pet` field has type `Maybe Text`. 182 | From this we can deduce that the query has type 183 | `Query s (Col s Text :*: Col s (Maybe Text))`, meaning that the type returned 184 | back to Haskell land will be `[Text :*: Maybe Text]`. 185 | 186 | ```language-haskell 187 | liftIO $ print adultsAndTheirPets 188 | ``` 189 | 190 | To verify that this whole example works as advertised, we print out the entire 191 | result set of the query. 192 | As `SeldaM` implements `MonadIO` we can just lift the standard `print` function 193 | into the computation. 194 | 195 | Since Miyu is the only person in the table who is under the age of 18, 196 | the result set, when printed, should look like this: 197 | 198 | ```language-haskell 199 | ["Velvet" :*: Just Dog,"Kobayashi" :*: Just Dragon] 200 | ``` 201 | 202 |
203 | 204 | 245 | -------------------------------------------------------------------------------- /website/pages/tutorial/ch2-destructive-operations.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | ## Chapter 2: Destructive Operations 4 | 5 | A database we can't modify in any meaningful way is no good, so let's 6 | have a closer look at how to make our database reflect changes to the real world. 7 | Throughout this chapter, we're going to work with the table and data presented 8 | to the right of the text. 9 | 10 | After reading this chapter, you will be able to add, update and delete 11 | table rows. You will also gain a better understanding of the types involved, 12 | as all examples from this chapter on include full type signatures. 13 | 14 | ### All About Inserts 15 | 16 | As we saw in the previous chapter, inserting data into a table is easy. 17 | However, the table from the first chapter is often a bit too simplistic. 18 | Recall that we used the name of a person as the table's primary key. 19 | What if the user changes their name, or if there are multiple persons with 20 | the same name? 21 | 22 | For reasons like this, we often want the database to keep track of primary 23 | keys for us, so for this chapter we've added the `pid` column to the table, 24 | which will at all times contain the unique identifier of each row. 25 | 26 | ```language-haskell 27 | data Person = Person 28 | { pid :: ID Person 29 | ... 30 | ``` 31 | 32 | Since we want the database to manage the identifier for us, we have to add a 33 | column attribute, specifying that `pid` is an *auto-incrementing* primary key. 34 | 35 | ```language-haskell 36 | people :: Table Person 37 | people = table "people" [#pid :- autoPrimary] 38 | ``` 39 | 40 | With these simple changes, we can now use the somewhat magical `def` value when 41 | inserting data, to tell the database that we want to use the *default* value 42 | for the `pid` column. 43 | 44 | It is worth noting that `def` can be used for *any* column to which we want to 45 | assign a default value. However, it is only when used as an auto-incrementing 46 | primary key that `def` ensures the uniqueness of the value; in all other cases 47 | it is simply the "least" value of the type, such as `False`, `""` or `Nothing`. 48 | 49 | ```language-haskell 50 | insertSara :: SeldaM b () 51 | insertSara = insert_ people [Person def "Sara" 14 Nothing] 52 | ``` 53 | 54 | If we perform the insert and then select all table rows, we'll find that Sara 55 | was added to the table with a unique identifier. 56 | 57 | ```language-haskell 58 | insertThenInspect :: SeldaM b [Person] 59 | insertThenInspect = do 60 | insertSara 61 | query (select people) 62 | ``` 63 | 64 | ```language-haskell 65 | pid | name | age | pet 66 | --------------------------- 67 | 1 | Velvet | 19 | Just Dog 68 | 2 | Kobayashi | 23 | Just Dragon 69 | 3 | Miyu | 10 | Nothing 70 | 4 | Sara | 14 | Nothing 71 | ``` 72 | 73 | When using auto-incrementing primary keys, we often want to know what ID 74 | a particular row got when we inserted it. 75 | The `insertWithPK` function is handy for this. 76 | 77 | ```language-haskell 78 | insertAndPrintPk :: SeldaM b () 79 | insertAndPrintPk = do 80 | pk <- insertWithPK people [Person def Sara 14 Nothing] 81 | liftIO (print pk) 82 | ``` 83 | ```language-haskell 84 | > withSQLite "database.sqlite" insertAndPrintPk 85 | 4 86 | ``` 87 | 88 | ### Updates 89 | 90 | As time goes by, people age, their pets die, and thus our `people` table 91 | will need to be regulary updated to stay in sync with reality. 92 | Fortunately, Selda's got your back: 93 | 94 | ```language-haskell 95 | update :: (MonadSelda m, Relational a) 96 | => Table a 97 | -> (Row s a -> Col s Bool) 98 | -> (Row s a -> Row s a) 99 | -> m Int 100 | ``` 101 | 102 | The `update` function takes a table, a predicate, and an update function as its 103 | inputs, and returns the number of rows affected by the update. 104 | For each row that matches the given predicate — where the predicate 105 | returns `true` — Selda applies the given update function. 106 | 107 | Let's assume, for instance, that we're feeling sorry for anyone who hasn't got 108 | a pet, and decide to give every pet-less person a dog: 109 | 110 | ```language-haskell 111 | petsForEveryone :: SeldaM b Int 112 | petsForEveryone = do 113 | update people 114 | (\person -> isNull (person ! #pet)) 115 | (\person -> person `with` [#pet := just (literal Dog)]) 116 | ``` 117 | 118 | Here we see the use of `with` for the first time. 119 | The `with` function takes a table row and a list of updates — expressed 120 | as selector-expression pairs — and applies the updates, 121 | from left to right, to the table row. 122 | 123 | The most basic update is `:=`, which simply overwrites the column 124 | indicated by its given selector with its given expression, but there are also 125 | convenient shortcuts for common operations such as incrementing or decrementing 126 | values: 127 | 128 | ```language-haskell 129 | ageEveryone :: SeldaM b Int 130 | ageEveryone = do 131 | update people (const true) (\person -> person `with` [#age += 1]) 132 | ``` 133 | 134 | As expected, this function will increment everyone's age by one. 135 | 136 | ### Conditional Updates 137 | 138 | Sometimes it can be useful to update a table row *or* add it to the table if 139 | it doesn't exist. This is sometimes referred to as an *upsert*. 140 | In Selda, this is handled by the `upsert` function. 141 | 142 | ```language-haskell 143 | upsert :: ( MonadSelda m 144 | , Relational a 145 | ) 146 | => Table a 147 | -> (Row s a -> Col s Bool) 148 | -> (Row s a -> Row s a) 149 | -> [a] 150 | -> m (Maybe (ID a)) 151 | ``` 152 | 153 | This function works much like `update`, but takes an additional list of elements, 154 | to be inserted into the table iff *no rows currently in the given table match 155 | the given predicate*. 156 | 157 | To grant a horse to any person named Miyu, and to create a horse owner by that 158 | name if none exists, we would do the following: 159 | 160 | ```language-haskell 161 | horseForMiyu :: SeldaM b () 162 | horseForMiyu = do 163 | result <- upsert people 164 | (\person -> person ! #name .== "Miyu") 165 | (\person -> person `with` [#pet := just (literal Horse)]) 166 | [Person def Miyu 10 Nothing] 167 | case result of 168 | Just id -> liftIO $ putStrLn ("person inserted with id " ++ show id) 169 | Nothing -> liftIO $ putStrLn "update performed; no person inserted" 170 | ``` 171 | ```language-haskell 172 | > withSQLite "database.sqlite" horseForMiyu 173 | update performed; no person inserted 174 | ``` 175 | 176 | Apart from `upsert`, there are several less general conditional inserts, which 177 | often result in clearer code. 178 | Checking out the [API documentation](https://hackage.haskell.org/package/selda) 179 | is highly recommended. 180 | 181 | ### Deleting Rows 182 | 183 | Compared to inserts and updates, there is really not much to say about delete 184 | operations. 185 | 186 | ```language-haskell 187 | deleteFrom :: (MonadSelda m, Relational a) 188 | => Table a 189 | -> (Row s a -> Col s Bool) 190 | -> m Int 191 | ``` 192 | 193 | The delete operation takes a table to delete stuff from, and a predicate 194 | determining which rows to delete. 195 | Every row that matches the predicate is deleted, and `deleteFrom` returns 196 | the number of deleted rows. 197 | 198 | Let's say, for instance, that we want to delete all dragon owners from the 199 | table (they've probably gotten eaten already anyway): 200 | 201 | ```language-haskell 202 | deleteDragonOwners :: SeldaM b Int 203 | deleteDragonOwners = do 204 | deleteFrom persons (\person -> person ! #pet .== just (literal Dragon)) 205 | ``` 206 | ```language-haskell 207 | > withSQLite "database.sqlite" deleteDragonOwners 208 | 1 209 | > withSQLite "database.sqlite" (query $ select persons) 210 | pid | name | age | pet 211 | ------------------------ 212 | 1 | Velvet | 19 | Just Dog 213 | 3 | Miyu | 10 | Nothing 214 | ``` 215 | 216 |
217 | 218 | 253 | -------------------------------------------------------------------------------- /website/pages/tutorial/ch3-advanced-queries.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | ## Chapter 3: Advanced Queries 4 | 5 | While fetching rows from a single table is all well and good, most applications 6 | require a bit more interesting queries. 7 | This chapter will teach you how to correlate data between multiple tables, and 8 | to conjure up table rows from thin air. 9 | 10 | 11 | ### Product Queries 12 | 13 | Perhaps the most basic capability of a relational database is to correlate 14 | data between different tables, hence the *relational* part. 15 | In Selda, the monadic bind operator performs this function. 16 | In less theoretical terms, to combine data from multiple tables, simply use 17 | the `select` operation on each desired table. 18 | This mechanism should be familiar to you if you've ever used list comprehensions. 19 | 20 | To illustrate the concept, this query returns a list of pairs of all people 21 | in our database and any homes they happen to own. 22 | 23 | ```language-haskell 24 | peopleWithHomes :: Query s (Row s Person :*: Row s Home) 25 | peopleWithHomes = do 26 | person <- select people 27 | home <- select homes 28 | restrict (person ! #name .== home ! #ownerName) 29 | return (person :*: home) 30 | ``` 31 | 32 | The type signature of this query merits some explanation, as this is the first 33 | time we've seen one explicitly spelled out. 34 | As mentioned in [chapter 1](tutorial/ch1-example-explained), all Selda queries 35 | are executed in the `Query` monad, which is parameterised over 36 | a *scope type* `s`. 37 | 38 | All rows and columns originating from any given scope `s` are tagged with that 39 | `s`. This prevents queries in *another* scope from accessing those values, as 40 | all Selda operations ensure that the `s` of the current query and the `s` of the 41 | data being operated on are identical. 42 | 43 | So far, we haven't encountered any queries that are convoluted enough for this 44 | to matter. Once we get to 45 | [joins and aggregates](tutorial/ch4-joins-and-aggregates) however, the necessity 46 | of the scope parameter will become apparent. 47 | 48 | 49 | ### Set Membership 50 | 51 | The `peopleWithHomes` query does not include any persons who *don't* have 52 | a home. Not wanting to marginalize homeless people further, let's write a 53 | function that finds all such persons. 54 | 55 | The set of homeless people can be defined as the set of people who do 56 | *not* appear in the set of home owners. 57 | This means that we can check whether any particular person is homeless 58 | using the `isIn` function, which determines whether some 59 | particular value is contained in some other result set. 60 | 61 | ```language-haskell 62 | homelessPeople :: Query s (Row s Person) 63 | homelessPeople = do 64 | person <- select people 65 | restrict (not_ $ (person ! #name) `isIn` (#ownerName `from` select homes)) 66 | return person 67 | ``` 68 | 69 | The set of home owners is produced by the query 70 | ``#ownerName `from` select homes``. 71 | The `from` function is a convenient shorthand for extracting a single column 72 | from a query, and is defined as `from s q = fmap (!s) q`. 73 | 74 | 75 | ### Ad Hoc Rows 76 | 77 | Sometimes, it can be handy to conjure up database rows "from thin air". 78 | Let's say, for instance, that we want to create a `Person` row with only 79 | the information present in the `homes` table. 80 | We can accomplish this by using the `new` function. 81 | 82 | ```language-haskell 83 | personsFromHomes :: Query s (Row s Person) 84 | personsFromHomes = do 85 | home <- select homes 86 | return $ new [#name := home ! #ownerName] 87 | ``` 88 | 89 | `new` takes a list of updates — as seen 90 | in [chapter 2](tutorial/ch2-destructive-operations) — which are applied 91 | to a row where each value initially has its type's default value. 92 | Thus, the `personsFromHomes` function will return a list of `Person` values 93 | with their names set to something sensible, and the other fields set to 94 | `0` or `Nothing`. 95 | 96 | ### Querying into Another Table 97 | 98 | This ability to create entirely new rows can be convenient when you want to 99 | return some particular type from a query, but you don't want to get it straight 100 | from a table. 101 | One prime example of this is the `queryInto` function — corresponding to 102 | the `SELECT INTO` SQL statement — which inserts the result set of a query 103 | straight into another table and returns the number of inserted rows. 104 | 105 | Using this function, we can remedy the homelessness situation by simply granting 106 | a cheap home in Tokyo to any homeless persons in the `people` table. 107 | 108 | ```language-haskell 109 | homesForEveryone :: SeldaM s Int 110 | homesForEveryone = queryInto homes $ do 111 | person <- select people 112 | restrict (not_ $ (person ! #name) `isIn` (#ownerName `from` select homes)) 113 | 114 | return $ new 115 | [ #ownerName := person ! #names 116 | , #city := "Tokyo" 117 | , #rent := 50000 118 | ] 119 | ``` 120 | 121 | Using the `TypeApplications` language extension, we can make the `new` expression 122 | even clearer, explicitly telling the compiler just what type of row 123 | we want to conjure up: 124 | 125 | ```language-haskell 126 | return $ new @Home [ ... ] 127 | ``` 128 | 129 | This is often useful — essential, even — when, for instance, 130 | creating an row entirely made up of default values, with no updates given 131 | to fix the type of the row. 132 | 133 |
134 | 135 | 170 | -------------------------------------------------------------------------------- /website/templates/default.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | {{title}} 13 | 14 | 15 |

Selda: A Haskell SQL Library

16 | 17 | 22 |
23 | {{{content}}} 24 |
25 | 26 | 27 | -------------------------------------------------------------------------------- /website/website.cabal: -------------------------------------------------------------------------------- 1 | name: website 2 | version: 0.1.0.0 3 | license: MIT 4 | license-file: LICENSE 5 | author: Anton Ekblad 6 | maintainer: anton@ekblad.cc 7 | build-type: Simple 8 | extra-source-files: 9 | cabal-version: >=1.10 10 | 11 | executable compile 12 | main-is: compile.hs 13 | other-extensions: OverloadedStrings 14 | build-depends: 15 | base >=4.9 16 | , text >=1.1 17 | , markdown >=0.1 18 | , mustache >=2.2 19 | , directory >=1.2 20 | , filepath >=1.4 21 | , blaze-html >=0.9 22 | , aeson >=1.2 23 | default-language: Haskell2010 24 | --------------------------------------------------------------------------------