...
 
Commits (14)
v0.11.0.0
- Adds support for reading type defintions from type.d
- Adds support for TRIGGERs
- Fixes upgrades failing if types exist
v0.10.0.0
- Adds support for reading setup.yml from STDIN
- Adds "did you mean" for YamSql fields
......
HS = $(shell find app/ src/ test/ -name '*.hs')
VERSION = 0.9.90.0
HPCDIRS = --hpcdir dist/hpc/vanilla/mix/hamsql --hpcdir dist/hpc/vanilla/mix/hamsql-${VERSION}
.PHONY: test $(HS)
......@@ -10,9 +8,13 @@ update-and-build: update build
update:
cabal sandbox init
cabal update
cabal install -ffast --force-reinstalls --only-dependencies --disable-optimization
cabal install -ffast --only-dependencies --disable-optimization
test:
cabal configure --disable-optimization --enable-tests
cabal test --show-details=direct --test-option=--color=always
test-coverage:
cabal configure --disable-optimization --enable-coverage --enable-tests
cabal test --show-details=direct --test-option=--color=always
......
......@@ -4,7 +4,7 @@ HamSql
An interpreter for SQL structure definitions in YAML ([YamSql](http://yamsql.readthedocs.io/))
[![build status](https://git.hemio.de/hemio/hamsql/badges/master/build.svg)](https://git.hemio.de/hemio/hamsql/commits/master)
[![Hackage-Deps](https://img.shields.io/hackage-deps/v/hamsql.svg?maxAge=2592000)](https://hackage.haskell.org/package/hamsql)
[![Hackage-Deps](https://img.shields.io/hackage-deps/v/hamsql.svg?maxAge=2592000)](https://packdeps.haskellers.com/feed?needle=hamsql)
[![Hackage](https://img.shields.io/hackage/v/hamsql.svg?maxAge=2592000)](https://hackage.haskell.org/package/hamsql)
## About HamSql
......@@ -80,7 +80,7 @@ Those are the YamSql files for the project:
schemas:
- math
schema_dirs:
- schemas
- ./schemas
```
```yaml
......
# Makefile for Sphinx documentation
#
# You can set these variables from the command line.
SPHINXOPTS =
SPHINXBUILD = sphinx-build
PAPER =
BUILDDIR = _build
# Internal variables.
PAPEROPT_a4 = -D latex_paper_size=a4
PAPEROPT_letter = -D latex_paper_size=letter
ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
# the i18n builder cannot share the environment and doctrees with the others
I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
.PHONY: help
help:
@echo "Please use \`make <target>' where <target> is one of"
@echo " html to make standalone HTML files"
@echo " dirhtml to make HTML files named index.html in directories"
@echo " singlehtml to make a single large HTML file"
@echo " pickle to make pickle files"
@echo " json to make JSON files"
@echo " htmlhelp to make HTML files and a HTML help project"
@echo " qthelp to make HTML files and a qthelp project"
@echo " applehelp to make an Apple Help Book"
@echo " devhelp to make HTML files and a Devhelp project"
@echo " epub to make an epub"
@echo " epub3 to make an epub3"
@echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
@echo " latexpdf to make LaTeX files and run them through pdflatex"
@echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
@echo " text to make text files"
@echo " man to make manual pages"
@echo " texinfo to make Texinfo files"
@echo " info to make Texinfo files and run them through makeinfo"
@echo " gettext to make PO message catalogs"
@echo " changes to make an overview of all changed/added/deprecated items"
@echo " xml to make Docutils-native XML files"
@echo " pseudoxml to make pseudoxml-XML files for display purposes"
@echo " linkcheck to check all external links for integrity"
@echo " doctest to run all doctests embedded in the documentation (if enabled)"
@echo " coverage to run coverage check of the documentation (if enabled)"
@echo " dummy to check syntax errors of document sources"
.PHONY: clean
clean:
rm -rf $(BUILDDIR)/*
.PHONY: html
html:
$(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
@echo
@echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
.PHONY: dirhtml
dirhtml:
$(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
@echo
@echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
.PHONY: singlehtml
singlehtml:
$(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
@echo
@echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
.PHONY: pickle
pickle:
$(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
@echo
@echo "Build finished; now you can process the pickle files."
.PHONY: json
json:
$(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
@echo
@echo "Build finished; now you can process the JSON files."
.PHONY: htmlhelp
htmlhelp:
$(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
@echo
@echo "Build finished; now you can run HTML Help Workshop with the" \
".hhp project file in $(BUILDDIR)/htmlhelp."
.PHONY: qthelp
qthelp:
$(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
@echo
@echo "Build finished; now you can run "qcollectiongenerator" with the" \
".qhcp project file in $(BUILDDIR)/qthelp, like this:"
@echo "# qcollectiongenerator $(BUILDDIR)/qthelp/HamSql.qhcp"
@echo "To view the help file:"
@echo "# assistant -collectionFile $(BUILDDIR)/qthelp/HamSql.qhc"
.PHONY: applehelp
applehelp:
$(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp
@echo
@echo "Build finished. The help book is in $(BUILDDIR)/applehelp."
@echo "N.B. You won't be able to view it unless you put it in" \
"~/Library/Documentation/Help or install it in your application" \
"bundle."
.PHONY: devhelp
devhelp:
$(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
@echo
@echo "Build finished."
@echo "To view the help file:"
@echo "# mkdir -p $$HOME/.local/share/devhelp/HamSql"
@echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/HamSql"
@echo "# devhelp"
.PHONY: epub
epub:
$(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
@echo
@echo "Build finished. The epub file is in $(BUILDDIR)/epub."
.PHONY: epub3
epub3:
$(SPHINXBUILD) -b epub3 $(ALLSPHINXOPTS) $(BUILDDIR)/epub3
@echo
@echo "Build finished. The epub3 file is in $(BUILDDIR)/epub3."
.PHONY: latex
latex:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo
@echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
@echo "Run \`make' in that directory to run these through (pdf)latex" \
"(use \`make latexpdf' here to do that automatically)."
.PHONY: latexpdf
latexpdf:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo "Running LaTeX files through pdflatex..."
$(MAKE) -C $(BUILDDIR)/latex all-pdf
@echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
.PHONY: latexpdfja
latexpdfja:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo "Running LaTeX files through platex and dvipdfmx..."
$(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
@echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
.PHONY: text
text:
$(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
@echo
@echo "Build finished. The text files are in $(BUILDDIR)/text."
.PHONY: man
man:
$(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
@echo
@echo "Build finished. The manual pages are in $(BUILDDIR)/man."
.PHONY: texinfo
texinfo:
$(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
@echo
@echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
@echo "Run \`make' in that directory to run these through makeinfo" \
"(use \`make info' here to do that automatically)."
.PHONY: info
info:
$(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
@echo "Running Texinfo files through makeinfo..."
make -C $(BUILDDIR)/texinfo info
@echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
.PHONY: gettext
gettext:
$(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
@echo
@echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
.PHONY: changes
changes:
$(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
@echo
@echo "The overview file is in $(BUILDDIR)/changes."
.PHONY: linkcheck
linkcheck:
$(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
@echo
@echo "Link check complete; look for any errors in the above output " \
"or in $(BUILDDIR)/linkcheck/output.txt."
.PHONY: doctest
doctest:
$(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
@echo "Testing of doctests in the sources finished, look at the " \
"results in $(BUILDDIR)/doctest/output.txt."
.PHONY: coverage
coverage:
$(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage
@echo "Testing of coverage in the sources finished, look at the " \
"results in $(BUILDDIR)/coverage/python.txt."
.PHONY: xml
xml:
$(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
@echo
@echo "Build finished. The XML files are in $(BUILDDIR)/xml."
.PHONY: pseudoxml
pseudoxml:
$(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
@echo
@echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
.PHONY: dummy
dummy:
$(SPHINXBUILD) -b dummy $(ALLSPHINXOPTS) $(BUILDDIR)/dummy
@echo
@echo "Build finished. Dummy builder generates no files."
#!/usr/bin/env python3
# -*- coding: utf-8 -*-
#
# HamSql documentation build configuration file, created by
# sphinx-quickstart on Fri Nov 17 13:14:43 2017.
#
# This file is execfile()d with the current directory set to its
# containing dir.
#
# Note that not all possible configuration values are present in this
# autogenerated file.
#
# All configuration values have a default; values that are commented out
# serve to show the default.
# If extensions (or modules to document with autodoc) are in another directory,
# add these directories to sys.path here. If the directory is relative to the
# documentation root, use os.path.abspath to make it absolute, like shown here.
#
# import os
# import sys
# sys.path.insert(0, os.path.abspath('.'))
# -- General configuration ------------------------------------------------
# If your documentation needs a minimal Sphinx version, state it here.
#
# needs_sphinx = '1.0'
# Add any Sphinx extension module names here, as strings. They can be
# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
# ones.
extensions = []
# Add any paths that contain templates here, relative to this directory.
templates_path = ['_templates']
# The suffix(es) of source filenames.
# You can specify multiple suffix as a list of string:
#
# source_suffix = ['.rst', '.md']
source_suffix = '.rst'
# The encoding of source files.
#
# source_encoding = 'utf-8-sig'
# The master toctree document.
master_doc = 'index'
# General information about the project.
project = 'HamSql'
copyright = '2017, Sophie Herold'
author = 'Sophie Herold'
# The version info for the project you're documenting, acts as replacement for
# |version| and |release|, also used in various other places throughout the
# built documents.
#
# The short X.Y version.
version = '0.11'
# The full version, including alpha/beta/rc tags.
release = '0.11'
# The language for content autogenerated by Sphinx. Refer to documentation
# for a list of supported languages.
#
# This is also used if you do content translation via gettext catalogs.
# Usually you set "language" from the command line for these cases.
language = None
# There are two options for replacing |today|: either, you set today to some
# non-false value, then it is used:
#
# today = ''
#
# Else, today_fmt is used as the format for a strftime call.
#
# today_fmt = '%B %d, %Y'
# List of patterns, relative to source directory, that match files and
# directories to ignore when looking for source files.
# This patterns also effect to html_static_path and html_extra_path
exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store']
# The reST default role (used for this markup: `text`) to use for all
# documents.
#
# default_role = None
# If true, '()' will be appended to :func: etc. cross-reference text.
#
# add_function_parentheses = True
# If true, the current module name will be prepended to all description
# unit titles (such as .. function::).
#
# add_module_names = True
# If true, sectionauthor and moduleauthor directives will be shown in the
# output. They are ignored by default.
#
# show_authors = False
# The name of the Pygments (syntax highlighting) style to use.
pygments_style = 'sphinx'
# A list of ignored prefixes for module index sorting.
# modindex_common_prefix = []
# If true, keep warnings as "system message" paragraphs in the built documents.
# keep_warnings = False
# If true, `todo` and `todoList` produce output, else they produce nothing.
todo_include_todos = False
# -- Options for HTML output ----------------------------------------------
# The theme to use for HTML and HTML Help pages. See the documentation for
# a list of builtin themes.
#
html_theme = 'sphinx_rtd_theme'
# Theme options are theme-specific and customize the look and feel of a theme
# further. For a list of options available for each theme, see the
# documentation.
#
# html_theme_options = {}
# Add any paths that contain custom themes here, relative to this directory.
# html_theme_path = []
# The name for this set of Sphinx documents.
# "<project> v<release> documentation" by default.
#
# html_title = 'HamSql v0.11'
# A shorter title for the navigation bar. Default is the same as html_title.
#
# html_short_title = None
# The name of an image file (relative to this directory) to place at the top
# of the sidebar.
#
# html_logo = None
# The name of an image file (relative to this directory) to use as a favicon of
# the docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
# pixels large.
#
# html_favicon = None
# Add any paths that contain custom static files (such as style sheets) here,
# relative to this directory. They are copied after the builtin static files,
# so a file named "default.css" will overwrite the builtin "default.css".
html_static_path = ['_static']
# Add any extra paths that contain custom files (such as robots.txt or
# .htaccess) here, relative to this directory. These files are copied
# directly to the root of the documentation.
#
# html_extra_path = []
# If not None, a 'Last updated on:' timestamp is inserted at every page
# bottom, using the given strftime format.
# The empty string is equivalent to '%b %d, %Y'.
#
# html_last_updated_fmt = None
# If true, SmartyPants will be used to convert quotes and dashes to
# typographically correct entities.
#
# html_use_smartypants = True
# Custom sidebar templates, maps document names to template names.
#
# html_sidebars = {}
# Additional templates that should be rendered to pages, maps page names to
# template names.
#
# html_additional_pages = {}
# If false, no module index is generated.
#
# html_domain_indices = True
# If false, no index is generated.
#
# html_use_index = True
# If true, the index is split into individual pages for each letter.
#
# html_split_index = False
# If true, links to the reST sources are added to the pages.
#
# html_show_sourcelink = True
# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
#
# html_show_sphinx = True
# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
#
# html_show_copyright = True
# If true, an OpenSearch description file will be output, and all pages will
# contain a <link> tag referring to it. The value of this option must be the
# base URL from which the finished HTML is served.
#
# html_use_opensearch = ''
# This is the file name suffix for HTML files (e.g. ".xhtml").
# html_file_suffix = None
# Language to be used for generating the HTML full-text search index.
# Sphinx supports the following languages:
# 'da', 'de', 'en', 'es', 'fi', 'fr', 'h', 'it', 'ja'
# 'nl', 'no', 'pt', 'ro', 'r', 'sv', 'tr', 'zh'
#
# html_search_language = 'en'
# A dictionary with options for the search language support, empty by default.
# 'ja' uses this config value.
# 'zh' user can custom change `jieba` dictionary path.
#
# html_search_options = {'type': 'default'}
# The name of a javascript file (relative to the configuration directory) that
# implements a search results scorer. If empty, the default will be used.
#
# html_search_scorer = 'scorer.js'
# Output file base name for HTML help builder.
htmlhelp_basename = 'HamSqldoc'
# -- Options for LaTeX output ---------------------------------------------
latex_elements = {
# The paper size ('letterpaper' or 'a4paper').
#
# 'papersize': 'letterpaper',
# The font size ('10pt', '11pt' or '12pt').
#
# 'pointsize': '10pt',
# Additional stuff for the LaTeX preamble.
#
# 'preamble': '',
# Latex figure (float) alignment
#
# 'figure_align': 'htbp',
}
# Grouping the document tree into LaTeX files. List of tuples
# (source start file, target name, title,
# author, documentclass [howto, manual, or own class]).
latex_documents = [
(master_doc, 'HamSql.tex', 'HamSql Documentation',
'Sophie Herold', 'manual'),
]
# The name of an image file (relative to this directory) to place at the top of
# the title page.
#
# latex_logo = None
# For "manual" documents, if this is true, then toplevel headings are parts,
# not chapters.
#
# latex_use_parts = False
# If true, show page references after internal links.
#
# latex_show_pagerefs = False
# If true, show URL addresses after external links.
#
# latex_show_urls = False
# Documents to append as an appendix to all manuals.
#
# latex_appendices = []
# It false, will not define \strong, \code, itleref, \crossref ... but only
# \sphinxstrong, ..., \sphinxtitleref, ... To help avoid clash with user added
# packages.
#
# latex_keep_old_macro_names = True
# If false, no module index is generated.
#
# latex_domain_indices = True
# -- Options for manual page output ---------------------------------------
# One entry per manual page. List of tuples
# (source start file, name, description, authors, manual section).
man_pages = [
(master_doc, 'hamsql', 'HamSql Documentation',
[author], 1)
]
# If true, show URL addresses after external links.
#
# man_show_urls = False
# -- Options for Texinfo output -------------------------------------------
# Grouping the document tree into Texinfo files. List of tuples
# (source start file, target name, title, author,
# dir menu entry, description, category)
texinfo_documents = [
(master_doc, 'HamSql', 'HamSql Documentation',
author, 'HamSql', 'One line description of project.',
'Miscellaneous'),
]
# Documents to append as an appendix to all manuals.
#
# texinfo_appendices = []
# If false, no module index is generated.
#
# texinfo_domain_indices = True
# How to display URL addresses: 'footnote', 'no', or 'inline'.
#
# texinfo_show_urls = 'footnote'
# If true, do not generate a @detailmenu in the "Top" node's menu.
#
# texinfo_no_detailmenu = False
.. HamSql documentation master file, created by
sphinx-quickstart on Fri Nov 17 13:14:43 2017.
You can adapt this file completely to your liking, but it should at least
contain the root `toctree` directive.
Welcome to HamSql's documentation!
==================================
Contents:
.. toctree::
:maxdepth: 2
pitfalls
Indices and tables
==================
* :ref:`genindex`
* :ref:`modindex`
* :ref:`search`
Pitfalls
========
Changed function return type
----------------------------
Solution: ``DROP FUNCTION`` before redefinition if return type differs
.. code-block:: sql
DROP FUNCTION IF EXISTS f();
CREATE FUNCTION f()
RETURNS integer LANGUAGE SQL AS 'SELECT 0';
CREATE OR REPLACE FUNCTION f()
RETURNS varchar LANGUAGE SQL AS 'SELECT 0::varchar';
-- ERROR: cannot change return type of existing function
-- HINT: Use DROP FUNCTION f() first.
Owned sequences
---------------
Solution: ``DROP DEFAULT`` before ``DROP SEQUENCE``
.. code-block:: sql
DROP TABLE IF EXISTS t;
DROP SEQUENCE IF EXISTS t_t1_seq;
CREATE TABLE t (t1 integer);
CREATE SEQUENCE t_t1_seq OWNED BY t.t1;
DROP SEQUENCE t_t1_seq;
CREATE SEQUENCE t_t1_seq OWNED BY t.t1;
ALTER TABLE t ALTER COLUMN t1 SET DEFAULT nextval('t_t1_seq'::regclass);
DROP SEQUENCE t_t1_seq;
-- ERROR: cannot drop sequence t_t1_seq because other objects depend on it
-- DETAIL: default for table t column t1 depends on sequence t_t1_seq
-- HINT: Use DROP ... CASCADE to drop the dependent objects too.
DROP TABLE t;
DROP SEQUENCE t_t1_seq;
-- ERROR: sequence "t_t1_seq" does not exist
The first error does not depend on the ``OWNED BY`` property. The second does, since otherwise the sequence wouldn't be deleted.
Type limits are irrelevant for functions
----------------------------------------
Solution: Distinquish between function and column types
.. code-block:: sql
DROP FUNCTION IF EXISTS g(varchar);
CREATE FUNCTION g(varchar(2))
RETURNS varchar(3) LANGUAGE SQL AS 'SELECT $1';
SELECT g('abcd');
-- abcd (1 row)
DROP FUNCTION IF EXISTS g(time);
CREATE FUNCTION g(time (1))
RETURNS time (2) LANGUAGE SQL AS 'SELECT $1';
SELECT g('12:11:10.12345'::time);
-- 12:11:10.12345 (1 row)
CREATE OR REPLACE FUNCTION g(time (1))
RETURNS time (2) LANGUAGE SQL AS 'SELECT $1::time (3)';
SELECT g('12:11:10.12345'::time);
-- 12:11:10.123 (1 row)
DROP TABLE IF EXISTS s;
CREATE TABLE s (s1 varchar(2), s2 time(2));
INSERT INTO s VALUES ('abcd', '12:11:10.12345');
-- ERROR: value too long for type character varying(2)
INSERT INTO s VALUES ('ab', '12:11:10.12345');
SELECT t2 FROM t;
SELECT s2 FROM s;
-- 12:11:10.12 (1 row)
\ No newline at end of file
name: hamsql
version: 0.10.0.0
version: 0.10.0.99
synopsis: Interpreter for SQL-structure definitions in YAML (YamSql)
category: Database
description: Interpreter for SQL-structure definitions in YAML (YamSql)
......@@ -33,7 +33,8 @@ library
FlexibleContexts,
FlexibleInstances,
OverloadedStrings,
QuasiQuotes
QuasiQuotes,
TemplateHaskell
other-extensions:
GADTs,
......@@ -72,6 +73,7 @@ library
Database.HamSql.Internal.Stmt.Schema
Database.HamSql.Internal.Stmt.Sequence
Database.HamSql.Internal.Stmt.Table
Database.HamSql.Internal.Stmt.Trigger
Database.HamSql.Internal.Stmt.Type
Database.YamSql.Internal.Obj.Check
Database.YamSql.Internal.Obj.Domain
......@@ -80,6 +82,7 @@ library
Database.YamSql.Internal.Obj.Schema
Database.YamSql.Internal.Obj.Sequence
Database.YamSql.Internal.Obj.Table
Database.YamSql.Internal.Obj.Trigger
Database.YamSql.Internal.Obj.Type
Paths_hamsql
......@@ -95,6 +98,7 @@ library
file-embed == 0.0.*,
filepath == 1.4.*,
frontmatter == 0.1.*,
lens == 4.15.*,
network-uri == 2.6.*,
optparse-applicative == 0.14.*,
postgresql-simple >=0.4 && <0.6,
......
......@@ -8,7 +8,8 @@ module Database.HamSql.Cli
, parseThisArgv
) where
import Control.Monad (when)
import Control.Monad (void, when)
import Control.Monad.Trans.Reader (runReaderT)
import Data.List
import Data.Maybe
import qualified Data.Text as T
......@@ -22,7 +23,10 @@ import System.Environment (getArgs)
import Paths_hamsql (version)
import Database.HamSql
import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.Stmt.Database
import Database.HamSql.Setup
import Database.HamSql.Write
import Database.YamSql
parserPrefs :: ParserPrefs
......@@ -44,7 +48,6 @@ run (Install optCommon optDb optInstall)
"must be supplied or non of them."
| otherwise = do
setup <- loadSetup (optSetup optCommon)
let stmts = pgsqlGetFullStatements setup
let dbname = SqlName $ T.pack $ tail $ uriPath $ getConUrl optDb
if not (optEmulate optDb || optPrint optDb)
then close =<<
......@@ -60,18 +63,25 @@ run (Install optCommon optDb optInstall)
"database exists for those commands to make sense."
dropRoleStmts <-
if optDeleteResidualRoles optInstall
then pgsqlDropAllRoleStmts optDb setup
then pgsqlConnectUrl (getConUrl optDb) >>=
runReaderT (pgsqlDropAllRoleStmts setup)
else return []
useSqlStmts optCommon optDb $ sort $ stmts ++ dropRoleStmts
useSqlStmts optCommon optDb $ sort $ (stmtsInstall setup) ++ dropRoleStmts
-- Upgrade
run (Upgrade optCommon optDb) = do
setup <- loadSetup (optSetup optCommon)
sourceSetup' <- loadSetup (optSetup optCommon)
conn <- pgsqlConnectUrl (getConUrl optDb)
deleteStmts <- pgsqlDeleteAllStmt conn
let createStmts = pgsqlGetFullStatements setup
fragile <- pgsqlUpdateFragile setup conn createStmts
let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
sourceSetup <- runReaderT (normalizeOnline sourceSetup') conn
targetSetup <- runReaderT (inquireSetup $ setupRolePrefix sourceSetup') conn
let stmts = upgradeStmts sourceSetup targetSetup
--deleteStmts <- pgsqlDeleteAllStmt conn
--fragile <- pgsqlUpdateFragile setup conn (stmtsInstall setup)
--let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
useSqlStmts optCommon optDb stmts
run (Yamsql optDb OptYamsql {optYamsqlDir = p}) = do
conn <- pgsqlConnectUrl (getConUrl optDb)
setup <- runReaderT (inquireSetup Nothing) conn
void $ doWrite p $ setupToDirTree "db" setup
-- Doc
run (Doc optCommon optDoc) = do
setup <- loadSetup (optSetup optCommon)
......
......@@ -33,7 +33,7 @@ templateCompile str =
docWrite :: OptDoc -> Setup -> IO ()
docWrite optDoc s = do
t <- templateFromFile (optTemplate optDoc)
mapM_ (docWriteSchema optDoc t) (fromMaybe [] $ setupSchemaData s)
mapM_ (docWriteSchema optDoc t) (fromMaybe [] $ _setupSchemaData s)
return ()
docWriteSchema :: OptDoc -> Template -> Schema -> IO ()
......
......@@ -40,7 +40,7 @@ loadSetup filePath = do
loadSetupSchemas :: FilePath -> Setup -> IO Setup
loadSetupSchemas path s = do
schemaData <- loadSchemas path s [] (setupSchemas s)
return s {setupSchemaData = setupSchemaData s <> Just schemaData}
return s {_setupSchemaData = _setupSchemaData s <> Just schemaData}
loadSchemas :: FilePath -> Setup -> [Schema] -> [SqlName] -> IO [Schema]
loadSchemas _ _ allLoaded [] = return allLoaded
......@@ -124,11 +124,13 @@ readSchema md = do
in confDirFiles "functions.d" >>= mapM (readFunctionFromFile ins)
let schemaData' =
schemaData
{ schemaDomains = schemaDomains schemaData <> presetEmpty domains
, schemaFunctions = schemaFunctions schemaData <> presetEmpty functions
, schemaSequences = schemaSequences schemaData <> presetEmpty sequences
, schemaTables = schemaTables schemaData <> presetEmpty tables
, schemaTypes = schemaTypes schemaData <> presetEmpty types
{ _schemaDomains = _schemaDomains schemaData <> presetEmpty domains
, _schemaFunctions =
_schemaFunctions schemaData <> presetEmpty functions
, _schemaSequences =
_schemaSequences schemaData <> presetEmpty sequences
, _schemaTables = _schemaTables schemaData <> presetEmpty tables
, _schemaTypes = _schemaTypes schemaData <> presetEmpty types
}
return schemaData'
where
......
......@@ -32,6 +32,8 @@ data Command
OptInstall
| Upgrade OptCommon
OptCommonDb
| Yamsql OptCommonDb
OptYamsql
| Doc OptCommon
OptDoc
| NoCommand OptNoCommand
......@@ -50,6 +52,9 @@ parserCommand =
(info
(parserCmdUpgrade <**> helper)
(progDesc "Upgrades an existing setup on a database.")) <>
command
"yamsql"
(info (parserCmdYamsql <**> helper) (progDesc "Output yamsql")) <>
command
"doc"
(info
......@@ -64,6 +69,9 @@ parserCmdInstall =
parserCmdUpgrade :: Parser Command
parserCmdUpgrade = Upgrade <$> parserOptCommon <*> parserOptCommonDb
parserCmdYamsql :: Parser Command
parserCmdYamsql = Yamsql <$> parserOptCommonDb <*> parserOptYamsql
parserCmdDoc :: Parser Command
parserCmdDoc = Doc <$> parserOptCommon <*> parserOptDoc
......@@ -137,6 +145,13 @@ parserOptInstall =
help "Delete database if it allready exists") <*>
boolFlag (long "delete-residual-roles" <> help "Delete residual roles")
data OptYamsql = OptYamsql
{ optYamsqlDir :: FilePath
} deriving (Show)
parserOptYamsql :: Parser OptYamsql
parserOptYamsql = OptYamsql <$> strArgument (help "Out dir")
-- Command NoCommand
data OptNoCommand = OptNoCommand
{ optVersion :: Bool
......
This diff is collapsed.
......@@ -23,7 +23,7 @@ instance Show SqlStmtId where
data SqlStmt =
SqlStmt SqlStmtId
Text
deriving (Show)
deriving (Show, Eq, Ord)
stmtId :: SqlStmt -> SqlStmtId
stmtId (SqlStmt x _) = x
......@@ -37,12 +37,10 @@ stmtIdType (SqlStmt x _) = stmtType x
stmtDesc :: SqlStmt -> Text
stmtDesc stmt = sqlIdShowType (sqlId stmt) <-> sqlIdCode stmt
instance Eq SqlStmt where
x == y = stmtId x == stmtId y
instance Ord SqlStmt where
x `compare` y = stmtId x `compare` stmtId y
--instance Eq SqlStmt where
-- x == y = stmtId x == stmtId y
--instance Ord SqlStmt where
-- x `compare` y = stmtId x `compare` stmtId y
instance ToSqlId SqlStmt where
sqlId = stmtSqlId . stmtId
......@@ -95,6 +93,7 @@ data SqlStmtType
| SqlDropTableConstr
| SqlDropDomainConstr
| SqlDropSequence
| SqlDropTrigger
-- DROP FUNCTION
| SqlDropTableColumn
| SqlDropTable
......@@ -115,13 +114,15 @@ data SqlStmtType
-- FUNCTION
| SqlDropDomain
| SqlDropType
| SqlDropSchema
| SqlCreateFunction
| SqlInherit
| SqlAddTableConstr
| SqlCreatePrimaryKeyConstr
| SqlCreateUniqueConstr
| SqlCreateForeignKeyConstr
| SqlCreateCheckConstr
| SqlCreateDomainCheckConstr
| SqlCreateTableCheckConstr
| SqlDomainSetDefault
-- TRIGGER
| SqlCreateTrigger
......
......@@ -16,21 +16,26 @@ import Database.HamSql.Internal.Stmt.Role ()
import Database.HamSql.Internal.Stmt.Schema ()
import Database.HamSql.Internal.Stmt.Sequence ()
import Database.HamSql.Internal.Stmt.Table ()
import Database.HamSql.Internal.Stmt.Trigger ()
import Database.HamSql.Internal.Stmt.Type ()
allSchemaElements :: Schema -> [SetupElement]
allSchemaElements schema =
[SetupElement $ SqlContext schema] ++
toElemList' schemaRoles schema ++
toElemList schemaDomains schema ++
toElemList schemaFunctions schema ++
toElemList schemaSequences schema ++
toElemList schemaTables schema ++
toElemList schemaTypes schema ++
toElemList _schemaDomains schema ++
toElemList _schemaFunctions schema ++
toElemList _schemaSequences schema ++
toElemList _schemaTables schema ++
toElemList _schemaTypes schema ++
concat
[ map (SetupElement . (\x -> SqlContext (schema, table, x))) $
tableColumns table
| table <- fromMaybe [] $ schemaTables schema
[ map
(SetupElement . (\x -> SqlContext (schema, table, x)))
(_tableColumns table) ++
map
(SetupElement . (\x -> SqlContext (schema, table, x)))
(fromMaybe [] $ tableTriggers table)
| table <- fromMaybe [] $ _schemaTables schema
]
where
toElemList y = maybeMap (SetupElement . (\x -> SqlContext (schema, x))) . y
......@@ -54,13 +59,19 @@ sqlAddTransact xs =
catMaybes [newSqlStmt SqlUnclassified emptyName "BEGIN TRANSACTION"] ++
xs ++ catMaybes [newSqlStmt SqlUnclassified emptyName "COMMIT"]
getRoleStmts :: Setup -> [Role] -> [Maybe SqlStmt]
getRoleStmts s r =
concat $ map (toSqlStmts (SetupContext s)) $ map (SetupElement . SqlContext) r
-- | Setup
getSetupStatements :: Setup -> [Maybe SqlStmt]
getSetupStatements s =
[getStmt $ setupPreCode s] ++ schemaStatements ++ [getStmt $ setupPostCode s]
[getStmt $ setupPreCode s] ++
schemaStatements ++ myStmts ++ [getStmt $ setupPostCode s]
where
schemaStatements =
concat $ maybeMap (getSchemaStatements s) (setupSchemaData s)
concat $ maybeMap (getSchemaStatements s) (_setupSchemaData s)
myStmts = getRoleStmts s $ fromMaybe [] $ setupRoles s
getStmt (Just code) = newSqlStmt SqlPre emptyName code
getStmt Nothing = Nothing
......
......@@ -5,6 +5,7 @@
module Database.HamSql.Internal.Stmt.Database where
import Database.HamSql.Internal.Stmt.Basic
import Database.HamSql.Internal.Stmt.Schema
data SQL_DATABASE =
SQL_DATABASE
......
......@@ -19,7 +19,7 @@ stmtsDropDomainConstr obj@(SqlObj _ (d, c)) =
]
instance ToSqlStmts (SqlContext (Schema, Domain)) where
toSqlStmts _ obj@(SqlContext (_, d)) =
toSqlStmts _ obj@(SqlContext (s, d)) =
stmtCreateDomain :
sqlDefault (domainDefault d) :
stmtCommentOn obj (domainDescription d) :
......@@ -28,7 +28,7 @@ instance ToSqlStmts (SqlContext (Schema, Domain)) where
where
stmtCreateDomain =
newSqlStmt SqlCreateDomain obj $
"CREATE DOMAIN" <-> sqlIdCode obj <-> "AS" <-> toSqlCode (domainType d)
"CREATE DOMAIN" <-> sqlIdCode obj <-> "AS" <-> toSqlCode (_domainType d)
checkComment c =
newSqlStmt SqlComment obj $
"COMMENT ON CONSTRAINT" <-> toSqlCode (checkName c) <-> "ON DOMAIN" <->
......@@ -37,7 +37,11 @@ instance ToSqlStmts (SqlContext (Schema, Domain)) where
toSqlCodeString (checkDescription c)
sqlCheck :: Check -> Maybe SqlStmt
sqlCheck c =
newSqlStmt SqlCreateCheckConstr obj $
newSqlStmt
SqlCreateDomainCheckConstr
(SqlObj
SQL_TABLE_CONSTRAINT
(schemaName s <.> domainName d, checkName c)) $
"ALTER DOMAIN" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <->
toSqlCode (checkName c) <->
"CHECK (" <>
......
......@@ -31,11 +31,10 @@ instance ToSqlStmts (SqlContext (Schema, Function)) where
prefixedRole setup u
stmtCreateFunction =
newSqlStmt SqlCreateFunction obj $
--(maybeMap variableType (functionParameters f)) $
--(maybeMap _variableType (_functionParameters f)) $
"CREATE OR REPLACE FUNCTION " <> sqlFunctionIdentifierDef <> "\n" <>
"RETURNS" <->
toSqlCode (functionReturns f) <>
sqlReturnsColumns (functionReturnsColumns f) <>
sqlReturns (_functionReturns f) <>
"\nLANGUAGE " <>
sqlLanguage (functionLanguage f) <>
"\nSECURITY " <>
......@@ -51,22 +50,22 @@ instance ToSqlStmts (SqlContext (Schema, Function)) where
sqlSetOwner Nothing = Nothing
sqlFunctionIdentifierDef =
toSqlCode (schemaName s <.> functionName f) <> "(\n" <>
T.intercalate ",\n" (maybeMap sqlParameterDef (functionParameters f)) <>
T.intercalate ",\n" (maybeMap sqlParameterDef (_functionParameters f)) <>
"\n)"
-- function parameter
sqlParameterDef p =
toSqlCode (variableName p) <-> toSqlCode (variableType p) <->
toSqlCode (variableName p) <-> toSqlCode (_variableType p) <->
sqlParamDefault (variableDefault p)
where
sqlParamDefault Nothing = ""
sqlParamDefault (Just x) = "DEFAULT" <-> x
-- If function returns a table, use service for field definition
sqlReturnsColumns cs
| toSqlCode (functionReturns f) == "TABLE" =
" (" <\> T.intercalate ",\n" (maybeMap sqlReturnsColumn cs) <> ") "
| otherwise = ""
sqlReturns (ReturnType rt) = toSqlCode rt
sqlReturns (ReturnTypeSetof rt) = "SETOF" <-> toSqlCode rt
sqlReturns (ReturnTypeTable cs) =
"TABLE (" <\> T.intercalate ",\n" (map sqlReturnsColumn cs) <> ") "
sqlReturnsColumn c =
toSqlCode (parameterName c) <> " " <> toSqlCode (parameterType c)
toSqlCode (parameterName c) <> " " <> toSqlCode (_parameterType c)
-- If language not defined, use service for variable definitions
sqlBody
| isNothing (functionLanguage f) =
......@@ -79,15 +78,16 @@ instance ToSqlStmts (SqlContext (Schema, Function)) where
T.intercalate "\n" postludes
preludes :: [Text]
preludes =
catMaybes $maybeMap functiontplBodyPrelude (functionTemplateData f)
catMaybes $ maybeMap functiontplBodyPrelude (functionTemplateData f)
postludes :: [Text]
postludes =
catMaybes $maybeMap functiontplBodyPostlude (functionTemplateData f)
catMaybes $
maybeMap functiontplBodyPostlude (functionTemplateData f)
-- Service for variable definitions
sqlVariables Nothing = ""
sqlVariables (Just vs) = T.concat (map sqlVariable vs)
sqlVariable v =
toSqlCode (variableName v) <-> toSqlCode (variableType v) <->
toSqlCode (variableName v) <-> toSqlCode (_variableType v) <->
sqlVariableDefault (variableDefault v) <>
";\n"
sqlVariableDefault Nothing = ""
......
......@@ -8,6 +8,9 @@ module Database.HamSql.Internal.Stmt.Schema where
import Database.HamSql.Internal.Stmt.Basic
stmtsDropSchema :: SqlObj SQL_SCHEMA SqlName -> [Maybe SqlStmt]
stmtsDropSchema x = [newSqlStmt SqlDropSchema x $ "DROP SCHEMA" <-> toSqlCode x]
instance ToSqlStmts (SqlContext Schema) where
toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext s) =
[ newSqlStmt SqlCreateSchema obj $
......
......@@ -18,11 +18,10 @@ import Database.HamSql.Internal.Stmt.Sequence ()
-- | Assuming that CASCADE will only cause other constraints to be deleted.
-- | Required since foreign keys may depend on other keys.
stmtsDropTableConstr ::
SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName) -> [Maybe SqlStmt]
stmtsDropTableConstr x@(SqlObj _ (s, t, c)) =
SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName) -> [Maybe SqlStmt]
stmtsDropTableConstr x@(SqlObj _ (tbl, c)) =
[ newSqlStmt SqlDropTableConstr x $
"ALTER TABLE" <-> toSqlCode (s <.> t) <-> "DROP CONSTRAINT IF EXISTS" <->
toSqlCode c <->
"ALTER TABLE" <-> toSqlCode tbl <-> "DROP CONSTRAINT" <-> toSqlCode c <->
"CASCADE"
]
......@@ -39,24 +38,27 @@ constrId ::
Schema
-> Table
-> SqlName
-> SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)
constrId s t c = SqlObj SQL_TABLE_CONSTRAINT (schemaName s, tableName t, c)
-> SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName)
constrId s t c = SqlObj SQL_TABLE_CONSTRAINT (schemaName s <.> tableName t, c)
-- TODO: prefix with table name
stmtCheck :: ToSqlId a => a -> Check -> [Maybe SqlStmt]
stmtCheck obj c =
[ newSqlStmt SqlCreateCheckConstr obj $
"ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>
toSqlCode (checkName c) <>
" CHECK (" <>
checkCheck c <>
")"
, newSqlStmt SqlComment obj $
"COMMENT ON CONSTRAINT" <-> toSqlCode (checkName c) <-> "ON" <->
sqlIdCode obj <->
"IS" <->
toSqlCodeString (checkDescription c)
]
stmtCheck :: (Schema, Table) -> Check -> [Maybe SqlStmt]
stmtCheck (s, t) c =
let x =
SqlObj SQL_TABLE_CONSTRAINT (schemaName s <.> tableName t, checkName c)
obj = (schemaName s, tableName t)
in [ newSqlStmt SqlCreateTableCheckConstr x $
"ALTER TABLE " <> toSqlCode obj <> " ADD CONSTRAINT " <>
toSqlCode (checkName c) <>
" CHECK (" <>
checkCheck c <>
")"
, newSqlStmt SqlComment x $
"COMMENT ON CONSTRAINT" <-> toSqlCode (checkName c) <-> "ON" <->
toSqlCode obj <->
"IS" <->
toSqlCodeString (checkDescription c)
]
instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
toSqlStmts context obj@(SqlContext (schema, table, rawColumn)) =
......@@ -75,7 +77,7 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
stmtAddColumn =
newSqlStmt SqlAddColumn obj $
"ALTER TABLE" <-> tblId <-> "ADD COLUMN" <-> toSqlCode (columnName c) <->
toSqlCode (columnType c)
toSqlCode (_columnType c)
-- UNIQUE
stmtColumnUnique
| columnUnique c == Just True =
......@@ -95,7 +97,7 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
-- SET DATA TYPE
stmtAlterColumnType =
stmtAlterColumn SqlColumnSetType $
"SET DATA TYPE " <> toSqlCode (columnType c)
"SET DATA TYPE " <> toSqlCode (_columnType c)
-- DROP DEFAULT
stmtDropDefault = stmtAlterColumn SqlColumnSetDefault "DROP DEFAULT"
-- SET DEFAULT
......@@ -104,7 +106,8 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
sqlDefault d =
stmtAlterColumn SqlColumnSetDefault $ "SET DEFAULT " <> d
-- [CHECK]
stmtsAddColumnCheck = concat $ maybeMap (stmtCheck tbl) (columnChecks c)
stmtsAddColumnCheck =
concat $ maybeMap (stmtCheck (schema, table)) (columnChecks c)
-- FOREIGN KEY
stmtAddForeignKey =
case columnReferences c of
......@@ -127,7 +130,7 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
maybePrefix " ON DELETE " (columnOnRefDelete c)
-- CREATE SEQUENCE (for type SERIAL)
stmtsSerialSequence
| columnIsSerial /= Nothing = toSqlStmts context serialSequenceContext
| isJust columnIsSerial = toSqlStmts context serialSequenceContext
| otherwise = [Nothing]
-- Helpers
stmtAlterColumn t x =
......@@ -136,7 +139,7 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
" " <>
x
columnIsSerial =
let serialKey = T.toLower $ toSqlCode $ columnType rawColumn
let serialKey = T.toLower $ toSqlCode $ _columnType rawColumn
in lookup
serialKey
[ ("smallserial", "smallint")
......@@ -147,10 +150,11 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
case columnIsSerial of
Just sType ->
rawColumn
{ columnType = SqlType sType
{ _columnType = SqlType sType
, columnDefault =
Just $
"nextval('" <> toSqlCode (sqlId serialSequenceContext) <> "')"
"nextval('" <> toSqlCode (sqlId serialSequenceContext) <>
"'::regclass)"
}
Nothing -> rawColumn
tblId = sqlIdCode tbl
......@@ -184,7 +188,7 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
-- table comment
, stmtCommentOn obj (tableDescription t)
] ++
(concat $ maybeMap (stmtCheck obj) (tableChecks t)) ++
concat (maybeMap (stmtCheck (s, t)) (tableChecks t)) ++
-- grant rights to roles
maybeMap (sqlGrant "SELECT") (tablePrivSelect t) ++
maybeMap (sqlGrant "UPDATE") (tablePrivUpdate t) ++
......
-- This file is part of HamSql
--
-- Copyright 2016 by it's authors.
-- Copyright 2017 by it's authors.
-- Some rights reserved. See COPYING, AUTHORS.
{-# LANGUAGE FlexibleInstances #-}
......@@ -9,48 +9,34 @@ module Database.HamSql.Internal.Stmt.Trigger where
import qualified Data.Text as T
import Database.HamSql.Internal.Stmt.Basic
import Database.HamSql.Internal.Stmt.Function
import Database.HamSql.Internal.Stmt.Function ()
instance ToSqlStmts (SqlContextSqo Trigger) where
toSqlStmts = stmtsDeployTrigger
stmtsDropTrigger :: SqlObj SQL_TRIGGER (SqlName, SqlName) -> [Maybe SqlStmt]
stmtsDropTrigger x@(SqlObj _ (tbl, trig)) =
[ newSqlStmt SqlDropTrigger x $
"DROP TRIGGER" <-> toSqlCode trig <-> "ON" <-> toSqlCode tbl
]
stmtsDeployTrigger :: SetupContext -> SqlContextSqo Trigger -> [Maybe SqlStmt]
stmtsDeployTrigger context obj@SqlContextSqo { sqlSqoSchema = s
, sqlSqoObject = t
} =
stmtsDeployFunction context (SqlContextSqoArgtypes s triggerFunction) ++
map triggerStmt (triggerTables t)
where
triggerFunction =
Function
{ functionName = triggerName t
, functionDescription = triggerDescription t
, functionReturns = SqlType "trigger"
, functionParameters = Nothing
, functionTemplates = Nothing
, functionTemplateData = Nothing
, functionReturnsColumns = Nothing
, functionVariables = triggerVariables t
-- TODO: trigger owner?
, functionPrivExecute = Just []
, functionSecurityDefiner = Just True
-- TODO: trigger owner?
, functionOwner = Nothing
, functionLanguage = triggerLanguage t
, functionBody = triggerBody t
}
triggerStmt tbl =
newSqlStmt SqlCreateTrigger obj $
"CREATE TRIGGER " <> toSqlCode (triggerName t) <> " " <> triggerMoment t <>
" " <>
T.intercalate " OR " (triggerEvents t) <>
" ON " <>
toSqlCode tbl <>
" FOR EACH " <>
triggerForEach t <>
condition (triggerCondition t) <>
" EXECUTE PROCEDURE " <>
sqlIdCode obj <>
"()"
condition Nothing = ""
condition (Just x) = " WHEN " <> x <> " "
instance ToSqlStmts (SqlContext (Schema, Table, Trigger)) where
toSqlStmts _ obj@(SqlContext (s, tabl, t)) = [triggerStmt, triggerComment]
where
triggerComment =
newSqlStmt SqlComment obj $
"COMMENT ON TRIGGER " <> toSqlCode (triggerName t) <> " ON " <>
sqlIdCode (SqlContext (s, tabl)) <>
" IS " <>
toSqlCodeString (triggerDescription t)
triggerStmt =
newSqlStmt SqlCreateTrigger obj $
"CREATE TRIGGER " <> toSqlCode (triggerName t) <> " " <> triggerMoment t <>
" " <>
T.intercalate " OR " (triggerEvents t) <>
" ON " <>
sqlIdCode (SqlContext (s, tabl)) <>
" FOR EACH " <>
triggerForEach t <>
condition (triggerCondition t) <>
" EXECUTE PROCEDURE " <>
triggerExecute t
condition Nothing = ""
condition (Just x) = " WHEN (" <> x <> ") "
......@@ -17,11 +17,11 @@ instance ToSqlStmts (SqlContext (Schema, Type)) where
toSqlStmts _ obj@(SqlContext (_, t)) =
[ newSqlStmt SqlCreateType obj $
"CREATE TYPE" <-> sqlIdCode obj <-> "AS (" <>
T.intercalate ", " (map sqlElement (typeElements t)) <>
T.intercalate ", " (map sqlElement (_typeElements t)) <>
")"
, stmtCommentOn obj (typeDescription t)
]
-- ALTER TYPE name ALTER ATTRIBUTE attribute_name [ SET DATA ] TYPE data_type
where
sqlElement e =
toSqlCode (typeelementName e) <-> toSqlCode (typeelementType e)
toSqlCode (typeelementName e) <-> toSqlCode (_typeelementType e)
......@@ -6,8 +6,12 @@ module Database.HamSql.Internal.Utils
( module Data.Maybe
, module Database.HamSql.Internal.Utils
, module Database.YamSql.Internal.Utils
, traverseOf
, _Just
, each
) where
import Control.Lens (_Just, each, traverseOf)
import Data.List (group, intercalate, sort)
import Data.Maybe
import qualified Data.Text as T
......
......@@ -40,9 +40,12 @@ data Setup = Setup
, setupRolePrefix :: Maybe Text
, setupPreCode :: Maybe Text
, setupPostCode :: Maybe Text
, setupSchemaData :: Maybe [Schema]
, _setupSchemaData :: Maybe [Schema]
, setupRoles :: Maybe [Role]
} deriving (Generic, Show, Data)
makeLenses ''Setup
instance FromJSON Setup where
parseJSON = parseYamSql
......@@ -93,7 +96,7 @@ selectTemplate x ts =
-- get things from Setup
setupAllSchemas :: Setup -> [Schema]
setupAllSchemas = fromMaybe [] . setupSchemaData
setupAllSchemas = fromMaybe [] . _setupSchemaData
setupAllFunctionTemplates :: Setup -> [WithSchema FunctionTpl]
setupAllFunctionTemplates s =
......@@ -111,12 +114,12 @@ applyTpl :: Setup -> Setup
applyTpl s =
s
-- TODO: possible overwrite here!
{setupSchemaData = map applySchema <$> setupSchemaData s}
{_setupSchemaData = map applySchema <$> _setupSchemaData s}
where
applySchema m =
m
{ schemaTables = map applyTableTemplates <$> schemaTables m
, schemaFunctions = map applyFunctionTemplates <$> schemaFunctions m
{ _schemaTables = map applyTableTemplates <$> _schemaTables m
, _schemaFunctions = map applyFunctionTemplates <$> _schemaFunctions m
}
applyTableTemplates :: Table -> Table
applyTableTemplates t = foldr applyTableTpl t (tableTpls t)
......
module Database.HamSql.Write
( schemaToDirTree
, setupToDirTree
, toYml
, doWrite
) where
......@@ -13,23 +14,31 @@ import Data.Yaml.Pretty
import System.Directory.Tree
import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
import Database.YamSql
setupToDirTree :: FilePath -> Setup -> DirTree B.ByteString
setupToDirTree d s =
let setupFile = File "setup.yml" (toYml s {_setupSchemaData = Nothing})
in Dir
d
(setupFile : (map schemaToDirTree $ fromMaybe [] $ _setupSchemaData s))
schemaToDirTree :: Schema -> DirTree B.ByteString
schemaToDirTree schema =
let schemaFile =
File
"schema.yml"
(toYml schema {schemaTables = Nothing, schemaFunctions = Nothing})
(toYml schema {_schemaTables = Nothing, _schemaFunctions = Nothing})
in Dir
(filePath $ schemaName schema)
(schemaFile :
catMaybes
[ Dir "domains.d" . map (toYamlFile domainName) <$>
schemaDomains schema
_schemaDomains schema
, Dir "sequences.d" . map (toYamlFile sequenceName) <$>
schemaSequences schema
, Dir "types.d" . map (toYamlFile typeName) <$> schemaTypes schema
_schemaSequences schema
, Dir "types.d" . map (toYamlFile typeName) <$> _schemaTypes schema
, Dir "functions.d" .
map
(\x ->
......@@ -37,7 +46,7 @@ schemaToDirTree schema =
functionName
(x {functionBody = Nothing})
(functionBody x)) <$>
schemaFunctions schema
_schemaFunctions schema
])
where
toYamlFile getName obj = File (filePath (getName obj) <> ".yml") (toYml obj)
......@@ -51,7 +60,7 @@ schemaToDirTree schema =
toYml :: ToJSON a => a -> B.ByteString
toYml =
encodePretty $
setConfCompare (comparing ymlOrd) $ (setConfDropNull True) defConfig
setConfCompare (comparing ymlOrd) $ setConfDropNull True defConfig
doWrite :: FilePath -> DirTree B.ByteString -> IO (AnchoredDirTree ())
doWrite p x = writeDirectoryWith B.writeFile (p :/ x)
......
......@@ -14,8 +14,9 @@ import Database.YamSql.Internal.Basic
data Variable = Variable
{ variableName :: SqlName
, variableDescription :: Maybe Text
, variableType :: SqlType
, _variableType :: SqlType
, variableDefault :: Maybe Text
, variableMode :: Maybe Text
} deriving (Generic, Show, Data)
instance FromJSON Variable where
......@@ -24,18 +25,6 @@ instance FromJSON Variable where
instance ToJSON Variable where
toJSON = toYamSqlJson
data Parameter = Parameter
{ parameterName :: SqlName
, parameterDescription :: Maybe Text
, parameterType :: SqlType
} deriving (Generic, Show, Data)
instance FromJSON Parameter where
parseJSON = parseYamSql
instance ToJSON Parameter where
toJSON = toYamSqlJson
data Abbr a b
= ShortForm a
| LongForm b
......@@ -44,3 +33,5 @@ data Abbr a b
instance (FromJSON a, FromJSON b) => FromJSON (Abbr a b) where
parseJSON x@(Object _) = LongForm <$> parseJSON x
parseJSON x = ShortForm <$> parseJSON x
makeLenses ''Variable
......@@ -7,7 +7,7 @@ import Database.YamSql.Internal.Obj.Check
data Domain = Domain
{ domainName :: SqlName
, domainDescription :: Text
, domainType :: SqlType
, _domainType :: SqlType
, domainDefault :: Maybe Text
, domainChecks :: Maybe [Check]
} deriving (Generic, Show, Data)
......@@ -31,3 +31,5 @@ data SQL_DOMAIN_CONSTRAINT =
instance ToSqlCode SQL_DOMAIN_CONSTRAINT where
toSqlCode = const "DOMAIN_CONSTRAINT"
makeLenses ''Domain
......@@ -13,17 +13,14 @@ data Function = Function
-- | description what the function is good for
, functionDescription :: Text
-- | return type of the function, TABLE is special (see return_columns)
, functionReturns :: SqlType
, _functionReturns :: ReturnType
-- | parameters the function takes
, functionParameters :: Maybe [Variable]
, _functionParameters :: Maybe [Variable]