diff of 68ce4db4d35fe3e28ccebeb9850c005a199752b0
68ce4db4d35fe3e28ccebeb9850c005a199752b0
diff --git a/.github/workflows/build_murja.yml b/.github/workflows/build_murja.yml
new file mode 100644
index 0000000..9d1af2b
--- /dev/null
+++ b/.github/workflows/build_murja.yml
@@ -0,0 +1,112 @@
+on:
+ push:
+ branches: [main]
+
+
+env:
+ REGISTRY: ghcr.io
+ IMAGE_NAME: aggressive-murja
+
+jobs:
+ build:
+ name: "Build murja image"
+ runs-on: 'ubuntu-latest'
+ permissions:
+ contents: read
+ packages: write
+ steps:
+ - uses: actions/checkout@v2
+ name: Checkout code
+
+ - name: Install tools
+ run: sudo apt-get install npm uglifyjs -q -y
+
+ - name: Install elm
+ run: npm install -g elm
+
+ - name: Install quicklisp
+ run: |
+ curl https://beta.quicklisp.org/quicklisp.lisp -o ./quicklisp.lisp
+
+ - name: Build murja
+ run: |
+ cd elm-frontti
+ elm make src/Main.elm --output murja.js
+ uglifyjs murja.js --compress 'pure_funcs="F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9",pure_getters,keep_fargs=false,unsafe_comps,unsafe' | uglifyjs --mangle > murja.min.js
+ cd ../
+ mv elm-frontti/murja.min.js resources/js/murja.js
+
+ - name: Log in to the Container registry
+ uses: docker/login-action@v2
+ with:
+ registry: ${{ env.REGISTRY }}
+ username: ${{ github.actor }}
+ password: ${{ secrets.GITHUB_TOKEN }}
+
+ - name: Extract metadata (tags, labels) for Docker
+ id: meta
+ uses: docker/metadata-action@v4
+ with:
+ images: ${{ env.REGISTRY }}/${{ env.IMAGE_NAME }}
+
+ - name: Build and push Docker image
+ uses: docker/build-push-action@v4
+ with:
+ context: .
+ push: true
+ tags: |
+ ghcr.io/feuery/murja:latest
+ ghcr.io/feuery/murja:${{ github.sha }}
+ labels: ${{ steps.meta.outputs.labels }}
+
+ test-playwright:
+ name: Runs playwright browserr tests
+ needs: build
+ runs-on: ubuntu-latest
+ permissions:
+ contents: read
+ packages: read
+
+ steps:
+ - uses: actions/checkout@v2
+ name: Checkout code
+
+ - name: Start the database
+ run: |
+ docker-compose up -d
+
+ - name: Start murja
+ id: tests
+ uses: addnab/docker-run-action@v3
+ with:
+ image: ghcr.io/feuery/murja:latest
+ options: -v ${{ github.workspace }}:/workspace -v ${{ github.workspace }}/config:/etc/murja -e MURJA_DB_HOST=db -e MURJA_E2E=e2e -p 3010:3010 --network aggressive-murja_murja_test_network
+ run: |
+ set -eux
+
+ (./murja_server 2>&1 | grep -vi Firefox)&
+
+ cd /workspace
+
+ apt-get -qq install curl npm
+ curl -v http://localhost:3010
+
+ npm install -g n
+ n lts
+
+ hash -r
+ npm install -g npm
+
+ cd playwright-tests
+ npm ci
+ npx playwright install --with-deps
+ npx playwright test --reporter=line
+ find . -name '*.webm'
+
+ - uses: actions/upload-artifact@v3
+ if: always() && steps.tests.outcome == 'failure'
+ with:
+ name: playwright-report
+ path: ${{ github.workspace }}/playwright-tests/test-results
+ if-no-files-found: error
+ retention-days: 30
diff --git a/Dockerfile b/Dockerfile
new file mode 100644
index 0000000..c839720
--- /dev/null
+++ b/Dockerfile
@@ -0,0 +1,8 @@
+FROM ubuntu:latest
+COPY . /src
+RUN cd /src; \
+ ls -la . ; \
+ ./build_murja.sh \
+ cd ..
+
+CMD ["/murja_server"]
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 1c5f099..0ab224d 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -23,7 +23,9 @@
:components
((:module "local-lib"
:components ((:file "lisp-fixup")
- (:file "halisql")))
+ (:file "halisql")
+ (:file "migrations")))
+ (:file "migration-list")
(:module "users"
:components ((:file "user-db")))
(:module "middleware"
diff --git a/build_murja.lisp b/build_murja.lisp
new file mode 100644
index 0000000..e45a8c4
--- /dev/null
+++ b/build_murja.lisp
@@ -0,0 +1,5 @@
+(ql:quickload :aggressive-murja)
+(save-lisp-and-die "murja_server"
+ :toplevel (lambda ()
+ (murja:main))
+ :executable t)
diff --git a/build_murja.sh b/build_murja.sh
new file mode 100755
index 0000000..d64e44c
--- /dev/null
+++ b/build_murja.sh
@@ -0,0 +1,31 @@
+#!/bin/env bash
+set -euo pipefail
+
+apt-get update
+apt-get install sbcl curl libssl-dev -q -y
+
+curl https://beta.quicklisp.org/quicklisp.lisp -o ~/quicklisp.lisp
+sbcl --load ~/quicklisp.lisp --load ./install_ql.lisp
+
+current_dir=$(pwd)
+
+mkdir ~/common-lisp
+pushd ~/common-lisp
+ln -s $current_dir
+popd
+
+
+if [ ! -d ~/common-lisp ]; then
+ current_dir=$(pwd)
+
+ mkdir ~/common-lisp
+ pushd ~/common-lisp
+ ln -s $current_dir
+ popd
+fi
+
+sbcl --load ./build_murja.lisp
+
+mv murja_server ..
+
+apt-get remove sbcl -q -y
diff --git a/docker-compose.yml b/docker-compose.yml
new file mode 100644
index 0000000..c63da42
--- /dev/null
+++ b/docker-compose.yml
@@ -0,0 +1,15 @@
+services:
+ db:
+ image: postgres:latest
+ ports:
+ - 5432:5432
+ environment:
+ POSTGRES_USER: blogadmin
+ POSTGRES_PASSWORD: blog
+ POSTGRES_DB: blogdb
+ POSTGRES_INITDB_ARGS: '--locale en_US.UTF-8'
+ networks:
+ - murja_test_network
+
+networks:
+ murja_test_network:
diff --git a/install_ql.lisp b/install_ql.lisp
new file mode 100644
index 0000000..07e167d
--- /dev/null
+++ b/install_ql.lisp
@@ -0,0 +1,3 @@
+(quicklisp-quickstart:install)
+(ql-util:without-prompting
+ (ql:add-to-init-file))
diff --git a/playwright-tests/tests/basic-tests.spec.ts b/playwright-tests/tests/basic-tests.spec.ts
index 500e8aa..8ccbe84 100644
--- a/playwright-tests/tests/basic-tests.spec.ts
+++ b/playwright-tests/tests/basic-tests.spec.ts
@@ -121,7 +121,8 @@ test('basic testing', async ({ page, browser }) => {
await expect(page.locator('.tag')).toHaveText(tag);
// edit the post
- for(let x = 0; x < 10; x++) {
+ for(let x = 0; x < 10; x++) {
+ console.log('x: ' + x);
await page.getByTestId('edit-post-btn').click();
await expect(page.getByTestId('article-id')).not.toContainText('Article: No id');
diff --git a/resources/sql/001-users.up.sql b/resources/sql/001-users.up.sql
new file mode 100644
index 0000000..8c0f25b
--- /dev/null
+++ b/resources/sql/001-users.up.sql
@@ -0,0 +1,9 @@
+CREATE SCHEMA blog;
+
+CREATE TABLE blog.Users (
+ ID SERIAL,
+ Username VARCHAR(100) NOT NULL UNIQUE,
+ Password CHAR(128) NOT NULL, --SHA-512
+ Nickname VARCHAR(1000) NOT NULL DEFAULT '',
+ Img_location VARCHAR(2000),
+ PRIMARY KEY(ID));
diff --git a/resources/sql/002-posts.up.sql b/resources/sql/002-posts.up.sql
new file mode 100644
index 0000000..0cdc919
--- /dev/null
+++ b/resources/sql/002-posts.up.sql
@@ -0,0 +1,12 @@
+CREATE TABLE blog.Post
+(
+ ID SERIAL,
+ Title VARCHAR(1000) NOT NULL DEFAULT 'Untitled',
+ Content TEXT NOT NULL DEFAULT '',
+ creator_id INT NOT NULL,
+ tags JSONB NOT NULL DEFAULT '[]'::jsonb,
+ PRIMARY KEY(ID),
+ FOREIGN KEY(creator_id) REFERENCES blog.users(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE
+)
diff --git a/resources/sql/003-comments.up.sql b/resources/sql/003-comments.up.sql
new file mode 100644
index 0000000..f6a9671
--- /dev/null
+++ b/resources/sql/003-comments.up.sql
@@ -0,0 +1,19 @@
+CREATE TABLE blog.Comment
+(
+ ID SERIAL,
+ parent_post_id INT NOT NULL,
+ parent_comment_id INT NULL,
+ Content TEXT NOT NULL DEFAULT '',
+ creator_id INT NOT NULL,
+ created_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,
+ PRIMARY KEY(ID),
+ FOREIGN KEY(creator_id) REFERENCES blog.users(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE,
+ FOREIGN KEY(parent_post_id) REFERENCES blog.Post(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE,
+ FOREIGN KEY(parent_comment_id) REFERENCES blog.Comment(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE
+)
diff --git a/resources/sql/004-fixing-posts.up.sql b/resources/sql/004-fixing-posts.up.sql
new file mode 100644
index 0000000..dc34ae4
--- /dev/null
+++ b/resources/sql/004-fixing-posts.up.sql
@@ -0,0 +1,2 @@
+ALTER TABLE blog.Post
+ADD created_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP;
diff --git a/resources/sql/005-user-groups.up.sql b/resources/sql/005-user-groups.up.sql
new file mode 100644
index 0000000..ef02076
--- /dev/null
+++ b/resources/sql/005-user-groups.up.sql
@@ -0,0 +1,21 @@
+CREATE TABLE IF NOT EXISTS blog.UserGroup (
+ ID SERIAL,
+ Name VARCHAR NOT NULL UNIQUE,
+ Description VARCHAR(2000) NOT NULL DEFAULT '',
+ Img_location VARCHAR(2000) NOT NULL DEFAULT '',
+ PRIMARY KEY (ID));
+
+INSERT INTO blog.UserGroup(Name, Description) VALUES ('Admins', 'Group for admins');
+INSERT INTO blog.UserGroup(Name, Description) VALUES ('Users', 'Group for ordinary mortals');
+
+CREATE TABLE IF NOT EXISTS blog.GroupMapping (
+ UserID INT NOT NULL,
+ GroupID INT NOT NULL,
+ PrimaryGroup BOOL NOT NULL DEFAULT FALSE, -- I don't think it's possible to enforce only one PrimaryGroup per user in the DML?
+ PRIMARY KEY(UserID, GroupID),
+ FOREIGN KEY(UserID) REFERENCES blog.Users(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE,
+ FOREIGN KEY(GroupID) REFERENCES blog.UserGroup(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE);
diff --git a/resources/sql/006-permission-table.up.sql b/resources/sql/006-permission-table.up.sql
new file mode 100644
index 0000000..49e24dd
--- /dev/null
+++ b/resources/sql/006-permission-table.up.sql
@@ -0,0 +1,30 @@
+-- This is quickly spiralling to an endless abyss of shit
+CREATE TABLE blog.Permission (
+ ID SERIAL,
+ action varchar(2000),
+ PRIMARY KEY (ID));
+
+INSERT INTO blog.Permission(action) VALUES('create-page');
+INSERT INTO blog.Permission(action) VALUES('create-post');
+INSERT INTO blog.Permission(action) VALUES('create-comment');
+
+CREATE TABLE blog.GroupPermissions (
+ PermissionID INT,
+ GroupID INT,
+
+ PRIMARY KEY(PermissionID, GroupID),
+ FOREIGN KEY(PermissionID) REFERENCES blog.Permission(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE,
+ FOREIGN KEY(GroupID) REFERENCES blog.UserGroup(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE);
+
+-- The default sql accent PGSQL speaks is a bit braindead and I can't query the UserGroup table to get the exact id of admin group
+-- 1 == admins' id
+INSERT INTO blog.GroupPermissions VALUES(1, 1);
+INSERT INTO blog.GroupPermissions VALUES(2, 1);
+INSERT INTO blog.GroupPermissions VALUES(3, 1);
+
+-- 2 == users' id
+INSERT INTO blog.GroupPermissions VALUES(3, 2);
diff --git a/resources/sql/007-can-meta.up.sql b/resources/sql/007-can-meta.up.sql
new file mode 100644
index 0000000..c6bde90
--- /dev/null
+++ b/resources/sql/007-can-meta.up.sql
@@ -0,0 +1,11 @@
+INSERT INTO blog.Permission(ID, action) VALUES(4, 'delete-post');
+INSERT INTO blog.Permission(ID, action) VALUES(5, 'edit-post');
+INSERT INTO blog.Permission(ID, action) VALUES(6, 'comment-post');
+INSERT INTO blog.Permission(ID, action) VALUES(7, 'edit-comment');
+INSERT INTO blog.Permission(ID, action) VALUES(8, 'delete-comment');
+INSERT INTO blog.GroupPermissions VALUES(4, 1);
+INSERT INTO blog.GroupPermissions VALUES(5, 1);
+INSERT INTO blog.GroupPermissions VALUES(6, 1);
+INSERT INTO blog.GroupPermissions VALUES(7, 1);
+INSERT INTO blog.GroupPermissions VALUES(8, 1);
+
diff --git a/resources/sql/008-users-can-edit-self.up.sql b/resources/sql/008-users-can-edit-self.up.sql
new file mode 100644
index 0000000..0f90b40
--- /dev/null
+++ b/resources/sql/008-users-can-edit-self.up.sql
@@ -0,0 +1,11 @@
+-- Of course anyone can edit themselves
+-- Which means these permissions are kind of unnecessary atm
+INSERT INTO blog.Permission(ID, action) VALUES(9, 'delete-user');
+INSERT INTO blog.Permission(ID, action) VALUES(10, 'edit-user');
+INSERT INTO blog.Permission(ID, action) VALUES(11, 'edit-self');
+
+INSERT INTO blog.GroupPermissions VALUES(9, 1);
+INSERT INTO blog.GroupPermissions VALUES(10, 1);
+INSERT INTO blog.GroupPermissions VALUES(11, 1);
+
+INSERT INTO blog.GroupPermissions VALUES(11, 2);
diff --git a/resources/sql/009-users-can-comment.up.sql b/resources/sql/009-users-can-comment.up.sql
new file mode 100644
index 0000000..caa619d
--- /dev/null
+++ b/resources/sql/009-users-can-comment.up.sql
@@ -0,0 +1 @@
+INSERT INTO blog.GroupPermissions VALUES(6, 2);
diff --git a/resources/sql/010-can-import.up.sql b/resources/sql/010-can-import.up.sql
new file mode 100644
index 0000000..47924a9
--- /dev/null
+++ b/resources/sql/010-can-import.up.sql
@@ -0,0 +1,3 @@
+INSERT INTO blog.Permission(ID, action) VALUES(12, 'can-import');
+
+INSERT INTO blog.GroupPermissions VALUES(12, 1);
diff --git a/resources/sql/011-versioned-posts.up.sql b/resources/sql/011-versioned-posts.up.sql
new file mode 100644
index 0000000..5af17ce
--- /dev/null
+++ b/resources/sql/011-versioned-posts.up.sql
@@ -0,0 +1,15 @@
+CREATE TABLE blog.Post_History (
+ ID SERIAL,
+ Title VARCHAR(1000) NOT NULL DEFAULT 'Untitled',
+ Content TEXT NOT NULL DEFAULT '',
+ creator_id INT NOT NULL,
+ tags JSONB NOT NULL DEFAULT '[]'::jsonb,
+ created_at TIMESTAMP NOT NULL,
+ version INT NOT NULL DEFAULT 1,
+ PRIMARY KEY(ID, version),
+ FOREIGN KEY(creator_id) REFERENCES blog.users(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE,
+ FOREIGN KEY(ID) REFERENCES blog.Post(ID)
+ ON UPDATE CASCADE
+ ON DELETE CASCADE);
diff --git a/resources/sql/012-version-triggers.up.sql b/resources/sql/012-version-triggers.up.sql
new file mode 100644
index 0000000..341341c
--- /dev/null
+++ b/resources/sql/012-version-triggers.up.sql
@@ -0,0 +1,25 @@
+CREATE OR REPLACE FUNCTION push_to_history()
+RETURNS TRIGGER
+LANGUAGE plpgsql
+AS
+$$
+DECLARE local_version INT;
+BEGIN
+ SELECT coalesce(MAX(ph.version), 0) + 1 INTO local_version
+ FROM blog.Post p
+ LEFT JOIN blog.Post_History ph ON p.ID = ph.ID
+ WHERE p.id = OLD.id
+ GROUP BY p.ID;
+
+ INSERT INTO blog.Post_History(ID, Title, Content, creator_id, tags, created_at, version)
+ VALUES (OLD.ID, OLD.Title, OLD.Content, OLD.creator_id, OLD.tags, OLD.created_at, local_version);
+
+ RETURN NEW;
+END;
+$$;
+
+CREATE TRIGGER history_pushing
+BEFORE UPDATE
+ON blog.Post
+FOR EACH ROW
+EXECUTE PROCEDURE push_to_history();
diff --git a/resources/sql/013-media-table.up.sql b/resources/sql/013-media-table.up.sql
new file mode 100644
index 0000000..8cfc4b2
--- /dev/null
+++ b/resources/sql/013-media-table.up.sql
@@ -0,0 +1,4 @@
+CREATE TABLE blog.media (
+ id uuid DEFAULT gen_random_uuid(),
+ name text NOT NULL,
+ data bytea NOT null)
diff --git a/resources/sql/014-tag-hidden-unlisted-validator.up.sql b/resources/sql/014-tag-hidden-unlisted-validator.up.sql
new file mode 100644
index 0000000..b30243a
--- /dev/null
+++ b/resources/sql/014-tag-hidden-unlisted-validator.up.sql
@@ -0,0 +1,3 @@
+ALTER TABLE blog.post ADD CONSTRAINT not_hidden_and_unlisted CHECK ((tags ?? 'hidden' AND NOT tags ?? 'unlisted') OR
+ (NOT tags ?? 'hidden' AND tags ?? 'unlisted') OR
+ (NOT tags ?? 'hidden' AND NOT tags ?? 'unlisted'))
diff --git a/resources/sql/015-image-post-pairing-view.up.sql b/resources/sql/015-image-post-pairing-view.up.sql
new file mode 100644
index 0000000..2c46490
--- /dev/null
+++ b/resources/sql/015-image-post-pairing-view.up.sql
@@ -0,0 +1,8 @@
+create or replace view blog.media_post_pairing as
+select post.id as post_id,
+ post.title as post_title,
+ media.id as media_id,
+ media.name as media_name
+from blog.post post
+join blog.media media
+ on post.content ilike '%'||media.id||'%';
diff --git a/resources/sql/init-migration-tables.sql b/resources/sql/init-migration-tables.sql
new file mode 100644
index 0000000..7a5aa97
--- /dev/null
+++ b/resources/sql/init-migration-tables.sql
@@ -0,0 +1,16 @@
+CREATE TABLE IF NOT EXISTS public.migrations_tracker
+(
+ id varchar(255) NOT NULL PRIMARY KEY,
+ created_at timestamp NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS public.ragtime_migrations
+(
+ id varchar(255) NOT NULL PRIMARY KEY,
+ created_at varchar(32) NOT NULL
+);
+
+INSERT INTO public.migrations_tracker
+SELECT id, created_at::timestamp
+FROM public.ragtime_migrations
+WHERE id NOT IN (SELECT id FROM public.migrations_tracker);
diff --git a/resources/sql/migration-helper-queries.sql b/resources/sql/migration-helper-queries.sql
new file mode 100644
index 0000000..f1f7987
--- /dev/null
+++ b/resources/sql/migration-helper-queries.sql
@@ -0,0 +1,17 @@
+-- name: migration-exists
+-- returns: :array-hash
+
+SELECT COUNT(*) as "count"
+FROM public.migrations_tracker
+WHERE id = $1;
+
+-- name: migration-table-exists*
+-- returns: :array-hash
+
+SELECT EXISTS (
+ SELECT FROM information_schema.tables
+ WHERE table_schema = 'public'
+ AND table_name = 'migrations_tracker');
+
+-- name: mark-migration-done @execute
+INSERT INTO public.migrations_tracker VALUES ($1, NOW());
diff --git a/src/local-lib/halisql.lisp b/src/local-lib/halisql.lisp
index 5b104ae..e11eb76 100644
--- a/src/local-lib/halisql.lisp
+++ b/src/local-lib/halisql.lisp
@@ -1,7 +1,7 @@
(defpackage halisql
(:use :cl :binding-arrows)
(:import-from :lisp-fixup :slurp-utf-8 :drop :partial :compose)
- (:export :*log* :defqueries :*system-name*))
+ (:export :get-sql :*log* :pick-queries :defqueries :*system-name*))
(in-package :halisql)
@@ -68,16 +68,19 @@
(apply #'max params )
0)))
+(defun pick-queries (file-path)
+ (->> (uiop:split-string
+ (slurp-sql file-path)
+ :separator '(#\;))
+ (mapcar (lambda (fn)
+ (uiop:split-string fn :separator '(#\Newline))))
+ (remove-if (lambda (query)
+ (every (partial #'string= "") query)))))
+
(defparameter *log* nil)
(defmacro defqueries (file-path)
- (let ((queries (->> (uiop:split-string
- (slurp-sql file-path)
- :separator '(#\;))
- (mapcar (lambda (fn)
- (uiop:split-string fn :separator '(#\Newline))))
- (remove-if (lambda (query)
- (every (partial #'string= "") query))))))
+ (let ((queries (pick-queries file-path)))
`(progn
,@(->> queries
(mapcar (lambda (query)
diff --git a/src/local-lib/migrations.lisp b/src/local-lib/migrations.lisp
new file mode 100644
index 0000000..88962be
--- /dev/null
+++ b/src/local-lib/migrations.lisp
@@ -0,0 +1,58 @@
+(defpackage murja.migrations
+ (:use :halisql)
+ (:use :cl)
+ (:export :defmigration :migrate))
+
+(in-package :murja.migrations)
+
+(defparameter *migrations* nil)
+
+(defqueries "migration-helper-queries")
+
+(defun migration-does-exist (name)
+ (> (gethash "count"
+ (aref
+ (migration-exists name) 0))
+ 0))
+
+(defun migration-table-exists ()
+ (gethash "exists" (aref (migration-table-exists*) 0)))
+
+
+(defun defmigration (path &key initial)
+ (let* ((queries (pick-queries path))
+ ;; ragtime legacy, migration filenames are named .up.sql but they were saved into the public.ragtime_migrations without the .up.sql postfix
+ ;; and murja.migrations/halisql system drops the .sql extension, but halisql functions don't handle the .up. string correctly
+ (path (str:replace-all ".up" "" path))
+ (sql-statements (mapcar #'get-sql queries))
+ (a-loop (lambda ()
+ (dolist (sql sql-statements)
+ (postmodern:execute sql))
+ (mark-migration-done path)))
+ (fn (lambda ()
+ (cond ((and initial (not (migration-table-exists)))
+ (funcall a-loop))
+
+ ((and (migration-table-exists) (not (migration-does-exist path)))
+ (funcall a-loop))
+
+ (t (log:info "Didn't run ~a" path)))))
+ (found-migration? nil))
+ (dolist (mig *migrations*)
+ (when (string= (first mig) path)
+ (setf (cdr mig) fn)
+ (setf found-migration? t)
+ (return)))
+
+ (unless found-migration?
+ (push (cons path fn) *migrations*))))
+
+(defun migrate ()
+ (postmodern:with-transaction ()
+ (dolist (mig (reverse *migrations*))
+ (log:info "Running ~a" (car mig))
+ (funcall (cdr mig)))))
+
+(defmigration "init-migration-tables" :initial t)
+
+;; (migrate)
diff --git a/src/main.lisp b/src/main.lisp
index d9c88d3..14a1795 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -1,6 +1,9 @@
(defpackage murja
(:use :cl)
- (:import-from :murja.posts.post-db))
+ (:import-from :murja.posts.post-db)
+ (:import-from :murja.middleware.db :with-db)
+ (:import-from :murja.migrations :migrate)
+ (:export :main :start-server))
(in-package :murja)
@@ -9,6 +12,8 @@
(defun start-server (&key (port 3010))
(format t "Starting murja server~%")
+ (with-db
+ (migrate))
(let ((server (make-instance 'easy-routes:easy-routes-acceptor :port port)))
(when (equalp 3010 port)
(setf *server* server))
@@ -16,4 +21,10 @@
(format t "Started murja server on ~a ~%" port)
server))
-(start-server :port 3010)
+(defun main (&key (port 3010))
+ (start-server :port port)
+ (handler-case
+ (loop do (sleep 1000))
+ (condition () nil)))
+
+;; (start-server :port 3010)
diff --git a/src/middleware/db.lisp b/src/middleware/db.lisp
index b293152..694a1cf 100644
--- a/src/middleware/db.lisp
+++ b/src/middleware/db.lisp
@@ -1,5 +1,6 @@
(defpackage murja.middleware.db
- (:use :cl :postmodern))
+ (:use :cl :postmodern)
+ (:export :connect-murjadb-toplevel))
(in-package :murja.middleware.db)
@@ -17,20 +18,29 @@
(parse-integer port-str)
5432))))
-(defun @transaction (next)
+(defun connect-murjadb-toplevel ()
(destructuring-bind (&key db username password host port) (db-config)
- (handler-bind ((cl-postgres:database-socket-error
+ (postmodern:connect-toplevel db username password host :port port)))
+
+;; (connect-murjadb-toplevel)
+
+(defmacro with-db (&rest body)
+ `(destructuring-bind (&key db username password host port) (db-config)
+ (format t "Connecting to db ~a ~%" (list db username "$password" host :port port))
+ (with-connection (list db username password host :port port)
+ ,@body)))
+
+(defun @transaction (next)
+ (with-db
+ (handler-bind ((cl-postgres:database-socket-error
(lambda (c)
(format t "Socket error from db: ~a~%" c)
(setf (hunchentoot:return-code*) 500)
- (return-from @transaction "Internal Server Error"))))
- (with-connection (list db username password host :port port)
-
- (with-schema (:blog :if-not-exist nil)
- (handler-bind ((cl-postgres:database-error
- (lambda (c)
- (format t "Error from db: ~a~%" c)
- (setf (hunchentoot:return-code*) 500)
- (return-from @transaction "Internal Server Error"))))
- (with-transaction ()
- (funcall next))))))))
+ (return-from @transaction "Internal Server Error")))
+ (cl-postgres:database-error
+ (lambda (c)
+ (format t "Error from db: ~a~%" c)
+ (setf (hunchentoot:return-code*) 500)
+ (return-from @transaction "Internal Server Error"))))
+ (with-transaction ()
+ (funcall next)))))
diff --git a/src/migration-list.lisp b/src/migration-list.lisp
new file mode 100644
index 0000000..8c20fbd
--- /dev/null
+++ b/src/migration-list.lisp
@@ -0,0 +1,23 @@
+(defpackage murja.migration-list
+ (:use :cl)
+ (:import-from :murja.migrations :defmigration))
+
+(in-package :murja.migration-list)
+
+(defmigration "001-users.up")
+(defmigration "002-posts.up")
+(defmigration "003-comments.up")
+(defmigration "004-fixing-posts.up")
+(defmigration "005-user-groups.up")
+(defmigration "006-permission-table.up")
+(defmigration "007-can-meta.up")
+(defmigration "008-users-can-edit-self.up")
+(defmigration "009-users-can-comment.up")
+(defmigration "010-can-import.up")
+(defmigration "011-versioned-posts.up")
+(defmigration "012-version-triggers.up")
+(defmigration "013-media-table.up")
+(defmigration "014-tag-hidden-unlisted-validator.up")
+(defmigration "015-image-post-pairing-view.up")
+
+;; (murja.migrations:migrate)