mirror of
https://github.com/dimitri/pgloader.git
synced 2025-08-06 22:37:02 +02:00
1975 lines
60 KiB
Common Lisp
1975 lines
60 KiB
Common Lisp
;;;
|
||
;;; Parse the pgloader commands grammar
|
||
;;;
|
||
|
||
(in-package :pgloader.parser)
|
||
|
||
(defvar *data-expected-inline* nil
|
||
"Set to :inline when parsing an INLINE keyword in a FROM clause.")
|
||
|
||
;;
|
||
;; Some useful rules
|
||
;;
|
||
(defrule single-line-comment (and "--" (+ (not #\Newline)) #\Newline)
|
||
(:constant :comment))
|
||
|
||
(defrule multi-line-comment (and "/*" (+ (not "*/")) "*/")
|
||
(:constant :comment))
|
||
|
||
(defrule comments (or single-line-comment multi-line-comment))
|
||
|
||
(defrule keep-a-single-whitespace (+ (or #\space #\tab #\newline #\linefeed))
|
||
(:constant " "))
|
||
|
||
(defrule whitespace (+ (or #\space #\tab #\newline #\linefeed comments))
|
||
(:constant 'whitespace))
|
||
|
||
(defrule ignore-whitespace (* whitespace)
|
||
(:constant nil))
|
||
|
||
(defrule punct (or #\, #\- #\_)
|
||
(:text t))
|
||
|
||
(defrule namestring (and (alpha-char-p character)
|
||
(* (or (alpha-char-p character)
|
||
(digit-char-p character)
|
||
punct)))
|
||
(:text t))
|
||
|
||
(defrule quoted-namestring (and #\' namestring #\')
|
||
(:destructure (open name close) (declare (ignore open close)) name))
|
||
|
||
(defrule name (or namestring quoted-namestring)
|
||
(:text t))
|
||
|
||
(defrule trimmed-name (and ignore-whitespace name)
|
||
(:destructure (whitespace name) (declare (ignore whitespace)) name))
|
||
|
||
|
||
;;;
|
||
;;; Keywords
|
||
;;;
|
||
(defmacro def-keyword-rule (keyword)
|
||
(let ((rule-name (read-from-string (format nil "kw-~a" keyword)))
|
||
(constant (read-from-string (format nil ":~a" keyword))))
|
||
`(defrule ,rule-name (and ignore-whitespace (~ ,keyword) ignore-whitespace)
|
||
(:constant ',constant))))
|
||
|
||
(eval-when (:load-toplevel :compile-toplevel :execute)
|
||
(def-keyword-rule "load")
|
||
(def-keyword-rule "data")
|
||
(def-keyword-rule "from")
|
||
(def-keyword-rule "csv")
|
||
(def-keyword-rule "dbf")
|
||
(def-keyword-rule "fixed")
|
||
(def-keyword-rule "into")
|
||
(def-keyword-rule "with")
|
||
(def-keyword-rule "when")
|
||
(def-keyword-rule "set")
|
||
(def-keyword-rule "database")
|
||
(def-keyword-rule "messages")
|
||
(def-keyword-rule "matches")
|
||
(def-keyword-rule "in")
|
||
(def-keyword-rule "registering")
|
||
(def-keyword-rule "cast")
|
||
(def-keyword-rule "column")
|
||
(def-keyword-rule "type")
|
||
(def-keyword-rule "extra")
|
||
(def-keyword-rule "include")
|
||
(def-keyword-rule "drop")
|
||
(def-keyword-rule "not")
|
||
(def-keyword-rule "to")
|
||
(def-keyword-rule "no")
|
||
(def-keyword-rule "null")
|
||
(def-keyword-rule "default")
|
||
(def-keyword-rule "typemod")
|
||
(def-keyword-rule "using")
|
||
;; option for loading from a file
|
||
(def-keyword-rule "workers")
|
||
(def-keyword-rule "batch")
|
||
(def-keyword-rule "size")
|
||
(def-keyword-rule "reject")
|
||
(def-keyword-rule "file")
|
||
(def-keyword-rule "log")
|
||
(def-keyword-rule "level")
|
||
(def-keyword-rule "encoding")
|
||
(def-keyword-rule "truncate")
|
||
(def-keyword-rule "lines")
|
||
(def-keyword-rule "fields")
|
||
(def-keyword-rule "optionally")
|
||
(def-keyword-rule "enclosed")
|
||
(def-keyword-rule "by")
|
||
(def-keyword-rule "escaped")
|
||
(def-keyword-rule "terminated")
|
||
(def-keyword-rule "nullif")
|
||
(def-keyword-rule "blank")
|
||
(def-keyword-rule "skip")
|
||
(def-keyword-rule "header")
|
||
(def-keyword-rule "null")
|
||
(def-keyword-rule "if")
|
||
(def-keyword-rule "as")
|
||
(def-keyword-rule "blanks")
|
||
(def-keyword-rule "date")
|
||
(def-keyword-rule "format")
|
||
(def-keyword-rule "keep")
|
||
(def-keyword-rule "trim")
|
||
(def-keyword-rule "unquoted")
|
||
;; option for MySQL imports
|
||
(def-keyword-rule "schema")
|
||
(def-keyword-rule "only")
|
||
(def-keyword-rule "drop")
|
||
(def-keyword-rule "create")
|
||
(def-keyword-rule "materialize")
|
||
(def-keyword-rule "reset")
|
||
(def-keyword-rule "table")
|
||
(def-keyword-rule "name")
|
||
(def-keyword-rule "names")
|
||
(def-keyword-rule "tables")
|
||
(def-keyword-rule "views")
|
||
(def-keyword-rule "indexes")
|
||
(def-keyword-rule "sequences")
|
||
(def-keyword-rule "foreign")
|
||
(def-keyword-rule "keys")
|
||
(def-keyword-rule "downcase")
|
||
(def-keyword-rule "quote")
|
||
(def-keyword-rule "identifiers")
|
||
(def-keyword-rule "including")
|
||
(def-keyword-rule "excluding")
|
||
;; option for loading from an archive
|
||
(def-keyword-rule "archive")
|
||
(def-keyword-rule "before")
|
||
(def-keyword-rule "after")
|
||
(def-keyword-rule "finally")
|
||
(def-keyword-rule "and")
|
||
(def-keyword-rule "do")
|
||
(def-keyword-rule "filename")
|
||
(def-keyword-rule "matching"))
|
||
|
||
(defrule kw-auto-increment (and "auto_increment" (* (or #\Tab #\Space)))
|
||
(:constant :auto-increment))
|
||
|
||
|
||
;;;
|
||
;;; Regular Expression support, quoted as-you-like
|
||
;;;
|
||
(defun process-quoted-regex (pr)
|
||
"Helper function to process different kinds of quotes for regexps"
|
||
(destructuring-bind (open regex close) pr
|
||
(declare (ignore open close))
|
||
`(:regex ,(text regex))))
|
||
|
||
(defrule single-quoted-regex (and #\' (+ (not #\')) #\')
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule double-quoted-regex (and #\" (+ (not #\")) #\")
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule parens-quoted-regex (and #\( (+ (not #\))) #\))
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule braces-quoted-regex (and #\{ (+ (not #\})) #\})
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule chevron-quoted-regex (and #\< (+ (not #\>)) #\>)
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule brackets-quoted-regex (and #\[ (+ (not #\])) #\])
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule slash-quoted-regex (and #\/ (+ (not #\/)) #\/)
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule pipe-quoted-regex (and #\| (+ (not #\|)) #\|)
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule sharp-quoted-regex (and #\# (+ (not #\#)) #\#)
|
||
(:function process-quoted-regex))
|
||
|
||
(defrule quoted-regex (and "~" (or single-quoted-regex
|
||
double-quoted-regex
|
||
parens-quoted-regex
|
||
braces-quoted-regex
|
||
chevron-quoted-regex
|
||
brackets-quoted-regex
|
||
slash-quoted-regex
|
||
pipe-quoted-regex
|
||
sharp-quoted-regex))
|
||
(:lambda (qr)
|
||
(destructuring-bind (tilde regex) qr
|
||
(declare (ignore tilde))
|
||
regex)))
|
||
|
||
|
||
;;;
|
||
;;; The main target parsing
|
||
;;;
|
||
;;; COPY postgresql://user@localhost:5432/dbname?foo
|
||
;;;
|
||
;;
|
||
;; Parse PostgreSQL database connection strings
|
||
;;
|
||
;; at postgresql://[user[:password]@][netloc][:port][/dbname]?table-name
|
||
;;
|
||
;; http://www.postgresql.org/docs/9.2/static/libpq-connect.html#LIBPQ-CONNSTRING
|
||
;;
|
||
;; Also parse MySQL connection strings and syslog service definition
|
||
;; strings, using the same model.
|
||
;;
|
||
(defrule dsn-port (and ":" (* (digit-char-p character)))
|
||
(:destructure (colon digits &aux (port (coerce digits 'string)))
|
||
(declare (ignore colon))
|
||
(list :port (if (null digits) digits
|
||
(parse-integer port)))))
|
||
|
||
(defrule doubled-at-sign (and "@@") (:constant "@"))
|
||
(defrule doubled-colon (and "::") (:constant ":"))
|
||
(defrule password (+ (or (not "@") doubled-at-sign)) (:text t))
|
||
(defrule username (+ (or (not (or ":" "@")) doubled-at-sign doubled-colon))
|
||
(:text t))
|
||
|
||
(defrule dsn-user-password (and username
|
||
(? (and ":" (? password)))
|
||
"@")
|
||
(:lambda (args)
|
||
(destructuring-bind (username &optional password)
|
||
(butlast args)
|
||
;; password looks like '(":" "password")
|
||
(list :user username :password (cadr password)))))
|
||
|
||
(defun hexdigit-char-p (character)
|
||
(member character #. (quote (coerce "0123456789abcdefABCDEF" 'list))))
|
||
|
||
(defrule ipv4-part (and (digit-char-p character)
|
||
(? (digit-char-p character))
|
||
(? (digit-char-p character))))
|
||
|
||
(defrule ipv4 (and ipv4-part "." ipv4-part "." ipv4-part "." ipv4-part)
|
||
(:lambda (ipv4)
|
||
(list :ipv4 (text ipv4))))
|
||
|
||
;;; socket directory is unix only, so we can forbid ":" on the parsing
|
||
(defun socket-directory-character-p (char)
|
||
(or (member char #.(quote (coerce "/.-_" 'list)))
|
||
(alphanumericp char)))
|
||
|
||
(defrule socket-directory (and "unix:" (* (socket-directory-character-p character)))
|
||
(:destructure (unix socket-directory)
|
||
(declare (ignore unix))
|
||
(list :unix (when socket-directory (text socket-directory)))))
|
||
|
||
(defrule network-name (and namestring (? (and "." network-name)))
|
||
(:lambda (name)
|
||
(list :host (text name))))
|
||
|
||
(defrule hostname (or ipv4 socket-directory network-name)
|
||
(:identity t))
|
||
|
||
(defrule dsn-hostname (and (? hostname) (? dsn-port))
|
||
(:destructure (hostname &optional port)
|
||
(append (list :host hostname) port)))
|
||
|
||
(defrule dsn-dbname (and "/" (? namestring))
|
||
(:destructure (slash dbname)
|
||
(declare (ignore slash))
|
||
(list :dbname dbname)))
|
||
|
||
(defrule qualified-table-name (and namestring "." namestring)
|
||
(:destructure (schema dot table)
|
||
(declare (ignore dot))
|
||
(format nil "~a.~a" (text schema) (text table))))
|
||
|
||
(defrule dsn-table-name (and "?" (or qualified-table-name namestring))
|
||
(:destructure (qm name)
|
||
(declare (ignore qm))
|
||
(list :table-name name)))
|
||
|
||
(defrule dsn-prefix (and (+ (alpha-char-p character)) "://")
|
||
(:destructure (p c-s-s &aux (prefix (coerce p 'string)))
|
||
(declare (ignore c-s-s))
|
||
(cond ((string= "postgresql" prefix) (list :type :postgresql))
|
||
((string= "mysql" prefix) (list :type :mysql))
|
||
((string= "syslog" prefix) (list :type :syslog))
|
||
(t (list :type :unknown)))))
|
||
|
||
(defrule db-connection-uri (and dsn-prefix
|
||
(? dsn-user-password)
|
||
(? dsn-hostname)
|
||
dsn-dbname
|
||
(? dsn-table-name))
|
||
(:lambda (uri)
|
||
(destructuring-bind (&key type
|
||
user
|
||
password
|
||
host
|
||
port
|
||
dbname
|
||
table-name)
|
||
(apply #'append uri)
|
||
;;
|
||
;; Default to environment variables as described in
|
||
;; http://www.postgresql.org/docs/9.3/static/app-psql.html
|
||
;; http://dev.mysql.com/doc/refman/5.0/en/environment-variables.html
|
||
;;
|
||
(let ((user
|
||
(or user
|
||
(case type
|
||
(:postgresql (getenv-default "PGUSER" (getenv-default "USER")))
|
||
(:mysql (getenv-default "USER"))))))
|
||
(list :type type
|
||
:user user
|
||
:password password
|
||
:host (or (when host
|
||
(destructuring-bind (type &optional name) host
|
||
(ecase type
|
||
(:unix (if name (cons :unix name) :unix))
|
||
(:ipv4 name)
|
||
(:host name))))
|
||
(case type
|
||
(:postgresql (getenv-default "PGHOST"
|
||
#+unix :unix
|
||
#-unix "localhost"))
|
||
(:mysql (getenv-default "MYSQL_HOST" "localhost"))))
|
||
:port (or port
|
||
(parse-integer
|
||
;; avoid a NIL is not a STRING style warning by
|
||
;; using ecase here
|
||
(ecase type
|
||
(:postgresql (getenv-default "PGPORT" "5432"))
|
||
(:mysql (getenv-default "MYSQL_TCP_PORT" "3306")))))
|
||
:dbname (or dbname
|
||
(case type
|
||
(:postgresql (getenv-default "PGDATABASE" user))))
|
||
:table-name table-name)))))
|
||
|
||
(defrule target (and kw-into db-connection-uri)
|
||
(:destructure (into target)
|
||
(declare (ignore into))
|
||
(destructuring-bind (&key type &allow-other-keys) target
|
||
(unless (eq type :postgresql)
|
||
(error "The target must be a PostgreSQL connection string."))
|
||
target)))
|
||
|
||
|
||
;;;
|
||
;;; Source parsing
|
||
;;;
|
||
;;; Source is either a local filename, stdin, a MySQL connection with a
|
||
;;; table-name, or an http uri.
|
||
;;;
|
||
|
||
;; parsing filename
|
||
(defun filename-character-p (char)
|
||
(or (member char #.(quote (coerce "/\\:.-_!@#$%^&*()" 'list)))
|
||
(alphanumericp char)))
|
||
|
||
(defrule stdin (~ "stdin") (:constant (list :stdin nil)))
|
||
(defrule inline (~ "inline")
|
||
(:lambda (i)
|
||
(declare (ignore i))
|
||
(setf *data-expected-inline* :inline)
|
||
(list :inline nil)))
|
||
|
||
(defrule filename (* (filename-character-p character))
|
||
(:lambda (f)
|
||
(list :filename (parse-namestring (coerce f 'string)))))
|
||
|
||
(defrule quoted-filename (and #\' filename #\')
|
||
(:destructure (open f close) (declare (ignore open close)) f))
|
||
|
||
(defrule maybe-quoted-filename (or quoted-filename filename)
|
||
(:identity t))
|
||
|
||
(defrule http-uri (and "http://" (* (filename-character-p character)))
|
||
(:destructure (prefix url)
|
||
(list :http (concatenate 'string prefix url))))
|
||
|
||
(defrule source-uri (or stdin
|
||
http-uri
|
||
db-connection-uri
|
||
maybe-quoted-filename)
|
||
(:identity t))
|
||
|
||
(defrule load-from (and (~ "LOAD") ignore-whitespace (~ "FROM"))
|
||
(:constant :load-from))
|
||
|
||
(defrule source (and load-from ignore-whitespace source-uri)
|
||
(:destructure (load-from ws source)
|
||
(declare (ignore load-from ws))
|
||
source))
|
||
|
||
|
||
;;
|
||
;; Putting it all together, the COPY command
|
||
;;
|
||
;; The output format is Lisp code using the pgloader API.
|
||
;;
|
||
(defrule load (and ignore-whitespace source ignore-whitespace target)
|
||
(:destructure (ws1 source ws2 target)
|
||
(declare (ignore ws1 ws2))
|
||
(destructuring-bind (&key table-name user password host port dbname
|
||
&allow-other-keys)
|
||
target
|
||
`(lambda (&key
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password))
|
||
(pgloader.pgsql:copy-from-file ,dbname ,table-name ',source)))))
|
||
|
||
(defrule database-source (and kw-load kw-database kw-from
|
||
db-connection-uri)
|
||
(:lambda (source)
|
||
(destructuring-bind (l d f uri) source
|
||
(declare (ignore l d f))
|
||
uri)))
|
||
|
||
|
||
;;;
|
||
;;; Parsing GUCs and WITH options for loading from MySQL and from file.
|
||
;;;
|
||
(defun optname-char-p (char)
|
||
(and (or (alphanumericp char)
|
||
(char= char #\-) ; support GUCs
|
||
(char= char #\_)) ; support GUCs
|
||
(not (char= char #\Space))))
|
||
|
||
(defrule optname-element (* (optname-char-p character)))
|
||
(defrule another-optname-element (and keep-a-single-whitespace optname-element))
|
||
|
||
(defrule optname (and optname-element (* another-optname-element))
|
||
(:lambda (source)
|
||
(string-trim " " (text source))))
|
||
|
||
(defun optvalue-char-p (char)
|
||
(not (member char '(#\, #\; #\=) :test #'char=)))
|
||
|
||
(defrule optvalue (+ (optvalue-char-p character))
|
||
(:text t))
|
||
|
||
(defrule equal-sign (and (* whitespace) #\= (* whitespace))
|
||
(:constant :equal))
|
||
|
||
(defrule option-workers (and kw-workers equal-sign (+ (digit-char-p character)))
|
||
(:lambda (workers)
|
||
(destructuring-bind (w e nb) workers
|
||
(declare (ignore w e))
|
||
(cons :workers (parse-integer (text nb))))))
|
||
|
||
(defmacro make-option-rule (name rule &optional option)
|
||
"Generates a rule named NAME to parse RULE and return OPTION."
|
||
(let* ((bindings
|
||
(loop for element in rule
|
||
unless (member element '(and or))
|
||
collect (if (and (typep element 'list)
|
||
(eq '? (car element))) 'no (gensym))))
|
||
(ignore (loop for b in bindings unless (eq 'no b) collect b))
|
||
(option-name (intern (string-upcase (format nil "option-~a" name))))
|
||
(option (or option (intern (symbol-name name) :keyword))))
|
||
`(defrule ,option-name ,rule
|
||
(:destructure ,bindings
|
||
(declare (ignore ,@ignore))
|
||
(cons ,option (null no))))))
|
||
|
||
(make-option-rule include-drop (and kw-include (? kw-no) kw-drop))
|
||
(make-option-rule truncate (and (? kw-no) kw-truncate))
|
||
(make-option-rule create-tables (and kw-create (? kw-no) kw-tables))
|
||
(make-option-rule create-indexes (and kw-create (? kw-no) kw-indexes))
|
||
(make-option-rule reset-sequences (and kw-reset (? kw-no) kw-sequences))
|
||
(make-option-rule foreign-keys (and (? kw-no) kw-foreign kw-keys))
|
||
|
||
(defrule option-schema-only (and kw-schema kw-only)
|
||
(:constant (cons :schema-only t)))
|
||
|
||
(defrule option-data-only (and kw-data kw-only)
|
||
(:constant (cons :data-only t)))
|
||
|
||
(defrule option-identifiers-case (and (or kw-downcase kw-quote) kw-identifiers)
|
||
(:lambda (id-case)
|
||
(destructuring-bind (action id) id-case
|
||
(declare (ignore id))
|
||
(cons :identifier-case action))))
|
||
|
||
(defrule mysql-option (or option-workers
|
||
option-truncate
|
||
option-data-only
|
||
option-schema-only
|
||
option-include-drop
|
||
option-create-tables
|
||
option-create-indexes
|
||
option-reset-sequences
|
||
option-foreign-keys
|
||
option-identifiers-case))
|
||
|
||
(defrule comma (and ignore-whitespace #\, ignore-whitespace)
|
||
(:constant :comma))
|
||
|
||
(defrule another-mysql-option (and comma mysql-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule mysql-option-list (and mysql-option (* another-mysql-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
(alexandria:alist-plist (list* opt1 opts)))))
|
||
|
||
(defrule mysql-options (and kw-with mysql-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (w opts) source
|
||
(declare (ignore w))
|
||
opts)))
|
||
|
||
;; we don't validate GUCs, that's PostgreSQL job.
|
||
(defrule generic-optname optname-element
|
||
(:text t))
|
||
|
||
(defrule generic-value (and #\' (* (not #\')) #\')
|
||
(:lambda (quoted)
|
||
(destructuring-bind (open value close) quoted
|
||
(declare (ignore open close))
|
||
(text value))))
|
||
|
||
(defrule generic-option (and generic-optname
|
||
(or equal-sign kw-to)
|
||
generic-value)
|
||
(:lambda (source)
|
||
(destructuring-bind (name es value) source
|
||
(declare (ignore es))
|
||
(cons name value))))
|
||
|
||
(defrule another-generic-option (and comma generic-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule generic-option-list (and generic-option (* another-generic-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
;; here we want an alist
|
||
(list* opt1 opts))))
|
||
|
||
(defrule gucs (and kw-set generic-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (set gucs) source
|
||
(declare (ignore set))
|
||
gucs)))
|
||
|
||
|
||
#|
|
||
BEFORE LOAD DO $$ sql $$
|
||
|
||
LOAD CSV FROM '*/GeoLiteCity-Blocks.csv' ...
|
||
LOAD DBF FROM '*/GeoLiteCity-Location.csv' ...
|
||
|
||
FINALLY DO $$ sql $$;
|
||
|#
|
||
(defrule double-dollar (and ignore-whitespace #\$ #\$ ignore-whitespace)
|
||
(:constant :double-dollars))
|
||
|
||
(defrule dollar-quoted (and double-dollar (* (not double-dollar)) double-dollar)
|
||
(:lambda (dq)
|
||
(destructuring-bind (open quoted close) dq
|
||
(declare (ignore open close))
|
||
(text quoted))))
|
||
|
||
(defrule another-dollar-quoted (and comma dollar-quoted)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma quoted) source
|
||
(declare (ignore comma))
|
||
quoted)))
|
||
|
||
(defrule dollar-quoted-list (and dollar-quoted (* another-dollar-quoted))
|
||
(:lambda (source)
|
||
(destructuring-bind (dq1 dqs) source
|
||
(list* dq1 dqs))))
|
||
|
||
(defrule before-load-do (and kw-before kw-load kw-do dollar-quoted-list)
|
||
(:lambda (bld)
|
||
(destructuring-bind (before load do quoted) bld
|
||
(declare (ignore before load do))
|
||
quoted)))
|
||
|
||
(defrule finally-do (and kw-finally kw-do dollar-quoted-list)
|
||
(:lambda (fd)
|
||
(destructuring-bind (finally do quoted) fd
|
||
(declare (ignore finally do))
|
||
quoted)))
|
||
|
||
(defrule after-load-do (and kw-after kw-load kw-do dollar-quoted-list)
|
||
(:lambda (fd)
|
||
(destructuring-bind (after load do quoted) fd
|
||
(declare (ignore after load do))
|
||
quoted)))
|
||
|
||
(defun sql-code-block (dbname state commands label)
|
||
"Return lisp code to run COMMANDS against DBNAME, updating STATE."
|
||
(when commands
|
||
`(with-stats-collection (,dbname ,label :state ,state)
|
||
(with-pgsql-transaction (,dbname)
|
||
(loop for command in ',commands
|
||
do
|
||
(log-message :notice command)
|
||
(pgsql-execute command :client-min-messages :error))))))
|
||
|
||
|
||
;;;
|
||
;;; Now parsing CAST rules for migrating from MySQL
|
||
;;;
|
||
(defrule cast-typemod-guard (and kw-when sexp)
|
||
(:destructure (w expr) (declare (ignore w)) (cons :typemod expr)))
|
||
|
||
(defrule cast-default-guard (and kw-when kw-default quoted-string)
|
||
(:destructure (w d value) (declare (ignore w d)) (cons :default value)))
|
||
|
||
(defrule cast-source-guards (* (or cast-default-guard
|
||
cast-typemod-guard))
|
||
(:lambda (guards)
|
||
(alexandria:alist-plist guards)))
|
||
|
||
;; at the moment we only know about extra auto_increment
|
||
(defrule cast-source-extra (and kw-with kw-extra kw-auto-increment)
|
||
(:constant (list :auto-increment t)))
|
||
|
||
(defrule cast-source-type (and kw-type trimmed-name)
|
||
(:destructure (kw name) (declare (ignore kw)) (list :type name)))
|
||
|
||
(defrule table-column-name (and namestring "." namestring)
|
||
(:destructure (table-name dot column-name)
|
||
(declare (ignore dot))
|
||
(list :column (cons (text table-name) (text column-name)))))
|
||
|
||
(defrule cast-source-column (and kw-column table-column-name)
|
||
;; well, we want namestring . namestring
|
||
(:destructure (kw name) (declare (ignore kw)) name))
|
||
|
||
(defrule cast-source (and (or cast-source-type cast-source-column)
|
||
(? cast-source-extra)
|
||
(? cast-source-guards)
|
||
ignore-whitespace)
|
||
(:lambda (source)
|
||
(destructuring-bind (name-and-type opts guards ws) source
|
||
(declare (ignore ws))
|
||
(destructuring-bind (&key (default nil d-s-p)
|
||
(typemod nil t-s-p)
|
||
&allow-other-keys)
|
||
guards
|
||
(destructuring-bind (&key (auto-increment nil ai-s-p)
|
||
&allow-other-keys)
|
||
opts
|
||
`(,@name-and-type
|
||
,@(when t-s-p (list :typemod typemod))
|
||
,@(when d-s-p (list :default default))
|
||
,@(when ai-s-p (list :auto-increment auto-increment))))))))
|
||
|
||
(defrule cast-type-name (and (alpha-char-p character)
|
||
(* (or (alpha-char-p character)
|
||
(digit-char-p character))))
|
||
(:text t))
|
||
|
||
(defrule cast-to-type (and kw-to cast-type-name ignore-whitespace)
|
||
(:lambda (source)
|
||
(destructuring-bind (to type-name ws) source
|
||
(declare (ignore to ws))
|
||
(list :type type-name))))
|
||
|
||
(defrule cast-keep-default (and kw-keep kw-default)
|
||
(:constant (list :drop-default nil)))
|
||
|
||
(defrule cast-keep-typemod (and kw-keep kw-typemod)
|
||
(:constant (list :drop-typemod nil)))
|
||
|
||
(defrule cast-keep-not-null (and kw-keep kw-not kw-null)
|
||
(:constant (list :drop-not-null nil)))
|
||
|
||
(defrule cast-drop-default (and kw-drop kw-default)
|
||
(:constant (list :drop-default t)))
|
||
|
||
(defrule cast-drop-typemod (and kw-drop kw-typemod)
|
||
(:constant (list :drop-typemod t)))
|
||
|
||
(defrule cast-drop-not-null (and kw-drop kw-not kw-null)
|
||
(:constant (list :drop-not-null t)))
|
||
|
||
(defrule cast-def (+ (or cast-to-type
|
||
cast-keep-default
|
||
cast-drop-default
|
||
cast-keep-typemod
|
||
cast-drop-typemod
|
||
cast-keep-not-null
|
||
cast-drop-not-null))
|
||
(:lambda (source)
|
||
(destructuring-bind
|
||
(&key type drop-default drop-typemod drop-not-null &allow-other-keys)
|
||
(apply #'append source)
|
||
(list :type type
|
||
:drop-default drop-default
|
||
:drop-typemod drop-typemod
|
||
:drop-not-null drop-not-null))))
|
||
|
||
(defun function-name-character-p (char)
|
||
(or (member char #.(quote (coerce "/:.-%" 'list)))
|
||
(alphanumericp char)))
|
||
|
||
(defrule function-name (* (function-name-character-p character))
|
||
(:text t))
|
||
|
||
(defrule cast-function (and kw-using function-name)
|
||
(:lambda (function)
|
||
(destructuring-bind (using fname) function
|
||
(declare (ignore using))
|
||
(intern (string-upcase fname) :pgloader.transforms))))
|
||
|
||
(defun fix-target-type (source target)
|
||
"When target has :type nil, steal the source :type definition."
|
||
(if (getf target :type)
|
||
target
|
||
(loop
|
||
for (key value) on target by #'cddr
|
||
append (list key (if (eq :type key) (getf source :type) value)))))
|
||
|
||
(defrule cast-rule (and cast-source cast-def (? cast-function))
|
||
(:lambda (cast)
|
||
(destructuring-bind (source target function) cast
|
||
(list :source source
|
||
:target (fix-target-type source target)
|
||
:using function))))
|
||
|
||
(defrule another-cast-rule (and comma cast-rule)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma rule) source
|
||
(declare (ignore comma))
|
||
rule)))
|
||
|
||
(defrule cast-rule-list (and cast-rule (* another-cast-rule))
|
||
(:lambda (source)
|
||
(destructuring-bind (rule1 rules) source
|
||
(list* rule1 rules))))
|
||
|
||
(defrule casts (and kw-cast cast-rule-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (c casts) source
|
||
(declare (ignore c))
|
||
casts)))
|
||
|
||
|
||
;;;
|
||
;;; Materialize views by copying their data over, allows for doing advanced
|
||
;;; ETL processing by having parts of the processing happen on the MySQL
|
||
;;; query side.
|
||
;;;
|
||
(defrule view-name (and (alpha-char-p character)
|
||
(* (or (alpha-char-p character)
|
||
(digit-char-p character)
|
||
#\_)))
|
||
(:text t))
|
||
|
||
(defrule view-sql (and kw-as dollar-quoted)
|
||
(:destructure (as sql) (declare (ignore as)) sql))
|
||
|
||
(defrule view-definition (and view-name (? view-sql))
|
||
(:destructure (name sql) (cons name sql)))
|
||
|
||
(defrule another-view-definition (and comma view-definition)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma view) source
|
||
(declare (ignore comma))
|
||
view)))
|
||
|
||
(defrule views-list (and view-definition (* another-view-definition))
|
||
(:lambda (vlist)
|
||
(destructuring-bind (view1 views) vlist
|
||
(list* view1 views))))
|
||
|
||
(defrule materialize-views (and kw-materialize kw-views views-list)
|
||
(:destructure (mat views list) (declare (ignore mat views)) list))
|
||
|
||
|
||
;;;
|
||
;;; Including only some tables or excluding some others
|
||
;;;
|
||
(defrule namestring-or-regex (or quoted-namestring quoted-regex))
|
||
|
||
(defrule another-namestring-or-regex (and comma namestring-or-regex)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma re) source
|
||
(declare (ignore comma))
|
||
re)))
|
||
|
||
(defrule filter-list (and namestring-or-regex (* another-namestring-or-regex))
|
||
(:lambda (source)
|
||
(destructuring-bind (filter1 filters) source
|
||
(list* filter1 filters))))
|
||
|
||
(defrule including (and kw-including kw-only kw-table kw-names kw-matching
|
||
filter-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (i o table n m filter-list) source
|
||
(declare (ignore i o table n m))
|
||
filter-list)))
|
||
|
||
(defrule excluding (and kw-excluding kw-table kw-names kw-matching filter-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (e table n m filter-list) source
|
||
(declare (ignore e table n m))
|
||
filter-list)))
|
||
|
||
|
||
;;; LOAD DATABASE FROM mysql://
|
||
(defrule load-mysql-database (and database-source target
|
||
(? mysql-options)
|
||
(? gucs)
|
||
(? casts)
|
||
(? materialize-views)
|
||
(? including)
|
||
(? excluding)
|
||
(? before-load-do)
|
||
(? after-load-do))
|
||
(:lambda (source)
|
||
(destructuring-bind (my-db-uri pg-db-uri options
|
||
gucs casts views
|
||
incl excl
|
||
before after)
|
||
source
|
||
(destructuring-bind (&key ((:host myhost))
|
||
((:port myport))
|
||
((:user myuser))
|
||
((:password mypass))
|
||
((:dbname mydb))
|
||
table-name
|
||
&allow-other-keys)
|
||
my-db-uri
|
||
(destructuring-bind (&key ((:host pghost))
|
||
((:port pgport))
|
||
((:user pguser))
|
||
((:password pgpass))
|
||
((:dbname pgdb))
|
||
&allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before ,(when before `(pgloader.utils:make-pgstate)))
|
||
(*state* (or *state* (pgloader.utils:make-pgstate)))
|
||
(state-idx (pgloader.utils:make-pgstate))
|
||
(state-after (pgloader.utils:make-pgstate))
|
||
(pgloader.mysql:*cast-rules* ',casts)
|
||
(*myconn-host* ,myhost)
|
||
(*myconn-port* ,myport)
|
||
(*myconn-user* ,myuser)
|
||
(*myconn-pass* ,mypass)
|
||
(*pgconn-host* ,pghost)
|
||
(*pgconn-port* ,pgport)
|
||
(*pgconn-user* ,pguser)
|
||
(*pgconn-pass* ,pgpass)
|
||
(*pg-settings* ',gucs)
|
||
(pgloader.pgsql::*pgsql-reserved-keywords*
|
||
(pgloader.pgsql:list-reserved-keywords ,pgdb))
|
||
(source
|
||
(make-instance 'pgloader.mysql::copy-mysql
|
||
:target-db ,pgdb
|
||
:source-db ,mydb)))
|
||
|
||
,(sql-code-block pgdb 'state-before before "before load")
|
||
|
||
(pgloader.mysql:copy-database source
|
||
,@(when table-name
|
||
`(:only-tables ',(list table-name)))
|
||
:including ',incl
|
||
:excluding ',excl
|
||
:materialize-views ',views
|
||
:state-before state-before
|
||
:state-after state-after
|
||
:state-indexes state-idx
|
||
,@options)
|
||
|
||
,(sql-code-block pgdb 'state-after after "after load")
|
||
|
||
(report-full-summary "Total import time" *state*
|
||
:before state-before
|
||
:finally state-after
|
||
:parallel state-idx))))))))
|
||
|
||
|
||
;;;
|
||
;;; LOAD DATABASE FROM SQLite
|
||
;;;
|
||
#|
|
||
load database
|
||
from sqlite:///Users/dim/Downloads/lastfm_tags.db
|
||
into postgresql:///tags
|
||
|
||
with drop tables, create tables, create indexes, reset sequences
|
||
|
||
set work_mem to '16MB', maintenance_work_mem to '512 MB';
|
||
|#
|
||
(defrule sqlite-option (or option-truncate
|
||
option-data-only
|
||
option-schema-only
|
||
option-include-drop
|
||
option-create-tables
|
||
option-create-indexes
|
||
option-reset-sequences))
|
||
|
||
(defrule another-sqlite-option (and comma sqlite-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule sqlite-option-list (and sqlite-option (* another-sqlite-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
(alexandria:alist-plist (list* opt1 opts)))))
|
||
|
||
(defrule sqlite-options (and kw-with sqlite-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (w opts) source
|
||
(declare (ignore w))
|
||
opts)))
|
||
|
||
(defrule sqlite-db-uri (and "sqlite://" filename)
|
||
(:lambda (source)
|
||
(destructuring-bind (prefix filename) source
|
||
(declare (ignore prefix))
|
||
(destructuring-bind (type path) filename
|
||
(declare (ignore type))
|
||
(list :sqlite path)))))
|
||
|
||
(defrule sqlite-uri (or sqlite-db-uri http-uri maybe-quoted-filename))
|
||
(defrule sqlite-source (and kw-load kw-database kw-from sqlite-uri)
|
||
(:destructure (l d f u)
|
||
(declare (ignore l d f))
|
||
u))
|
||
|
||
(defrule load-sqlite-database (and sqlite-source target
|
||
(? sqlite-options)
|
||
(? gucs)
|
||
(? including)
|
||
(? excluding))
|
||
(:lambda (source)
|
||
(destructuring-bind (sqlite-uri pg-db-uri options gucs incl excl) source
|
||
(destructuring-bind (&key host port user password dbname table-name
|
||
&allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before (pgloader.utils:make-pgstate))
|
||
(*state* (pgloader.utils:make-pgstate))
|
||
(db
|
||
,(destructuring-bind (kind url) sqlite-uri
|
||
(ecase kind
|
||
(:http `(with-stats-collection
|
||
(,dbname "download" :state state-before)
|
||
(pgloader.archive:http-fetch-file ,url)))
|
||
(:sqlite url)
|
||
(:filename url))))
|
||
(db
|
||
(if (string= "zip" (pathname-type db))
|
||
(progn
|
||
(with-stats-collection (,dbname "extract"
|
||
:state state-before)
|
||
(let ((d (pgloader.archive:expand-archive db)))
|
||
(merge-pathnames
|
||
(make-pathname :name (pathname-name db)
|
||
:type "db")
|
||
d))))
|
||
db))
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password)
|
||
(*pg-settings* ',gucs)
|
||
(pgloader.pgsql::*pgsql-reserved-keywords*
|
||
(pgloader.pgsql:list-reserved-keywords ,dbname))
|
||
(source
|
||
(make-instance 'pgloader.sqlite::copy-sqlite
|
||
:target-db ,dbname
|
||
:source-db db)))
|
||
(pgloader.sqlite:copy-database source
|
||
:state-before state-before
|
||
,@(when table-name
|
||
`(:only-tables ',(list table-name)))
|
||
:including ',incl
|
||
:excluding ',excl
|
||
,@options)))))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; LOAD MESSAGES FROM syslog
|
||
;;;
|
||
#|
|
||
LOAD MESSAGES FROM syslog://localhost:10514/
|
||
|
||
WHEN MATCHES rsyslog-msg IN apache
|
||
REGISTERING timestamp, ip, rest
|
||
INTO postgresql://localhost/db?logs.apache
|
||
SET guc_1 = 'value', guc_2 = 'other value'
|
||
|
||
WHEN MATCHES rsyslog-msg IN others
|
||
REGISTERING timestamp, app-name, data
|
||
INTO postgresql://localhost/db?logs.others
|
||
SET guc_1 = 'value', guc_2 = 'other value'
|
||
|
||
WITH apache = rsyslog
|
||
DATA = IP REST
|
||
IP = 1*3DIGIT \".\" 1*3DIGIT \".\"1*3DIGIT \".\"1*3DIGIT
|
||
REST = ~/.*/
|
||
|
||
WITH others = rsyslog;
|
||
|#
|
||
(defrule rule-name (and (alpha-char-p character)
|
||
(+ (abnf::rule-name-character-p character)))
|
||
(:lambda (name)
|
||
(text name)))
|
||
|
||
(defrule rules (* (not (or kw-registering
|
||
kw-with
|
||
kw-when
|
||
kw-set
|
||
end-of-command)))
|
||
(:text t))
|
||
|
||
(defrule rule-name-list (and rule-name
|
||
(+ (and "," ignore-whitespace rule-name)))
|
||
(:lambda (list)
|
||
(destructuring-bind (name names) list
|
||
(list* name (mapcar (lambda (x)
|
||
(destructuring-bind (c w n) x
|
||
(declare (ignore c w))
|
||
n)) names)))))
|
||
|
||
(defrule syslog-grammar (and kw-with rule-name equal-sign rule-name rules)
|
||
(:lambda (grammar)
|
||
(destructuring-bind (w top-level e gram abnf) grammar
|
||
(declare (ignore w e))
|
||
(let* ((default-abnf-grammars
|
||
`(("rsyslog" . ,abnf:*abnf-rsyslog*)
|
||
("syslog" . ,abnf:*abnf-rfc5424-syslog-protocol*)
|
||
("syslog-draft-15" . ,abnf:*abnf-rfc-syslog-draft-15*)))
|
||
(grammar (cdr (assoc gram default-abnf-grammars :test #'string=))))
|
||
(cons top-level
|
||
(concatenate 'string
|
||
abnf
|
||
'(#\Newline #\Newline)
|
||
grammar))))))
|
||
|
||
(defrule register-groups (and kw-registering rule-name-list)
|
||
(:lambda (groups)
|
||
(destructuring-bind (reg rule-names) groups
|
||
(declare (ignore reg))
|
||
rule-names)))
|
||
|
||
(defrule syslog-match (and kw-when
|
||
kw-matches rule-name kw-in rule-name
|
||
register-groups
|
||
target
|
||
(? gucs))
|
||
(:lambda (matches)
|
||
(destructuring-bind (w m top-level i rule-name groups target gucs) matches
|
||
(declare (ignore w m i))
|
||
(list :target target
|
||
:gucs gucs
|
||
:top-level top-level
|
||
:grammar rule-name
|
||
:groups groups))))
|
||
|
||
(defrule syslog-connection-uri (and dsn-prefix dsn-hostname (? "/"))
|
||
(:lambda (syslog)
|
||
(destructuring-bind (prefix host-port slash) syslog
|
||
(declare (ignore slash))
|
||
(destructuring-bind (&key type host port)
|
||
(append prefix host-port)
|
||
(list :type type
|
||
:host host
|
||
:port port)))))
|
||
|
||
(defrule syslog-source (and ignore-whitespace
|
||
kw-load kw-messages kw-from
|
||
syslog-connection-uri)
|
||
(:lambda (source)
|
||
(destructuring-bind (nil l d f uri) source
|
||
(declare (ignore l d f))
|
||
uri)))
|
||
|
||
(defrule load-syslog-messages (and syslog-source
|
||
(+ syslog-match)
|
||
(+ syslog-grammar))
|
||
(:lambda (syslog)
|
||
(destructuring-bind (syslog-server matches grammars)
|
||
syslog
|
||
(destructuring-bind (&key ((:host syslog-host))
|
||
((:port syslog-port))
|
||
&allow-other-keys)
|
||
syslog-server
|
||
(let ((scanners
|
||
(loop
|
||
for match in matches
|
||
collect (destructuring-bind (&key target
|
||
gucs
|
||
top-level
|
||
grammar
|
||
groups)
|
||
match
|
||
(list :target target
|
||
:gucs gucs
|
||
:parser (abnf:parse-abnf-grammar
|
||
(cdr (assoc grammar grammars
|
||
:test #'string=))
|
||
top-level
|
||
:registering-rules groups)
|
||
:groups groups)))))
|
||
`(lambda ()
|
||
(let ((scanners ',scanners))
|
||
(pgloader.syslog:stream-messages :host ,syslog-host
|
||
:port ,syslog-port
|
||
:scanners scanners))))))))
|
||
|
||
|
||
#|
|
||
LOAD DBF FROM '/Users/dim/Downloads/comsimp2013.dbf'
|
||
INTO postgresql://dim@localhost:54393/dim?comsimp2013
|
||
WITH truncate, create table, table name = 'comsimp2013'
|
||
|#
|
||
(defrule option-create-table (and kw-create kw-table)
|
||
(:constant (cons :create-table t)))
|
||
|
||
(defrule quoted-table-name (and #\' (or qualified-table-name namestring) #\')
|
||
(:lambda (qtn)
|
||
(destructuring-bind (open name close) qtn
|
||
(declare (ignore open close))
|
||
name)))
|
||
|
||
(defrule option-table-name (and kw-table kw-name equal-sign quoted-table-name)
|
||
(:lambda (tn)
|
||
(destructuring-bind (table name e table-name) tn
|
||
(declare (ignore table name e))
|
||
(cons :table-name (text table-name)))))
|
||
|
||
(defrule dbf-option (or option-truncate option-create-table option-table-name))
|
||
|
||
(defrule another-dbf-option (and comma dbf-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule dbf-option-list (and dbf-option (* another-dbf-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
(alexandria:alist-plist `(,opt1 ,@opts)))))
|
||
|
||
(defrule dbf-options (and kw-with dbf-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (w opts) source
|
||
(declare (ignore w))
|
||
opts)))
|
||
|
||
(defrule dbf-source (and kw-load kw-dbf kw-from filename-or-http-uri)
|
||
(:lambda (src)
|
||
(destructuring-bind (load dbf from source) src
|
||
(declare (ignore load dbf from))
|
||
source)))
|
||
|
||
(defrule load-dbf-file (and dbf-source target dbf-options (? gucs))
|
||
(:lambda (command)
|
||
(destructuring-bind (source pg-db-uri options gucs) command
|
||
(destructuring-bind (&key host port user password dbname table-name
|
||
&allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before (pgloader.utils:make-pgstate))
|
||
(*state* (pgloader.utils:make-pgstate))
|
||
(source
|
||
,(destructuring-bind (kind url) source
|
||
(ecase kind
|
||
(:http `(with-stats-collection
|
||
(,dbname "download" :state state-before)
|
||
(pgloader.archive:http-fetch-file ,url)))
|
||
(:filename url))))
|
||
(source
|
||
(if (string= "zip" (pathname-type source))
|
||
(progn
|
||
(with-stats-collection (,dbname "extract"
|
||
:state state-before)
|
||
(let ((d (pgloader.archive:expand-archive source)))
|
||
(merge-pathnames
|
||
(make-pathname :name (pathname-name source)
|
||
:type "dbf")
|
||
d))))
|
||
source))
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password)
|
||
(*pg-settings* ',gucs)
|
||
(source
|
||
(make-instance 'pgloader.db3:copy-db3
|
||
:target-db ,dbname
|
||
:source source
|
||
:target ,table-name)))
|
||
|
||
(pgloader.sources:copy-from source
|
||
:state-before state-before
|
||
,@options)
|
||
|
||
(report-full-summary "Total import time" *state*
|
||
:before state-before)))))))
|
||
|
||
|
||
#|
|
||
LOAD CSV FROM /Users/dim/dev/CL/pgloader/galaxya/yagoa/communaute_profil.csv
|
||
INTO postgresql://dim@localhost:54393/yagoa?commnaute_profil
|
||
|
||
WITH truncate,
|
||
fields optionally enclosed by '\"',
|
||
fields escaped by \"\,
|
||
fields terminated by '\t',
|
||
reset sequences;
|
||
|
||
LOAD CSV FROM '*/GeoLiteCity-Blocks.csv'
|
||
(
|
||
startIpNum, endIpNum, locId
|
||
)
|
||
INTO postgresql://dim@localhost:54393/dim?geolite.blocks
|
||
(
|
||
iprange ip4r using (ip-range startIpNum endIpNum),
|
||
locId
|
||
)
|
||
WITH truncate,
|
||
skip header = 2,
|
||
fields optionally enclosed by '\"',
|
||
fields escaped by '\"',
|
||
fields terminated by '\t';
|
||
|#
|
||
(defrule hex-char-code (and "0x" (+ (hexdigit-char-p character)))
|
||
(:lambda (hex)
|
||
(destructuring-bind (prefix digits) hex
|
||
(declare (ignore prefix))
|
||
(code-char (parse-integer (text digits) :radix 16)))))
|
||
|
||
(defrule tab (and #\\ #\t) (:constant #\Tab))
|
||
|
||
(defrule separator (and #\' (or hex-char-code tab character ) #\')
|
||
(:lambda (sep)
|
||
(destructuring-bind (open char close) sep
|
||
(declare (ignore open close))
|
||
char)))
|
||
|
||
;;
|
||
;; Main CSV options (WITH ... in the command grammar)
|
||
;;
|
||
(defrule option-skip-header (and kw-skip kw-header equal-sign
|
||
(+ (digit-char-p character)))
|
||
(:lambda (osh)
|
||
(destructuring-bind (skip header eqs digits) osh
|
||
(declare (ignore skip header eqs))
|
||
(cons :skip-lines (parse-integer (text digits))))))
|
||
|
||
(defrule option-fields-enclosed-by
|
||
(and kw-fields (? kw-optionally) kw-enclosed kw-by separator)
|
||
(:lambda (enc)
|
||
(destructuring-bind (f e o b sep) enc
|
||
(declare (ignore f e o b))
|
||
(cons :quote sep))))
|
||
|
||
(defrule option-fields-not-enclosed (and kw-fields kw-not kw-enclosed)
|
||
(:constant (cons :quote nil)))
|
||
|
||
(defrule quote-quote "double-quote" (:constant "\"\""))
|
||
(defrule backslash-quote "backslash-quote" (:constant "\\\""))
|
||
(defrule escaped-quote-name (or quote-quote backslash-quote))
|
||
(defrule escaped-quote-literal (or (and #\" #\") (and #\\ #\")) (:text t))
|
||
(defrule escaped-quote (or escaped-quote-literal escaped-quote-name))
|
||
|
||
(defrule option-fields-escaped-by (and kw-fields kw-escaped kw-by escaped-quote)
|
||
(:lambda (esc)
|
||
(destructuring-bind (f e b sep) esc
|
||
(declare (ignore f e b))
|
||
(cons :escape sep))))
|
||
|
||
(defrule option-terminated-by (and kw-terminated kw-by separator)
|
||
(:lambda (term)
|
||
(destructuring-bind (terminated by sep) term
|
||
(declare (ignore terminated by))
|
||
(cons :separator sep))))
|
||
|
||
(defrule option-fields-terminated-by (and kw-fields option-terminated-by)
|
||
(:lambda (term)
|
||
(destructuring-bind (fields sep) term
|
||
(declare (ignore fields ))
|
||
sep)))
|
||
|
||
(defrule option-keep-unquoted-blanks (and kw-keep kw-unquoted kw-blanks)
|
||
(:constant (cons :trim-blanks nil)))
|
||
|
||
(defrule option-trim-unquoted-blanks (and kw-trim kw-unquoted kw-blanks)
|
||
(:constant (cons :trim-blanks t)))
|
||
|
||
(defrule csv-option (or option-truncate
|
||
option-skip-header
|
||
option-fields-not-enclosed
|
||
option-fields-enclosed-by
|
||
option-fields-escaped-by
|
||
option-fields-terminated-by
|
||
option-trim-unquoted-blanks
|
||
option-keep-unquoted-blanks))
|
||
|
||
(defrule another-csv-option (and comma csv-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule csv-option-list (and csv-option (* another-csv-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
(alexandria:alist-plist `(,opt1 ,@opts)))))
|
||
|
||
(defrule csv-options (and kw-with csv-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (w opts) source
|
||
(declare (ignore w))
|
||
opts)))
|
||
|
||
;;
|
||
;; CSV per-field reading options
|
||
;;
|
||
(defrule single-quoted-string (and #\' (* (not #\')) #\')
|
||
(:lambda (qs)
|
||
(destructuring-bind (open string close) qs
|
||
(declare (ignore open close))
|
||
(text string))))
|
||
|
||
(defrule double-quoted-string (and #\" (* (not #\")) #\")
|
||
(:lambda (qs)
|
||
(destructuring-bind (open string close) qs
|
||
(declare (ignore open close))
|
||
(text string))))
|
||
|
||
(defrule quoted-string (or single-quoted-string double-quoted-string))
|
||
|
||
(defrule option-date-format (and kw-date kw-format quoted-string)
|
||
(:lambda (df)
|
||
(destructuring-bind (date format date-format) df
|
||
(declare (ignore date format))
|
||
(cons :date-format date-format))))
|
||
|
||
(defrule blanks kw-blanks (:constant :blanks))
|
||
|
||
(defrule option-null-if (and kw-null kw-if (or blanks quoted-string))
|
||
(:lambda (nullif)
|
||
(destructuring-bind (null if opt) nullif
|
||
(declare (ignore null if))
|
||
(cons :null-as opt))))
|
||
|
||
(defrule csv-field-option (or option-terminated-by
|
||
option-date-format
|
||
option-null-if))
|
||
|
||
(defrule csv-field-options (* csv-field-option)
|
||
(:lambda (options)
|
||
(alexandria:alist-plist options)))
|
||
|
||
(defrule csv-field-name (and (alpha-char-p character)
|
||
(* (or (alpha-char-p character)
|
||
(digit-char-p character)
|
||
#\_)))
|
||
(:text t))
|
||
|
||
(defrule csv-source-field (and csv-field-name csv-field-options)
|
||
(:destructure (name opts)
|
||
`(,name ,@opts)))
|
||
|
||
(defrule another-csv-source-field (and comma csv-source-field)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma field) source
|
||
(declare (ignore comma))
|
||
field)))
|
||
|
||
(defrule csv-source-fields (and csv-source-field (* another-csv-source-field))
|
||
(:lambda (source)
|
||
(destructuring-bind (field1 fields) source
|
||
(list* field1 fields))))
|
||
|
||
(defrule open-paren (and ignore-whitespace #\( ignore-whitespace)
|
||
(:constant :open-paren))
|
||
(defrule close-paren (and ignore-whitespace #\) ignore-whitespace)
|
||
(:constant :close-paren))
|
||
|
||
(defrule csv-source-field-list (and open-paren csv-source-fields close-paren)
|
||
(:lambda (source)
|
||
(destructuring-bind (open field-defs close) source
|
||
(declare (ignore open close))
|
||
field-defs)))
|
||
|
||
;;
|
||
;; csv-target-column-list
|
||
;;
|
||
;; iprange ip4r using (ip-range startIpNum endIpNum),
|
||
;;
|
||
(defrule column-name csv-field-name) ; same rules here
|
||
(defrule column-type csv-field-name) ; again, same rules, names only
|
||
|
||
(defun not-doublequote (char)
|
||
(not (eql #\" char)))
|
||
|
||
(defun symbol-character-p (character)
|
||
(not (member character '(#\Space #\( #\)))))
|
||
|
||
(defun symbol-first-character-p (character)
|
||
(and (symbol-character-p character)
|
||
(not (member character '(#\+ #\-)))))
|
||
|
||
(defrule sexp-symbol (and (symbol-first-character-p character)
|
||
(* (symbol-character-p character)))
|
||
(:lambda (schars)
|
||
(pgloader.transforms:intern-symbol (text schars))))
|
||
|
||
(defrule sexp-string-char (or (not-doublequote character) (and #\\ #\")))
|
||
|
||
(defrule sexp-string (and #\" (* sexp-string-char) #\")
|
||
(:destructure (q1 string q2)
|
||
(declare (ignore q1 q2))
|
||
(text string)))
|
||
|
||
(defrule sexp-integer (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
|
||
(:lambda (list)
|
||
(parse-integer (text list) :radix 10)))
|
||
|
||
(defrule sexp-list (and open-paren sexp (* sexp) close-paren)
|
||
(:destructure (open car cdr close)
|
||
(declare (ignore open close))
|
||
(cons car cdr)))
|
||
|
||
(defrule sexp-atom (and ignore-whitespace
|
||
(or sexp-string sexp-integer sexp-symbol))
|
||
(:lambda (atom)
|
||
(destructuring-bind (ws a) atom
|
||
(declare (ignore ws))
|
||
a)))
|
||
|
||
(defrule sexp (or sexp-atom sexp-list))
|
||
|
||
(defrule column-expression (and kw-using sexp)
|
||
(:lambda (expr)
|
||
(destructuring-bind (using sexp) expr
|
||
(declare (ignore using))
|
||
sexp)))
|
||
|
||
(defrule csv-target-column (and column-name
|
||
(? (and ignore-whitespace column-type
|
||
column-expression)))
|
||
(:lambda (col)
|
||
(destructuring-bind (name opts) col
|
||
(if opts
|
||
(destructuring-bind (ws type expr) opts
|
||
(declare (ignore ws))
|
||
(list name type expr))
|
||
(list name nil nil)))))
|
||
|
||
(defrule another-csv-target-column (and comma csv-target-column)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma col) source
|
||
(declare (ignore comma))
|
||
col)))
|
||
|
||
(defrule csv-target-columns (and csv-target-column
|
||
(* another-csv-target-column))
|
||
(:lambda (source)
|
||
(destructuring-bind (col1 cols) source
|
||
(list* col1 cols))))
|
||
|
||
(defrule csv-target-column-list (and open-paren csv-target-columns close-paren)
|
||
(:lambda (source)
|
||
(destructuring-bind (open columns close) source
|
||
(declare (ignore open close))
|
||
columns)))
|
||
;;
|
||
;; The main command parsing
|
||
;;
|
||
(defun find-encoding-by-name-or-alias (encoding)
|
||
"charsets::*lisp-encodings* is an a-list of (NAME . ALIASES)..."
|
||
(loop for (name . aliases) in charsets::*lisp-encodings*
|
||
for encoding-name = (when (or (string-equal name encoding)
|
||
(member encoding aliases :test #'string-equal))
|
||
name)
|
||
until encoding-name
|
||
finally (if encoding-name (return encoding-name)
|
||
(error "The encoding '~a' is unknown" encoding))))
|
||
|
||
(defrule encoding (or namestring single-quoted-string)
|
||
(:lambda (encoding)
|
||
(charsets:make-external-format (find-encoding-by-name-or-alias encoding))))
|
||
|
||
(defrule file-encoding (? (and kw-with kw-encoding encoding))
|
||
(:lambda (enc)
|
||
(if enc
|
||
(destructuring-bind (with kw-encoding encoding) enc
|
||
(declare (ignore with kw-encoding))
|
||
encoding)
|
||
:utf-8)))
|
||
|
||
(defrule filename-matching (and kw-filename kw-matching quoted-regex)
|
||
(:lambda (fm)
|
||
(destructuring-bind (filename matching regex) fm
|
||
(declare (ignore filename matching))
|
||
regex)))
|
||
|
||
(defrule csv-file-source (or stdin
|
||
inline
|
||
filename-matching
|
||
maybe-quoted-filename))
|
||
|
||
(defrule csv-source (and kw-load kw-csv kw-from csv-file-source)
|
||
(:lambda (src)
|
||
(destructuring-bind (load csv from source) src
|
||
(declare (ignore load csv from))
|
||
;; source is (:filename #P"pathname/here")
|
||
(destructuring-bind (type uri) source
|
||
(declare (ignore uri))
|
||
(ecase type
|
||
(:stdin source)
|
||
(:inline source)
|
||
(:filename source)
|
||
(:regex source))))))
|
||
|
||
(defun list-symbols (expression &optional s)
|
||
"Return a list of the symbols used in EXPRESSION."
|
||
(typecase expression
|
||
(symbol (pushnew expression s))
|
||
(list (loop for e in expression for s = (list-symbols e s)
|
||
finally (return (reverse s))))
|
||
(t s)))
|
||
|
||
(defrule load-csv-file (and csv-source (? file-encoding) (? csv-source-field-list)
|
||
target (? csv-target-column-list)
|
||
csv-options
|
||
(? gucs)
|
||
(? before-load-do)
|
||
(? after-load-do))
|
||
(:lambda (command)
|
||
(destructuring-bind (source encoding fields pg-db-uri
|
||
columns options gucs before after) command
|
||
(destructuring-bind (&key host port user password dbname table-name
|
||
&allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before ,(when before `(pgloader.utils:make-pgstate)))
|
||
(summary (null *state*))
|
||
(*state* (or *state* (pgloader.utils:make-pgstate)))
|
||
(state-after ,(when after `(pgloader.utils:make-pgstate)))
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password)
|
||
(*pg-settings* ',gucs)
|
||
(source
|
||
(make-instance 'pgloader.csv:copy-csv
|
||
:target-db ,dbname
|
||
:source ',source
|
||
:target ,table-name
|
||
:encoding ,encoding
|
||
:fields ',fields
|
||
:columns ',columns
|
||
,@(loop for (k v) on options by #'cddr
|
||
unless (eq k :truncate)
|
||
append (list k v)))))
|
||
|
||
(progn
|
||
,(sql-code-block dbname 'state-before before "before load")
|
||
|
||
(pgloader.sources:copy-from source
|
||
:truncate (getf ',options :truncate))
|
||
|
||
,(sql-code-block dbname 'state-after after "after load")
|
||
|
||
;; reporting
|
||
(when summary
|
||
(report-full-summary "Total import time" *state*
|
||
:before state-before
|
||
:finally state-after)))))))))
|
||
|
||
|
||
;;;
|
||
;;; LOAD FIXED COLUMNS FILE
|
||
;;;
|
||
;;; That has lots in common with CSV, so we share a fair amount of parsing
|
||
;;; rules with the CSV case.
|
||
;;;
|
||
(defrule hex-number (and "0x" (+ (hexdigit-char-p character)))
|
||
(:lambda (hex)
|
||
(destructuring-bind (prefix digits) hex
|
||
(declare (ignore prefix))
|
||
(parse-integer (text digits) :radix 16))))
|
||
|
||
(defrule dec-number (+ (digit-char-p character))
|
||
(:lambda (digits)
|
||
(parse-integer (text digits))))
|
||
|
||
(defrule number (or hex-number dec-number))
|
||
|
||
(defrule field-start-position (and ignore-whitespace number)
|
||
(:destructure (ws pos) (declare (ignore ws)) pos))
|
||
|
||
(defrule fixed-field-length (and ignore-whitespace number)
|
||
(:destructure (ws len) (declare (ignore ws)) len))
|
||
|
||
(defrule fixed-source-field (and csv-field-name
|
||
field-start-position fixed-field-length
|
||
csv-field-options)
|
||
(:destructure (name start len opts)
|
||
`(,name :start ,start :length ,len ,@opts)))
|
||
|
||
(defrule another-fixed-source-field (and comma fixed-source-field)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma field) source
|
||
(declare (ignore comma))
|
||
field)))
|
||
|
||
(defrule fixed-source-fields (and fixed-source-field (* another-fixed-source-field))
|
||
(:lambda (source)
|
||
(destructuring-bind (field1 fields) source
|
||
(list* field1 fields))))
|
||
|
||
(defrule fixed-source-field-list (and open-paren fixed-source-fields close-paren)
|
||
(:lambda (source)
|
||
(destructuring-bind (open field-defs close) source
|
||
(declare (ignore open close))
|
||
field-defs)))
|
||
|
||
(defrule fixed-option (or option-truncate
|
||
option-skip-header))
|
||
|
||
(defrule another-fixed-option (and comma fixed-option)
|
||
(:lambda (source)
|
||
(destructuring-bind (comma option) source
|
||
(declare (ignore comma))
|
||
option)))
|
||
|
||
(defrule fixed-option-list (and fixed-option (* another-fixed-option))
|
||
(:lambda (source)
|
||
(destructuring-bind (opt1 opts) source
|
||
(alexandria:alist-plist `(,opt1 ,@opts)))))
|
||
|
||
(defrule fixed-options (and kw-with csv-option-list)
|
||
(:lambda (source)
|
||
(destructuring-bind (w opts) source
|
||
(declare (ignore w))
|
||
opts)))
|
||
|
||
|
||
(defrule fixed-file-source (or stdin
|
||
inline
|
||
filename-matching
|
||
maybe-quoted-filename))
|
||
|
||
(defrule fixed-source (and kw-load kw-fixed kw-from fixed-file-source)
|
||
(:lambda (src)
|
||
(destructuring-bind (load fixed from source) src
|
||
(declare (ignore load fixed from))
|
||
;; source is (:filename #P"pathname/here")
|
||
(destructuring-bind (type uri) source
|
||
(declare (ignore uri))
|
||
(ecase type
|
||
(:stdin source)
|
||
(:inline source)
|
||
(:filename source)
|
||
(:regex source))))))
|
||
|
||
(defrule load-fixed-cols-file (and fixed-source (? file-encoding)
|
||
fixed-source-field-list
|
||
target
|
||
(? csv-target-column-list)
|
||
(? fixed-options)
|
||
(? gucs)
|
||
(? before-load-do)
|
||
(? after-load-do))
|
||
(:lambda (command)
|
||
(destructuring-bind (source encoding fields pg-db-uri
|
||
columns options gucs before after) command
|
||
(destructuring-bind (&key host port user password dbname table-name
|
||
&allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before ,(when before `(pgloader.utils:make-pgstate)))
|
||
(summary (null *state*))
|
||
(*state* (or *state* (pgloader.utils:make-pgstate)))
|
||
(state-after ,(when after `(pgloader.utils:make-pgstate)))
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password)
|
||
(*pg-settings* ',gucs)
|
||
(source
|
||
(make-instance 'pgloader.fixed:copy-fixed
|
||
:target-db ,dbname
|
||
:source ',source
|
||
:target ,table-name
|
||
:encoding ,encoding
|
||
:fields ',fields
|
||
:columns ',columns
|
||
:skip-lines ,(or (getf options :skip-line) 0))))
|
||
|
||
(progn
|
||
,(sql-code-block dbname 'state-before before "before load")
|
||
|
||
(pgloader.sources:copy-from source
|
||
:truncate ,(getf options :truncate))
|
||
|
||
,(sql-code-block dbname 'state-after after "after load")
|
||
|
||
;; reporting
|
||
(when summary
|
||
(report-full-summary "Total import time" *state*
|
||
:before state-before
|
||
:finally state-after)))))))))
|
||
|
||
|
||
;;;
|
||
;;; LOAD ARCHIVE ...
|
||
;;;
|
||
(defrule archive-command (or load-csv-file
|
||
load-dbf-file
|
||
load-fixed-cols-file))
|
||
|
||
(defrule another-archive-command (and kw-and archive-command)
|
||
(:lambda (source)
|
||
(destructuring-bind (and col) source
|
||
(declare (ignore and))
|
||
col)))
|
||
|
||
(defrule archive-command-list (and archive-command (* another-archive-command))
|
||
(:lambda (source)
|
||
(destructuring-bind (col1 cols) source
|
||
(list* col1 cols))))
|
||
|
||
(defrule filename-or-http-uri (or http-uri maybe-quoted-filename))
|
||
|
||
(defrule archive-source (and kw-load kw-archive kw-from filename-or-http-uri)
|
||
(:lambda (src)
|
||
(destructuring-bind (load from archive source) src
|
||
(declare (ignore load from archive))
|
||
source)))
|
||
|
||
(defrule load-archive (and archive-source
|
||
target
|
||
(? before-load-do)
|
||
archive-command-list
|
||
(? finally-do))
|
||
(:lambda (archive)
|
||
(destructuring-bind (source pg-db-uri before commands finally) archive
|
||
(destructuring-bind (&key host port user password dbname &allow-other-keys)
|
||
pg-db-uri
|
||
`(lambda ()
|
||
(let* ((state-before ,(when before (pgloader.utils:make-pgstate)))
|
||
(*state* (pgloader.utils:make-pgstate))
|
||
(state-finally ,(when finally `(pgloader.utils:make-pgstate)))
|
||
(archive-file
|
||
,(destructuring-bind (kind url) source
|
||
(ecase kind
|
||
(:http `(with-stats-collection
|
||
(,dbname "download" :state state-before)
|
||
(pgloader.archive:http-fetch-file ,url)))
|
||
(:filename url))))
|
||
(*csv-path-root*
|
||
(with-stats-collection (,dbname "extract" :state state-before)
|
||
(pgloader.archive:expand-archive archive-file)))
|
||
(*pgconn-host* ,host)
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password))
|
||
(progn
|
||
,(sql-code-block dbname 'state-before before "before load")
|
||
|
||
;; import from files block
|
||
,@(loop for command in commands
|
||
collect `(funcall ,command))
|
||
|
||
,(sql-code-block dbname 'state-finally finally "finally")
|
||
|
||
;; reporting
|
||
(report-full-summary "Total import time" *state*
|
||
:before state-before
|
||
:finally state-finally))))))))
|
||
|
||
|
||
;;;
|
||
;;; Now the main command, one of
|
||
;;;
|
||
;;; - LOAD FROM some files
|
||
;;; - LOAD DATABASE FROM a MySQL remote database
|
||
;;; - LOAD MESSAGES FROM a syslog daemon receiver we're going to start here
|
||
;;;
|
||
(defrule end-of-command (and ignore-whitespace #\; ignore-whitespace)
|
||
(:constant :eoc))
|
||
|
||
(defrule command (and (or load-archive
|
||
load-csv-file
|
||
load-fixed-cols-file
|
||
load-dbf-file
|
||
load-mysql-database
|
||
load-sqlite-database
|
||
load-syslog-messages)
|
||
end-of-command)
|
||
(:lambda (cmd)
|
||
(destructuring-bind (command eoc) cmd
|
||
(declare (ignore eoc))
|
||
command)))
|
||
|
||
(defrule commands (+ command))
|
||
|
||
(defun parse-commands (commands)
|
||
"Parse a command and return a LAMBDA form that takes no parameter."
|
||
(parse 'commands commands))
|
||
|
||
(defun inject-inline-data-position (command position)
|
||
"We have '(:inline nil) somewhere in command, have '(:inline position) instead."
|
||
(loop
|
||
for s-exp in command
|
||
when (equal '(:inline nil) s-exp) collect (list :inline position)
|
||
else collect (if (and (consp s-exp) (listp (cdr s-exp)))
|
||
(inject-inline-data-position s-exp position)
|
||
s-exp)))
|
||
|
||
(defun process-relative-pathnames (filename command)
|
||
"Walk the COMMAND to replace relative pathname with absolute ones, merging
|
||
them within the directory where we found the command FILENAME."
|
||
(loop
|
||
for s-exp in command
|
||
when (pathnamep s-exp)
|
||
collect (if (fad:pathname-relative-p s-exp)
|
||
(merge-pathnames s-exp (directory-namestring filename))
|
||
s-exp)
|
||
else
|
||
collect (if (and (consp s-exp) (listp (cdr s-exp)))
|
||
(process-relative-pathnames filename s-exp)
|
||
s-exp)))
|
||
|
||
(defun parse-commands-from-file (filename)
|
||
"The command could be using from :inline, in which case we want to parse
|
||
as much as possible then use the command against an already opened stream
|
||
where we moved at the beginning of the data."
|
||
(log-message :log "Parsing commands from file ~s~%" filename)
|
||
|
||
(process-relative-pathnames
|
||
filename
|
||
(let ((*data-expected-inline* nil)
|
||
(content (slurp-file-into-string filename)))
|
||
(multiple-value-bind (commands end-commands-position)
|
||
(parse 'commands content :junk-allowed t)
|
||
|
||
;; INLINE is only allowed where we have a single command in the file
|
||
(if *data-expected-inline*
|
||
(progn
|
||
(when (= 0 end-commands-position)
|
||
;; didn't find any command, leave error reporting to esrap
|
||
(parse 'commands content))
|
||
|
||
(when (and *data-expected-inline*
|
||
(null end-commands-position))
|
||
(error "Inline data not found in '~a'." filename))
|
||
|
||
(when (and *data-expected-inline* (not (= 1 (length commands))))
|
||
(error (concatenate 'string
|
||
"Too many commands found in '~a'.~%"
|
||
"To use inline data, use a single command.")
|
||
filename))
|
||
|
||
;; now we should have a single command and inline data after that
|
||
;; replace the (:inline nil) found in the first (and only) command
|
||
;; with a (:inline position) instead
|
||
(list
|
||
(inject-inline-data-position
|
||
(first commands) (cons filename end-commands-position))))
|
||
|
||
;; There was no INLINE magic found in the file, reparse it so that
|
||
;; normal error processing happen
|
||
(parse 'commands content))))))
|
||
|
||
(defun run-commands (source
|
||
&key
|
||
(start-logger t)
|
||
((:log-filename *log-filename*) *log-filename*)
|
||
((:log-min-messages *log-min-messages*) *log-min-messages*)
|
||
((:client-min-messages *client-min-messages*) *client-min-messages*))
|
||
"SOURCE can be a function, which is run, a list, which is compiled as CL
|
||
code then run, a pathname containing one or more commands that are parsed
|
||
then run, or a commands string that is then parsed and each command run."
|
||
|
||
(when start-logger
|
||
(start-logger :log-filename *log-filename*
|
||
:log-min-messages *log-min-messages*
|
||
:client-min-messages *client-min-messages*))
|
||
|
||
(let* ((funcs
|
||
(typecase source
|
||
(function (list source))
|
||
|
||
(list (list (compile nil source)))
|
||
|
||
(pathname (mapcar (lambda (expr) (compile nil expr))
|
||
(parse-commands-from-file source)))
|
||
|
||
(t (mapcar (lambda (expr) (compile nil expr))
|
||
(if (probe-file source)
|
||
(parse-commands-from-file source)
|
||
(parse-commands source)))))))
|
||
|
||
;; run the commands
|
||
(loop for func in funcs do (funcall func))
|
||
|
||
;; close the logger, only when we've been tasked with opening it.
|
||
(when start-logger
|
||
(stop-logger))))
|
||
|
||
|
||
;;;
|
||
;;; Interactive tool
|
||
;;;
|
||
(defmacro with-database-uri ((database-uri) &body body)
|
||
"Run the BODY forms with the connection parameters set to proper values
|
||
from the DATABASE-URI. For a MySQL connection string, that's
|
||
*myconn-user* and all, for a PostgreSQL connection string, *pgconn-user*
|
||
and all."
|
||
(destructuring-bind (&key type user password host port &allow-other-keys)
|
||
(parse 'db-connection-uri database-uri)
|
||
(ecase type
|
||
(:mysql
|
||
`(let* ((*myconn-host* ,host)
|
||
(*myconn-port* ,port)
|
||
(*myconn-user* ,user)
|
||
(*myconn-pass* ,password))
|
||
,@body))
|
||
(:postgresql
|
||
`(let* ((*pgconn-host* ,(if (consp host) (list 'quote host) host))
|
||
(*pgconn-port* ,port)
|
||
(*pgconn-user* ,user)
|
||
(*pgconn-pass* ,password))
|
||
,@body)))))
|
||
|
||
|
||
;;;
|
||
;;; Some testing
|
||
;;;
|
||
(defun test-parsing (&rest tests)
|
||
"Try parsing the command(s) from the file test/TEST.load"
|
||
(let* ((tdir (directory-namestring
|
||
(asdf:system-relative-pathname :pgloader "test/")))
|
||
(tests (or (remove-if #'null tests) (fad:list-directory tdir))))
|
||
(loop
|
||
for test in tests
|
||
for filename =
|
||
(if (fad:pathname-relative-p test)
|
||
(make-pathname :directory tdir :name test :type "load")
|
||
test)
|
||
collect
|
||
(cons filename
|
||
(ignore-errors
|
||
(parse-commands (slurp-file-into-string filename)))))))
|
||
|
||
(defun list-failing-tests (&rest tests)
|
||
"Return the list of test files we can't parse."
|
||
(loop for (name . code) in (test-parsing tests) unless code collect name))
|
||
|
||
|