Initial commit of cl-deck-builder2.
This commit is contained in:
Charlie Svitlik
commit
b1a375fb06
11
.gitignore
vendored
Normal file
11
.gitignore
vendored
Normal file
@ -0,0 +1,11 @@
|
||||
*.fasl
|
||||
*.dx32fsl
|
||||
*.dx64fsl
|
||||
*.lx32fsl
|
||||
*.lx64fsl
|
||||
*.x86f
|
||||
*~
|
||||
.#*
|
||||
*.sqlite
|
||||
*.sqlite3
|
||||
system-index.txt
|
||||
61
Dockerfile
Normal file
61
Dockerfile
Normal file
@ -0,0 +1,61 @@
|
||||
ARG TARGETARCH TARGETPLATFORM TARGETVARIANT
|
||||
FROM --platform=$TARGETPLATFORM docker.io/$TARGETARCH${TARGETVARIANT}/alpine:3.18.2
|
||||
|
||||
RUN addgroup -g 1000 quicklisp && adduser -D -G quicklisp -u 1000 quicklisp
|
||||
|
||||
RUN set -eux; \
|
||||
apk add --no-cache \
|
||||
cgit \
|
||||
curl \
|
||||
gcc \
|
||||
git \
|
||||
imagemagick \
|
||||
libev \
|
||||
make \
|
||||
musl-dev \
|
||||
py3-markdown \
|
||||
py3-pygments \
|
||||
python3 \
|
||||
sbcl \
|
||||
sqlite \
|
||||
sqlite-libs \
|
||||
texlive \
|
||||
texlive-xetex \
|
||||
texmf-dist-latexextra \
|
||||
zxing && \
|
||||
rm -rf /var/cache/apk/*
|
||||
|
||||
WORKDIR /home/quicklisp/
|
||||
|
||||
USER quicklisp
|
||||
|
||||
RUN curl -O https://beta.quicklisp.org/quicklisp.lisp
|
||||
RUN sbcl --noinform --no-userinit --no-sysinit --non-interactive \
|
||||
--load quicklisp.lisp --eval "(quicklisp-quickstart:install)" \
|
||||
--eval "(ql-util:without-prompting (ql:add-to-init-file))"
|
||||
|
||||
RUN sbcl --non-interactive \
|
||||
--eval "(ql:quickload '(:slynk :slynk/arglists :slynk/fancy-inspector :slynk/indentation :slynk/mrepl :slynk/profiler :slynk/trace-dialog))"
|
||||
|
||||
RUN sbcl --non-interactive \
|
||||
--eval "(ql:quickload '(:assoc-utils \
|
||||
:caveman2 :clack :clack-errors :datafly :djula :envy :hunchentoot :woo \
|
||||
:can :mito-auth :lack :lack-middleware-clack-errors :lack-middleware-csrf \
|
||||
:cl-csv :cl-json :cl-org-mode :cl-pass :dbd-sqlite3 :documentation-utils \
|
||||
:documentation-utils-extensions :lispqr :mito :mito-attachment :ratify \
|
||||
:sxql :trivial-download :verbose :websocket-driver :cl-markup :hermetic \
|
||||
:inferior-shell :psychiq :djula-gettext :gettext))"
|
||||
|
||||
RUN mkdir -p /home/quicklisp/public
|
||||
|
||||
COPY --chown=quicklisp:quicklisp . /home/quicklisp/quicklisp/local-projects/cl-deck-builder2/
|
||||
|
||||
RUN sbcl --non-interactive \
|
||||
--eval "(ql:register-local-projects)" \
|
||||
--eval "(ql:quickload :cl-deck-builder2)"
|
||||
|
||||
EXPOSE 4005 5005
|
||||
|
||||
VOLUME ["/home/quicklisp/public/"]
|
||||
|
||||
CMD ["sbcl", "--load", "/home/quicklisp/quicklisp/local-projects/cl-deck-builder2/preamble.lisp", "--eval", "(cl-deck-builder2:main)"]
|
||||
134
Makefile
Normal file
134
Makefile
Normal file
@ -0,0 +1,134 @@
|
||||
################################################################################
|
||||
# Target Host Architecture
|
||||
ARCH ?= x86_64
|
||||
|
||||
# docker / podman
|
||||
DOCKER ?= podman
|
||||
DOCKER_COMPOSE ?= podman-compose
|
||||
# Other programs
|
||||
LISP ?= sbcl
|
||||
RM ?= rm -f
|
||||
|
||||
################################################################################
|
||||
# Git Revision Info
|
||||
GIT_REV ?= $(shell git rev-parse master)
|
||||
# Influences the Docker Image Name
|
||||
IMAGE_NAME ?= cl-deck-builder2-$(GIT_REV)
|
||||
|
||||
# For bind to this external address for docker-run
|
||||
EXTERNAL_ADDR ?= 5005
|
||||
EXTERNAL_SLYNK_ADDR ?= 4005
|
||||
|
||||
# Platform passed to Dockerfile
|
||||
PLATFORM.x86_64 ?= linux/amd64
|
||||
PLATFORM.aarch64 ?= linux/arm64/v8
|
||||
PLATFORM ?= $(PLATFORM.$(ARCH))
|
||||
|
||||
################################################################################
|
||||
# Code Borrwed from openbookstore <https://gitlab.com/myopenbookstore/openbookstore>
|
||||
# List lisp files, unless they contains a #
|
||||
SRC += $(shell find src/ -name '*.lisp' -a ! -name '*#*')
|
||||
HTML += $(shell find templates/ -name '*.html' -a ! -name '*#*')
|
||||
DEPS += $(SRC) $(HTML) $(wildcard *.asd)
|
||||
|
||||
# list of supported locales
|
||||
LOCALES := en_US
|
||||
# Example of how the variable should look after adding a new locale:
|
||||
# LOCALES := en_US en_GB fr_FR es_ES
|
||||
|
||||
# list of .po files (computed from the LOCALES variable)
|
||||
PO_FILES := $(foreach locale,$(LOCALES),locale/$(locale)/LC_MESSAGES/cl-deck-builder2.po)
|
||||
# list of .mo files (computed from the LOCALES variable)
|
||||
MO_FILES := $(foreach locale,$(LOCALES),locale/$(locale)/LC_MESSAGES/cl-deck-builder2.mo)
|
||||
|
||||
################################################################################
|
||||
all:
|
||||
|
||||
docker-build: Dockerfile test
|
||||
$(DOCKER) buildx build --platform $(PLATFORM) -t $(IMAGE_NAME) .
|
||||
|
||||
docker-run:
|
||||
$(DOCKER) run --platform $(PLATFORM) \
|
||||
--rm -it -P -p $(EXTERNAL_SLYNK_ADDR):4005 -p $(EXTERNAL_ADDR):5005 \
|
||||
--userns=keep-id -v $(HOME)/public:/home/quicklisp/public:z $(IMAGE_NAME)
|
||||
|
||||
docker-clean:
|
||||
-$(DOCKER) image rm -f $(IMAGE_NAME)
|
||||
|
||||
clean-fasl:
|
||||
-find -name '*.fasl' | xargs $(RM) -fv
|
||||
|
||||
clean: clean-fasl
|
||||
-find -name '*~' | xargs $(RM) -fv
|
||||
$(RM) -rf bin/
|
||||
|
||||
# I use a feature flag, bc using djula:*recompile-templates-on-change*
|
||||
# requires to load Djula before our app, and it isn't exactly the same meaning.
|
||||
build-lisp-image: ${MO_FILES}
|
||||
$(LISP) --non-interactive \
|
||||
--eval '(ql:quickload "deploy")' \
|
||||
--load cl-deck-builder2.asd \
|
||||
--eval '(push :djula-binary *features*)' \
|
||||
--eval '(ql:quickload :cl-deck-builder2)' \
|
||||
--eval '(asdf:make :cl-deck-builder2)'
|
||||
|
||||
# This must use a custom-built SBCL with a special parameter,
|
||||
# see linux-packaging README.
|
||||
# I have it under ~/.local/bin/bin/sbcl
|
||||
build-package:
|
||||
$(LISP) --non-interactive \
|
||||
--load cl-deck-builder2.asd \
|
||||
--eval '(ql:quickload :cl-deck-builder2)' \
|
||||
--eval '(setf *debugger-hook* (lambda (c h) (declare (ignore h)) (format t "~A~%" c) (sb-ext:quit :unix-status -1)))' \
|
||||
--eval '(asdf:make :cl-deck-builder2)'
|
||||
|
||||
# build-gui:
|
||||
# $(LISP) --non-interactive \
|
||||
# --load cl-deck-builder2.asd \
|
||||
# --eval '(ql:quickload :bookshops/gui)' \
|
||||
# --eval '(asdf:make :bookshops/gui)'
|
||||
|
||||
test:
|
||||
$(LISP) --non-interactive \
|
||||
--load cl-deck-builder2.asd \
|
||||
--load cl-deck-builder2-test.asd \
|
||||
--eval "(ql:quickload '(:cl-deck-builder2 :cl-deck-builder2-test))" \
|
||||
--eval "(asdf:test-system :cl-deck-builder2)"
|
||||
|
||||
.PHONY: tr
|
||||
tr: ${MO_FILES}
|
||||
|
||||
PO_TEMPLATE_DIR := locale/templates/LC_MESSAGES
|
||||
PO_TEMPLATE := ${PO_TEMPLATE_DIR}/cl-deck-builder2.pot
|
||||
|
||||
# Rule to extract translatable strings from SRC
|
||||
${PO_TEMPLATE_DIR}/lisp.pot: $(SRC)
|
||||
mkdir -p $(@D)
|
||||
xgettext -k_ -kN_ --language=lisp -o $@ $^
|
||||
|
||||
# Rule to extract translatable strings from djula templates
|
||||
${PO_TEMPLATE_DIR}/djula.pot: $(HTML) src/i18n.lisp
|
||||
$(LISP) --non-interactive \
|
||||
--eval '(ql:quickload "deploy")' \
|
||||
--eval '(asdf:load-asd (truename "cl-deck-builder2.asd"))' \
|
||||
--eval '(push :djula-binary *features*)' \
|
||||
--eval '(ql:quickload :cl-deck-builder2)' \
|
||||
--eval '(cl-deck-builder2.i18n:update-djula.pot)'
|
||||
|
||||
# Rule to combine djula.pot and lisp.pot into cl-deck-builder2.pot
|
||||
${PO_TEMPLATE}: ${PO_TEMPLATE_DIR}/djula.pot ${PO_TEMPLATE_DIR}/lisp.pot
|
||||
msgcat --use-first $^ > $@
|
||||
|
||||
# Rule to generate or update the .po files from the .pot file
|
||||
locale/%/LC_MESSAGES/cl-deck-builder2.po: ${PO_TEMPLATE}
|
||||
mkdir -p $(@D)
|
||||
[ -f $@ ] || msginit --locale=$* \
|
||||
--no-translator \
|
||||
-i $< \
|
||||
-o $@ \
|
||||
&& msgmerge --update $@ $<
|
||||
|
||||
# Rule to create the .mo files from the .po files
|
||||
locale/%/LC_MESSAGES/cl-deck-builder2.mo: locale/%/LC_MESSAGES/cl-deck-builder2.po
|
||||
mkdir -p $(@D)
|
||||
msgfmt -o $@ $<
|
||||
172
README.md
Normal file
172
README.md
Normal file
@ -0,0 +1,172 @@
|
||||
# cl-deck-builder2
|
||||
|
||||
## About
|
||||
|
||||
This is a project to...
|
||||
|
||||
- Build TCG decks: "The Deck Builder"
|
||||
- Keep track of TCG inventory: "The Inventory Manager"
|
||||
- Support sale of TCG Inventory via "The Deck Builder"
|
||||
|
||||
It's a [Caveman2](https://github.com/fukamachi/caveman) web app, written in [Common Lisp](https://lisp-lang.org/).
|
||||
|
||||
The entire application may be built and run inside a [Docker](https://www.docker.com/) container.
|
||||
|
||||
You may access a live instance at [https://phntsm.ddns.net/](https://phntsm.ddns.net/).
|
||||
|
||||
## Usage
|
||||
|
||||
There are three components to this project. "The Inventory Manager",
|
||||
"The Deck Builder," and "The User Interface". The Deck Builder sources
|
||||
in-stock products from the Inventory Manager. When the Deck Builder
|
||||
constructs a Deck, it keeps a record of which cards are located in
|
||||
which decks. When a Deck is purchased, this information can be updated
|
||||
via a web interface. The User Interface is a convenient front-end.
|
||||
|
||||
The project may be used by loading a Docker image, loading the code
|
||||
directly into a Lisp sytem like [SBCL](http://sbcl.org/), or using a
|
||||
development environment like [Portacle](https://portacle.github.io/).
|
||||
|
||||
Once loaded, follow the code below to start the development
|
||||
environment, or, if you're using the Docker image, simply type:
|
||||
|
||||
```bash
|
||||
% make docker-build
|
||||
% make docker-run
|
||||
```
|
||||
|
||||
## Installation
|
||||
|
||||
First, set up [SBCL](http://sbcl.org/) and [Quicklisp](https://www.quicklisp.org/beta/).
|
||||
|
||||
If you're using [Portacle](https://portacle.github.io/), you should be all set already, just clone the repository.
|
||||
|
||||
Clone the master repository from
|
||||
[http://phntsm.ddns.net/git/cl-deck-builder.git/](http://phntsm.ddns.net/git/cl-deck-builder.git/):
|
||||
|
||||
```bash
|
||||
% cd ~/quicklisp/local-projects/
|
||||
git clone http://phntsm.ddns.net/git/cl-deck-builder.git/
|
||||
```
|
||||
|
||||
```lisp
|
||||
;; You may have to push whatever directory you're in to *LOCAL-PROJECT-DIRECTORIES*
|
||||
(push #P"~/code/cl-deck-builder2/" ql:*local-project-directories*)
|
||||
|
||||
;; Load cl-deck-builder2 and tests
|
||||
(ql:quickload '(:cl-deck-builder2 :cl-deck-builder2-test))
|
||||
|
||||
;; cl-deck-builder2.asd finds src/package.lisp which contains package
|
||||
;; definition - switch to this package for development.
|
||||
(in-package :cl-deck-builder2)
|
||||
|
||||
;; Start the server:
|
||||
;; in src/main.lisp we define a custom function, MY/START, that will
|
||||
;; INVOKE-RESTART if the server is already running.
|
||||
;;
|
||||
;; IPv4
|
||||
(my/start :address "0.0.0.0" :port 5001 :server :woo)
|
||||
;; IPv6
|
||||
(my/start :address "::" :port 5001 :server :woo)
|
||||
|
||||
;; For development session:
|
||||
(use-package '(:cl-deck-builder2.db
|
||||
:cl-deck-builder2.draw
|
||||
:cl-deck-builder2.models
|
||||
:cl-deck-builder2.toolkit
|
||||
:cl-deck-builder2-test))
|
||||
```
|
||||
|
||||
### Requirements
|
||||
|
||||
You'll need Quicklisp, and the dependencies listed in the ASDF System
|
||||
Definition file, as well as the following system libraries installed.
|
||||
|
||||
```bash
|
||||
# Install Software
|
||||
% apt install build-essential git jq sbcl
|
||||
% apt install nginx fcgiwrap libev-dev sqlite3 libsqlite3-dev collectd imagemagick ruby ruby-sidekiq
|
||||
|
||||
# For source code hosting
|
||||
% apt install cgit python3-pygments python3-markdown
|
||||
```
|
||||
|
||||
- [What is build-essential Ubuntu, how to install and use it?](https://linuxhint.com/install-build-essential-ubuntu/)
|
||||
- [git](https://git-scm.com/): Version Control
|
||||
- [jq](https://jqlang.github.io/jq/): Parsin JSON files on the command line
|
||||
- [SBCL](http://sbcl.org/): Lisp Implementation
|
||||
- [NGINX](https://www.nginx.com/): Web Server for HTTP, HTTPS, IPv4, IPv6, other services can be forwarded behind NGINX as well
|
||||
- [fcgiwrap](https://www.nginx.com/resources/wiki/start/topics/examples/fcgiwrap/): Simple FastCGI wrapper for CGI scripts (The project runs as a CGI script)
|
||||
- [libev](http://software.schmorp.de/pkg/libev.html): Event loop used by [woo](https://github.com/fukamachi/woo)
|
||||
- [sqlite3](https://www.sqlite.org/index.html): In-memory database store
|
||||
- [collectd](https://collectd.org/): collectd is a daemon which collects system and application performance metrics periodically and provides mechanisms to store the values in a variety of ways, for example in RRD files. This also nets us [RRDtool](https://oss.oetiker.ch/rrdtool/) which we can use for charts and graphs.
|
||||
- [ImageMagick](https://www.imagemagick.org/): We use this to generate deck images and other various image manipulations.
|
||||
- [Ruby](https://www.ruby-lang.org/en/): We use the [Sidekiq](https://sidekiq.org/) job scheduler, which is written in Ruby.
|
||||
|
||||
You may want to set up [cgit](https://git.zx2c4.com/cgit/) git web.
|
||||
|
||||
There is also a `Dockerfile` with a `Makefile`.
|
||||
|
||||
## Author
|
||||
|
||||
_Bubblegumdrop <staticsunn@gmail.com>_
|
||||
|
||||
## Copyright
|
||||
|
||||
Copyright (c) 2024 Bubblegumdrop
|
||||
|
||||
## License
|
||||
|
||||
GPLv3+
|
||||
|
||||
## Localization Workflow
|
||||
|
||||
`lisp.pot` contains the string to translate that were extracted from
|
||||
the `.lisp` files.
|
||||
|
||||
`djula.pot` contains the strings to transtlate that were extracted
|
||||
from the djula templates.
|
||||
|
||||
gettext is the default translation engine.
|
||||
|
||||
### Update Translations
|
||||
|
||||
To build the translations:
|
||||
|
||||
# Extract all {_ ... _} sequences from Djula templates
|
||||
make locale/templates/LC_MESSAGES/djula.pot
|
||||
|
||||
# Extract all (_ ... _) sequences from LISP code
|
||||
make locale/templates/LC_MESSAGES/lisp.pot
|
||||
|
||||
# Produce combined project template for translation
|
||||
make locale/templates/LC_MESSAGES/cl-deck-builder2.pot
|
||||
|
||||
... make your translation edits to cl-deck-builder2.pot ...
|
||||
|
||||
### Compile Translations
|
||||
|
||||
To Produce the `.mo` files, add your language to `LOCALES` in the
|
||||
`Makefile` then update the translations with the `tr` target:
|
||||
|
||||
LOCALES := en_US ja_JP
|
||||
|
||||
# Produce the translations
|
||||
make tr
|
||||
|
||||
The default `LANG` is currently `en_US` in `view.lisp`:
|
||||
|
||||
(defun render (template-path &optional env (lang "en_US"))
|
||||
"Use Djula to render a template."
|
||||
(let ((template (gethash template-path *template-registry*)))
|
||||
(unless template
|
||||
(setf template (djula:compile-template* (princ-to-string template-path)))
|
||||
(setf (gethash template-path *template-registry*) template))
|
||||
(with-locale (lang)
|
||||
(apply #'djula:render-template*
|
||||
template nil
|
||||
env))))
|
||||
|
||||
## TODO
|
||||
|
||||
See [todo.md](doc/todo.md)
|
||||
76
app.lisp
Normal file
76
app.lisp
Normal file
@ -0,0 +1,76 @@
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.app
|
||||
(:use #:cl)
|
||||
(:import-from #:mito-attachment
|
||||
#:*storage*
|
||||
#:s3-storage
|
||||
#:disk-storage
|
||||
#:disk-storage-mount-path)
|
||||
(:import-from #:lack.builder
|
||||
#:builder)
|
||||
(:import-from #:ppcre
|
||||
#:scan)
|
||||
(:import-from #:cl-deck-builder2.web
|
||||
#:*web*
|
||||
#:make-chat-server)
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:config
|
||||
#:productionp
|
||||
#:*public-directory*
|
||||
#:*static-directory*)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:git-revision)
|
||||
(:documentation "The package the app file executes in. Passed to ~CLACK:CLACKUP~ function."))
|
||||
|
||||
(in-package #:cl-deck-builder2.app)
|
||||
|
||||
(defparameter *git-revision* (git-revision))
|
||||
|
||||
(setf *storage*
|
||||
(if (productionp)
|
||||
;; Store files in AWS S3 for production environment
|
||||
(make-instance 's3-storage
|
||||
:bucket "mito-attachment-example"
|
||||
:endpoint "s3-ap-northeast-1.amazonaws.com"
|
||||
:access-key (uiop:getenv "AWS_ACCESS_KEY")
|
||||
:secret-key (uiop:getenv "AWS_SECRET_KEY"))
|
||||
;; Store files in local filesystem for development environment
|
||||
(make-instance 'disk-storage
|
||||
:bucket "mito-attachment-example"
|
||||
:directory (merge-pathnames "attachment" *public-directory*))))
|
||||
|
||||
(builder
|
||||
(:static
|
||||
:path (lambda (path)
|
||||
(if (ppcre:scan "^(?:/img/|/css/|/js/|/webfonts/|/robot\\.txt$|/favicon\\.(ico|png)|/manifest\\.json$)" path)
|
||||
path
|
||||
nil))
|
||||
:root *static-directory*)
|
||||
(:static
|
||||
:path "/public/"
|
||||
:root *public-directory*)
|
||||
(if (productionp)
|
||||
nil
|
||||
:accesslog)
|
||||
(if (getf (config) :error-log)
|
||||
`(:backtrace
|
||||
:output ,(getf (config) :error-log))
|
||||
nil)
|
||||
:session
|
||||
:csrf
|
||||
(when (typep *storage* 'disk-storage)
|
||||
`(:mount ,(disk-storage-mount-path *storage*) ,*storage*))
|
||||
(:clack-errors :debug t)
|
||||
(if (productionp)
|
||||
nil
|
||||
(lambda (app)
|
||||
(lambda (env)
|
||||
(let ((datafly:*trace-sql* t))
|
||||
(setf (getf djula:*default-template-arguments* :git-revision) *git-revision*
|
||||
(getf djula:*default-template-arguments* :server-name) "phntsm.ddns.net")
|
||||
(funcall app env)))))
|
||||
(:mount "/label-maker" cl-deck-builder2.web.label-maker:*web*)
|
||||
(:mount "/tinymce" cl-deck-builder2.web.tinymce:*web*)
|
||||
(:mount "/chat-server" #'cl-deck-builder2.web.sse:make-chat-server)
|
||||
*web*)
|
||||
11
cl-deck-builder2-test.asd
Normal file
11
cl-deck-builder2-test.asd
Normal file
@ -0,0 +1,11 @@
|
||||
(asdf:defsystem "cl-deck-builder2-test"
|
||||
:author "Bubblegumdrop"
|
||||
:license "Do Not Redistribute"
|
||||
:depends-on ("cl-deck-builder2"
|
||||
"rove")
|
||||
:components ((:module "tests"
|
||||
:components
|
||||
((:file "packages")
|
||||
(:file "cl-deck-builder2"))))
|
||||
:description "Test system for cl-deck-builder2"
|
||||
:perform (asdf:test-op (op c) (uiop:symbol-call :rove :run c)))
|
||||
250
cl-deck-builder2.asd
Normal file
250
cl-deck-builder2.asd
Normal file
@ -0,0 +1,250 @@
|
||||
;;;; cl-deck-builder2.asd
|
||||
;;;;
|
||||
;;;; ASDF System Definition File for "The Deck Builder" Common Lisp Project.
|
||||
;;;;
|
||||
;;;; You can read more about ASDF here:
|
||||
;;;; <https://lispcookbook.github.io/cl-cookbook/systems.html>
|
||||
;;;;
|
||||
|
||||
;; (require "asdf") ;; for CI
|
||||
|
||||
(pushnew :verbose-no-init *features*)
|
||||
|
||||
(asdf:defsystem "cl-deck-builder2"
|
||||
:version "0.4.0"
|
||||
:author "Bubblegumdrop"
|
||||
:license "Do Not Redistribute"
|
||||
:depends-on ("clack"
|
||||
"lack"
|
||||
"caveman2"
|
||||
"envy"
|
||||
"cl-ppcre"
|
||||
"uiop"
|
||||
|
||||
;; for @route annotation
|
||||
;; "cl-syntax-annot"
|
||||
|
||||
;; HTML Template
|
||||
"djula"
|
||||
"djula-gettext"
|
||||
"gettext"
|
||||
|
||||
;; for DB
|
||||
"mito"
|
||||
"mito-auth"
|
||||
"mito-attachment"
|
||||
"datafly"
|
||||
"sxql"
|
||||
"dbd-sqlite3"
|
||||
|
||||
;; for Models
|
||||
"assoc-utils" ; AGET is very handy
|
||||
"cl-csv" ; CSV import
|
||||
"cl-json" ; JSON import
|
||||
"local-time"
|
||||
"split-sequence"
|
||||
"can"
|
||||
|
||||
;; Documentation!
|
||||
;; "documentation-utils"
|
||||
;; "documentation-utils-extensions"
|
||||
"cl-org-mode"
|
||||
|
||||
;; More of Shinmeraa's code
|
||||
"ratify"
|
||||
"deploy"
|
||||
|
||||
;; QR Code Generator
|
||||
"lispqr"
|
||||
|
||||
;; Download stuff
|
||||
"trivial-download"
|
||||
|
||||
;; Error Handling
|
||||
"clack-errors"
|
||||
"lack-middleware-clack-errors"
|
||||
|
||||
;; Better logging
|
||||
"verbose"
|
||||
|
||||
;; WebSocket chat server backend
|
||||
"websocket-driver"
|
||||
"lack-middleware-csrf"
|
||||
|
||||
"cl-markup"
|
||||
"hermetic"
|
||||
|
||||
"inferior-shell"
|
||||
|
||||
;; Background job processing
|
||||
"psychiq"
|
||||
|
||||
"cl-fad"
|
||||
"slynk")
|
||||
:components ((:module "src"
|
||||
:components
|
||||
((:file "main" :depends-on ("config" "view" "db" "draw" "web"))
|
||||
(:file "config")
|
||||
(:file "db" :depends-on ("config" "toolkit"))
|
||||
(:file "view" :depends-on ("config" "i18n"))
|
||||
(:file "draw" :depends-on ("models"))
|
||||
(:file "i18n")
|
||||
(:module "toolkit"
|
||||
:components
|
||||
((:file "packages")
|
||||
(:file "paths")
|
||||
(:file "git")
|
||||
(:file "time")
|
||||
(:file "money")
|
||||
(:file "utils")))
|
||||
(:module "models"
|
||||
:components
|
||||
(;; (:file "toolkit")
|
||||
(:file "packages")
|
||||
;; (:file "model")
|
||||
(:file "registered-table-mixin")
|
||||
(:file "attachment")
|
||||
(:file "category")
|
||||
(:file "constructed-decks" :depends-on ("ydk" "ygoprodeck-classes" "ygoprodeck-methods" "ygoprodeck-fields"))
|
||||
(:file "crystal-commerce" :depends-on ("attachment" "ygoprodeck"))
|
||||
(:file "feedback" :depends-on ("user"))
|
||||
(:file "label-maker")
|
||||
(:file "qr-code")
|
||||
(:file "sqlite-schema")
|
||||
(:file "user")
|
||||
(:file "ydk" :depends-on ("ygoprodeck"))
|
||||
(:file "ygoprodeck")
|
||||
(:file "ygoprodeck-fields")
|
||||
(:file "ygoprodeck-classes" :depends-on ("ygoprodeck-fields"))
|
||||
(:file "ygoprodeck-methods")
|
||||
(:file "ygoprodeck-cardinfo")
|
||||
(:file "ygoprodeck-json"))
|
||||
:depends-on ("db" "toolkit"))
|
||||
(:module "web"
|
||||
:components
|
||||
((:file "packages")
|
||||
(:file "setup")
|
||||
(:file "flash-message")
|
||||
(:file "params")
|
||||
(:file "query")
|
||||
(:file "toolkit")
|
||||
(:file "index")
|
||||
(:file "builder" :depends-on ("search"))
|
||||
(:file "cards")
|
||||
(:file "constructed-decks")
|
||||
(:file "category")
|
||||
(:file "contact")
|
||||
(:file "decks")
|
||||
(:file "inventory" :depends-on ("search"))
|
||||
(:file "qr")
|
||||
(:file "search")
|
||||
(:file "sse")
|
||||
(:file "upload")
|
||||
(:file "user")
|
||||
(:file "ydk")
|
||||
(:file "label-maker" :depends-on ("query"))
|
||||
(:file "tinymce"))
|
||||
:depends-on ("db" "i18n" "view" "models" "draw" "toolkit"))))
|
||||
;; TODO seeing this all here makes me want to really compress this.
|
||||
(:module "templates"
|
||||
:components
|
||||
;; Order is important: the ones that extend default.html
|
||||
;; must be declared after it, because we compile all of them
|
||||
;; at build time.
|
||||
((:STATIC-FILE "ydk/index.html") (:STATIC-FILE "user/user-menu-bar.html")
|
||||
(:STATIC-FILE "user/user-list.html") (:STATIC-FILE "user/register.html")
|
||||
(:STATIC-FILE "user/login.html") (:STATIC-FILE "user/index.html")
|
||||
(:STATIC-FILE "user/admin.html") (:STATIC-FILE "upload.html")
|
||||
(:STATIC-FILE "template.Dockerfile") (:STATIC-FILE "tabs.html")
|
||||
(:STATIC-FILE "qr.html") (:STATIC-FILE "pages.html")
|
||||
(:STATIC-FILE "news.html") (:STATIC-FILE "navbar.html")
|
||||
(:STATIC-FILE "navbar-js.html") (:STATIC-FILE "messages.html")
|
||||
(:STATIC-FILE "markdown.html") (:STATIC-FILE "layouts/minimal.html")
|
||||
(:STATIC-FILE "layouts/html-head.html") (:STATIC-FILE "layouts/default.html")
|
||||
(:STATIC-FILE "latex/default.tpl.tex")
|
||||
(:STATIC-FILE "latex/ULINE-S-20247.tpl.tex")
|
||||
(:STATIC-FILE "latex/ULINE-S-20247.tex")
|
||||
(:STATIC-FILE "latex/Avery-5160.tpl.tex")
|
||||
(:STATIC-FILE "latex/Avery-5160.tex") (:STATIC-FILE "label-maker.html")
|
||||
(:STATIC-FILE "kde-team.html") (:STATIC-FILE "inventory/variant-results.html")
|
||||
(:STATIC-FILE "inventory/search-results.html")
|
||||
(:STATIC-FILE "inventory/old.html") (:STATIC-FILE "inventory/new.html")
|
||||
(:STATIC-FILE "inventory/index.html") (:STATIC-FILE "inventory/import.html")
|
||||
(:STATIC-FILE "inventory/edit.html") (:STATIC-FILE "inventory/base-menu.html")
|
||||
(:STATIC-FILE "inventory/advanced-search.html")
|
||||
(:STATIC-FILE "inventory/_view_result.html")
|
||||
(:STATIC-FILE "inventory/_search_result_th.html")
|
||||
(:STATIC-FILE "inventory/_new_row.html")
|
||||
(:STATIC-FILE "inventory/_inventory_variants.html")
|
||||
(:STATIC-FILE "inventory/_edit_row.html")
|
||||
(:STATIC-FILE "inventory/_edit_result.html")
|
||||
(:STATIC-FILE "inventory/_advanced_search_select.html")
|
||||
(:STATIC-FILE "inventory/_advanced_search_input.html")
|
||||
(:STATIC-FILE "index.html") (:STATIC-FILE "footer.html")
|
||||
(:STATIC-FILE "file-js.html") (:STATIC-FILE "docs.md")
|
||||
(:STATIC-FILE "docs.html") (:STATIC-FILE "decks/search.html")
|
||||
(:STATIC-FILE "decks/saved-category-list.html")
|
||||
(:STATIC-FILE "decks/index.html")
|
||||
(:STATIC-FILE "decks/decks-by-category.html")
|
||||
(:STATIC-FILE "decks/deck-text-three-column.html")
|
||||
(:STATIC-FILE "decks/deck-text-textarea.html")
|
||||
(:STATIC-FILE "decks/deck-text-list.html")
|
||||
(:STATIC-FILE "decks/deck-text-list-original.html")
|
||||
(:STATIC-FILE "decks/deck-select.html")
|
||||
(:STATIC-FILE "decks/deck-menu-bar.html")
|
||||
(:STATIC-FILE "decks/deck-image-listing.html")
|
||||
(:STATIC-FILE "decks/deck-html-results.html")
|
||||
(:STATIC-FILE "decks/deck-html-results-1.html")
|
||||
(:STATIC-FILE "decks/deck-controls.html")
|
||||
(:STATIC-FILE "decks/category-select.html")
|
||||
(:STATIC-FILE "decks/cards-in-decks.html")
|
||||
(:STATIC-FILE "decks/_field_control_select.html")
|
||||
(:STATIC-FILE "contact/list.html") (:STATIC-FILE "contact/index.html")
|
||||
(:STATIC-FILE "contact/admin.html")
|
||||
(:STATIC-FILE "construct/select-sets.html")
|
||||
(:STATIC-FILE "construct/pull-menu-bar.html")
|
||||
(:STATIC-FILE "construct/index.html") (:STATIC-FILE "chat.html")
|
||||
(:STATIC-FILE "category/index.html") (:STATIC-FILE "category/explain.html")
|
||||
(:STATIC-FILE "category/child-list.html")
|
||||
(:STATIC-FILE "category/child-form.html")
|
||||
(:STATIC-FILE "category/category-menu-bar.html")
|
||||
(:STATIC-FILE "cards/view.html") (:STATIC-FILE "cards/search-results.html")
|
||||
(:STATIC-FILE "cards/info.html") (:STATIC-FILE "cards/index.html")
|
||||
(:STATIC-FILE "cards/cc-item-view.html")
|
||||
(:STATIC-FILE "cards/cc-item-row.html")
|
||||
(:STATIC-FILE "cards/_search_result_th.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_top.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_select_kind.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_select.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_numeric.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_input_numeric.html")
|
||||
(:STATIC-FILE "cards/_advanced_search_attrs.html")
|
||||
(:STATIC-FILE "builder/search-results.html")
|
||||
(:STATIC-FILE "builder/saved-deck-list.html")
|
||||
(:STATIC-FILE "builder/saved-category-list.html")
|
||||
(:STATIC-FILE "builder/index.html")
|
||||
(:STATIC-FILE "builder/deck-controls.html")
|
||||
(:STATIC-FILE "builder/current-deck-list.html")
|
||||
(:STATIC-FILE "builder/base-menu.html")
|
||||
(:STATIC-FILE "builder/_search_results_th.html")
|
||||
(:STATIC-FILE "builder/_jquery_droppable.html")
|
||||
(:STATIC-FILE "builder/_current_deck_list-1.html")
|
||||
(:STATIC-FILE "builder/_advanced_search_select_kind.html")
|
||||
(:STATIC-FILE "builder/_advanced_search_select.html")
|
||||
(:STATIC-FILE "builder/_advanced_search_numeric.html")
|
||||
(:STATIC-FILE "builder/_advanced_search_input_numeric.html")
|
||||
(:STATIC-FILE "builder/_advanced_search_attrs.html")
|
||||
(:STATIC-FILE "_errors/404.html"))))
|
||||
:description "Deck Builder Project"
|
||||
|
||||
:defsystem-depends-on (:deploy) ;; (ql:quickload "deploy") before
|
||||
:build-operation "deploy-op" ;; instead of "program-op"
|
||||
:build-pathname "cl-deck-builder2"
|
||||
:entry-point "cl-deck-builder2:my/start"
|
||||
|
||||
:in-order-to ((test-op (test-op "cl-deck-builder2-test"))))
|
||||
|
||||
;; Use compression: from 108M, 0.04s startup time to 24M, 0.37s.
|
||||
#+sb-core-compression
|
||||
(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
|
||||
(uiop:dump-image (asdf:output-file o c) :executable t :compression t))
|
||||
15
cl-deck-builder2.service
Normal file
15
cl-deck-builder2.service
Normal file
@ -0,0 +1,15 @@
|
||||
[Unit]
|
||||
Description=Deck Builder Service
|
||||
After=podman.service
|
||||
Requires=podman.service
|
||||
|
||||
[Service]
|
||||
TimeoutStartSec=0
|
||||
Restart=always
|
||||
#ExecStartPre=-/usr/bin/podman stop %n
|
||||
#ExecStartPre=-/usr/bin/podman rm %n
|
||||
#ExecStartPre=/usr/bin/podman pull redis
|
||||
ExecStart=make -C /home/deck/ docker-run
|
||||
|
||||
[Install]
|
||||
WantedBy=multi-user.target
|
||||
68
cl-deck-builder2.workers.asd
Normal file
68
cl-deck-builder2.workers.asd
Normal file
@ -0,0 +1,68 @@
|
||||
(asdf:defsystem "cl-deck-builder2.workers"
|
||||
:version "0.0.1"
|
||||
:author "Bubblegumdrop"
|
||||
:license "Do Not Redistribute"
|
||||
:depends-on (
|
||||
;; "clack"
|
||||
;; "lack"
|
||||
;; "caveman2"
|
||||
;; "envy"
|
||||
;; "cl-ppcre"
|
||||
;; "uiop"
|
||||
|
||||
;; for @route annotation
|
||||
;; "cl-syntax-annot"
|
||||
|
||||
;; HTML Template
|
||||
;; "djula"
|
||||
|
||||
;; for DB
|
||||
"mito"
|
||||
"mito-attachment"
|
||||
"datafly"
|
||||
"sxql"
|
||||
|
||||
;; for Models
|
||||
"assoc-utils" ; AGET is very handy
|
||||
"cl-csv" ; CSV import
|
||||
"cl-json" ; JSON import
|
||||
"cl-pass" ; Password hashing
|
||||
"local-time"
|
||||
"split-sequence"
|
||||
|
||||
;; Documentation!
|
||||
;; "documentation-utils"
|
||||
;; "documentation-utils-extensions"
|
||||
;; "cl-org-mode"
|
||||
|
||||
;; More of Shinmeraa's code
|
||||
;; "ratify"
|
||||
|
||||
;; QR Code Generator
|
||||
;; "lispqr"
|
||||
|
||||
;; Download stuff
|
||||
;; "trivial-download"
|
||||
|
||||
;; Error Handling
|
||||
;; "lack-middleware-clack-errors"
|
||||
|
||||
;; Better logging
|
||||
;; "verbose"
|
||||
|
||||
;; WebSocket chat server backend
|
||||
;; "websocket-driver"
|
||||
;; "lack-middleware-csrf"
|
||||
|
||||
;; "cl-markup"
|
||||
"hermetic"
|
||||
|
||||
"inferior-shell"
|
||||
|
||||
;; Background job processing
|
||||
"psychiq")
|
||||
:components ((:module "src/workers"
|
||||
:components
|
||||
((:file "main"))))
|
||||
:description "Deck Builder Project - Background Job Workers"
|
||||
:in-order-to ((test-op (test-op "cl-deck-builder2.workers-test"))))
|
||||
123
contrib.sh
Normal file
123
contrib.sh
Normal file
@ -0,0 +1,123 @@
|
||||
#!/bin/bash
|
||||
|
||||
# Start some stuff: Sidekiq Web UI, collectd web UI, MariaDB container, Redis container.
|
||||
#
|
||||
# Looks like shell scripts are also going into here. You may additionally backup_database.
|
||||
#
|
||||
# Hey it's starting to turn into a real deploy script!
|
||||
|
||||
set -euox
|
||||
|
||||
DOCKER=podman
|
||||
MARIADB_IMAGE=localhost/alpine-mariadb
|
||||
REDIS_IMAGE=localhost/redis-7.2-rc-alpine
|
||||
SCHEMACRAWLER_DIR=$HOME/schemacrawler-16.20.4-bin
|
||||
|
||||
function message(){
|
||||
plus="+"
|
||||
[[ $1 -ne 0 ]] && plus=-
|
||||
shift
|
||||
echo "[${plus}] $@"
|
||||
}
|
||||
|
||||
# This will probably either go away or be moved to mariadb database as we migrate (eventually)
|
||||
function backup_database() {
|
||||
shift
|
||||
running_container=
|
||||
if [ $# -eq 0 ]
|
||||
then
|
||||
running_container=$(${DOCKER} ps --format '{{.Image}} {{.Names}}' | grep cl-deck-builder2 | awk '{print $2}')
|
||||
else
|
||||
running_container="$1"
|
||||
fi
|
||||
if [ "x$running_container" = "x" ]
|
||||
then
|
||||
message 1 "deck builder container not running?"
|
||||
else
|
||||
message 0 "found $running_container"
|
||||
message 0 "copying database $running_container:/home/quicklisp/quicklisp/local-projects/cl-deck-builder2/deck_builder.sqlite3"
|
||||
$DOCKER cp "$running_container:/home/quicklisp/quicklisp/local-projects/cl-deck-builder2/deck_builder.sqlite3" \
|
||||
~/sqlite3/$(date '+%Y-%m-%d')-deck_builder.sqlite3
|
||||
ls -l ~/sqlite3/$(date '+%Y-%m-%d')-deck_builder.sqlite3
|
||||
fi
|
||||
}
|
||||
|
||||
function psychiq_up(){
|
||||
ps -C rackup >/dev/null
|
||||
if [ $? -ne 0 ]
|
||||
then
|
||||
message 0 "Starting Psychiq Web UI"
|
||||
rackup /home/user/code/cl-deck-builder2/ruby/config.ru &
|
||||
else
|
||||
message 1 "Psychiq Web UI already running."
|
||||
fi
|
||||
}
|
||||
|
||||
function collectd_up() {
|
||||
ps -C python3 >/dev/null
|
||||
if [ $? -ne 0 ]
|
||||
then
|
||||
message 0 "Starting collectd Web UI"
|
||||
pushd /home/user/code/alpine-collectd-web/
|
||||
python3 runserver.py &
|
||||
popd
|
||||
else
|
||||
message 1 "collectd Web UI already running."
|
||||
fi
|
||||
}
|
||||
|
||||
function mariadb_up (){
|
||||
mkdir -p ~/mariadb
|
||||
$DOCKER ps 2>&1| grep 3306 2>&1>/dev/null
|
||||
if [ $? -ne 0 ]
|
||||
then
|
||||
$DOCKER run --restart always -d -P -p 3306:3306 -v $HOME/mariadb:/var/lib/mysql $MARIADB_IMAGE
|
||||
else
|
||||
message 1 "mariadb already running."
|
||||
fi
|
||||
}
|
||||
|
||||
function redis_up(){
|
||||
mkdir -p ~/redis
|
||||
$DOCKER ps 2>&1| grep 6379 2>&1>/dev/null
|
||||
if [ $? -ne 0 ]
|
||||
then
|
||||
$DOCKER run --restart always -d -P -p 6379:6379 -v $HOME/redis:/data $REDIS_IMAGE
|
||||
else
|
||||
message 1 "redis already running."
|
||||
fi
|
||||
}
|
||||
|
||||
function schemacrawler(){
|
||||
ORIG_DIR="$(pwd)"
|
||||
cd $SCHEMACRAWLER_DIR
|
||||
# Gentoo Strikes Again!
|
||||
# https://github.com/schemacrawler/SchemaCrawler/issues/394
|
||||
_JAVA_OPTIONS=-Djava.io.tmpdir=. \
|
||||
bash bin/schemacrawler.sh \
|
||||
--user= \
|
||||
--password= \
|
||||
--database "$ORIG_DIR/deck_builder.sqlite3" \
|
||||
--server sqlite \
|
||||
--weak-associations=true \
|
||||
-i standard \
|
||||
-c schema \
|
||||
-o ~/www/db.png
|
||||
|
||||
chown :www-data ~/www/db.png
|
||||
}
|
||||
|
||||
function main(){
|
||||
# backup_database
|
||||
psychiq_up
|
||||
collectd_up
|
||||
mariadb_up
|
||||
redis_up
|
||||
}
|
||||
|
||||
if [ $# -lt 1 ]
|
||||
then
|
||||
message 1 "Usage: $0 [main | backup_database | psychiq_up | collectd_up | mariadb_up | redis_up | schemacrawler]"
|
||||
else
|
||||
"$1" "$@"
|
||||
fi
|
||||
393
db/file.csv
Normal file
393
db/file.csv
Normal file
@ -0,0 +1,393 @@
|
||||
type,name,tbl_name,rootpage,sql
|
||||
table,deck_item,deck_item,2,"CREATE TABLE ""deck_item"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""deck_id"" INTEGER NOT NULL,
|
||||
""kind"" INTEGER NOT NULL,
|
||||
""passcode"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,sqlite_sequence,sqlite_sequence,3,"CREATE TABLE sqlite_sequence(name,seq)"
|
||||
table,ygo_info,ygo_info,8,"CREATE TABLE ""ygo_info"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""desc"" STRING NOT NULL,
|
||||
""frame_type"" STRING NOT NULL,
|
||||
""type"" STRING NOT NULL,
|
||||
""passcode"" INTEGER NOT NULL,
|
||||
""name"" STRING NOT NULL,
|
||||
""race"" STRING NOT NULL,
|
||||
""archetype"" STRING,
|
||||
""attribute"" STRING,
|
||||
""linkmarkers"" STRING,
|
||||
""atk"" INTEGER,
|
||||
""def"" INTEGER,
|
||||
""level"" INTEGER,
|
||||
""linkval"" INTEGER,
|
||||
""scale"" INTEGER,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,users-feedback,users-feedback,12,"CREATE TABLE ""users-feedback"" (
|
||||
""rowid"" INTEGER PRIMARY KEY,
|
||||
""userid"" INTEGER,
|
||||
""text"" STRING,
|
||||
""created-at"" STRING,
|
||||
""updated-at"" STRING
|
||||
)"
|
||||
table,ygoprodeck-card-data,ygoprodeck-card-data,13,"CREATE TABLE ""ygoprodeck-card-data"" (
|
||||
""rowid"" INTEGER PRIMARY KEY,
|
||||
""passcode"" INTEGER,
|
||||
""name"" STRING,
|
||||
""type"" STRING,
|
||||
""frame-type"" STRING,
|
||||
""desc"" STRING,
|
||||
""race"" STRING,
|
||||
""archetype"" STRING,
|
||||
""created-at"" STRING,
|
||||
""updated-at"" STRING
|
||||
)"
|
||||
table,ygoprodeck-card-sets,ygoprodeck-card-sets,14,"CREATE TABLE ""ygoprodeck-card-sets"" (
|
||||
""rowid"" INTEGER PRIMARY KEY,
|
||||
""passcode"" INTEGER,
|
||||
""name"" STRING,
|
||||
""code"" STRING,
|
||||
""rarity"" STRING,
|
||||
""rarity-code"" STRING,
|
||||
""price"" STRING,
|
||||
""created-at"" STRING,
|
||||
""updated-at"" STRING
|
||||
)"
|
||||
table,attachment,attachment,21,"CREATE TABLE ""attachment"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""file_key"" VARCHAR(255) NOT NULL,
|
||||
""content_type"" VARCHAR(255) NOT NULL,
|
||||
""file_size"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""file_key"")
|
||||
)"
|
||||
index,sqlite_autoindex_attachment_1,attachment,22,
|
||||
table,ydk_deck,ydk_deck,23,"CREATE TABLE ""ydk_deck"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""category_id"" INTEGER,
|
||||
""created_by"" STRING NOT NULL,
|
||||
""name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""name"")
|
||||
)"
|
||||
index,sqlite_autoindex_ydk_deck_1,ydk_deck,24,
|
||||
table,category,category,27,"CREATE TABLE ""category"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""left"" INTEGER NOT NULL,
|
||||
""right"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,cc_item,cc_item,2939,"CREATE TABLE ""cc_item"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""product_name"" STRING NOT NULL,
|
||||
""category"" STRING NOT NULL,
|
||||
""wishlists"" INTEGER NOT NULL,
|
||||
""buy_price"" REAL NOT NULL,
|
||||
""sell_price"" REAL NOT NULL,
|
||||
""url"" STRING,
|
||||
""barcode"" STRING,
|
||||
""manufacturer_sku"" STRING,
|
||||
""amazon_asin"" STRING,
|
||||
""msrp"" REAL,
|
||||
""brand"" STRING,
|
||||
""weight"" REAL NOT NULL,
|
||||
""description"" STRING,
|
||||
""max_qty"" INTEGER,
|
||||
""total_qty"" INTEGER NOT NULL,
|
||||
""domestic_only"" INTEGER NOT NULL,
|
||||
""tax_exempt"" INTEGER NOT NULL,
|
||||
""name"" STRING,
|
||||
""code"" STRING,
|
||||
""rarity"" STRING,
|
||||
""edition"" STRING,
|
||||
""passcode"" INTEGER,
|
||||
""condition"" STRING NOT NULL,
|
||||
""language"" STRING NOT NULL,
|
||||
""opt_qty"" INTEGER NOT NULL,
|
||||
""reserved_qty"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_misc,ygo_misc,31807,"CREATE TABLE ""ygo_misc"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode"" INTEGER NOT NULL,
|
||||
""beta_name"" INTEGER NOT NULL,
|
||||
""views"" INTEGER NOT NULL,
|
||||
""viewsweek"" INTEGER NOT NULL,
|
||||
""upvotes"" INTEGER NOT NULL,
|
||||
""downvotes"" INTEGER NOT NULL,
|
||||
""tcg_date"" STRING NOT NULL,
|
||||
""ocg_date"" STRING NOT NULL,
|
||||
""konami_id"" INTEGER NOT NULL,
|
||||
""has_effect"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,feedback,feedback,7,"CREATE TABLE ""feedback"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""body"" STRING NOT NULL,
|
||||
""user_id"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,constructed_deck_item,constructed_deck_item,30965,"CREATE TABLE ""constructed_deck_item"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""name_id"" INTEGER NOT NULL,
|
||||
""code_id"" INTEGER NOT NULL,
|
||||
""rarity_id"" INTEGER NOT NULL,
|
||||
""edition_id"" INTEGER NOT NULL,
|
||||
""price"" INTEGER NOT NULL,
|
||||
""origin_id_id"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,constructed_decks,constructed_decks,30966,"CREATE TABLE ""constructed_decks"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""sell_price"" INTEGER NOT NULL,
|
||||
""origin_id_id"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_cards_misc_info,ygo_cards_misc_info,2601,"CREATE TABLE ""ygo_cards_misc_info"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""views"" INTEGER NOT NULL,
|
||||
""viewsweek"" INTEGER NOT NULL,
|
||||
""upvotes"" INTEGER NOT NULL,
|
||||
""downvotes"" INTEGER NOT NULL,
|
||||
""beta_id"" INTEGER,
|
||||
""beta_name_id"" INTEGER,
|
||||
""staple"" INTEGER,
|
||||
""konami_id"" INTEGER NOT NULL,
|
||||
""treated_as"" INTEGER,
|
||||
""has_effect"" INTEGER,
|
||||
""question_atk"" INTEGER,
|
||||
""question_def"" INTEGER,
|
||||
""tcg_date"" TIMESTAMP,
|
||||
""ocg_date"" TIMESTAMP,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_set_rarity_code_abbr,ygo_set_rarity_code_abbr,1758,"CREATE TABLE ""ygo_set_rarity_code_abbr"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""code"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""code"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_set_rarity_code_abbr_1,ygo_set_rarity_code_abbr,1759,
|
||||
table,get_column_real_type,get_column_real_type,4,"CREATE TABLE get_column_real_type (
|
||||
test TIMESTAMP
|
||||
)"
|
||||
table,ygo_card_name,ygo_card_name,17,"CREATE TABLE ""ygo_card_name"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""name"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_name_1,ygo_card_name,1501,
|
||||
table,ygo_card_type,ygo_card_type,1512,"CREATE TABLE ""ygo_card_type"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""card_type"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""card_type"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_type_1,ygo_card_type,1515,
|
||||
table,ygo_card_frame_type,ygo_card_frame_type,1517,"CREATE TABLE ""ygo_card_frame_type"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""frame_type"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""frame_type"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_frame_type_1,ygo_card_frame_type,1539,
|
||||
table,ygo_card_race,ygo_card_race,1541,"CREATE TABLE ""ygo_card_race"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""race"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""race"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_race_1,ygo_card_race,1544,
|
||||
table,ygo_card_archetype,ygo_card_archetype,1554,"CREATE TABLE ""ygo_card_archetype"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""archetype"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""archetype"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_archetype_1,ygo_card_archetype,1562,
|
||||
table,ygo_card_attribute,ygo_card_attribute,1566,"CREATE TABLE ""ygo_card_attribute"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""attribute"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""attribute"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_card_attribute_1,ygo_card_attribute,1567,
|
||||
table,ygo_card,ygo_card,1571,"CREATE TABLE ""ygo_card"" (
|
||||
""id"" INTEGER NOT NULL PRIMARY KEY,
|
||||
""name_id"" INTEGER NOT NULL,
|
||||
""desc"" STRING NOT NULL,
|
||||
""archetype_id"" INTEGER,
|
||||
""attribute_id"" INTEGER,
|
||||
""atk"" INTEGER,
|
||||
""def"" INTEGER,
|
||||
""scale"" INTEGER,
|
||||
""level"" INTEGER,
|
||||
""frame_type_id"" INTEGER NOT NULL,
|
||||
""race_id"" INTEGER NOT NULL,
|
||||
""card_type_id"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_card_misc_info,ygo_card_misc_info,1576,"CREATE TABLE ""ygo_card_misc_info"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""views"" INTEGER NOT NULL,
|
||||
""viewsweek"" INTEGER NOT NULL,
|
||||
""upvotes"" INTEGER NOT NULL,
|
||||
""downvotes"" INTEGER NOT NULL,
|
||||
""beta_id"" INTEGER,
|
||||
""beta_name_id"" INTEGER,
|
||||
""staple"" INTEGER,
|
||||
""konami_id"" INTEGER NOT NULL,
|
||||
""treated_as_id"" INTEGER,
|
||||
""has_effect"" INTEGER,
|
||||
""question_atk"" INTEGER,
|
||||
""question_def"" INTEGER,
|
||||
""tcg_date"" TIMESTAMP,
|
||||
""ocg_date"" TIMESTAMP,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_set_name,ygo_set_name,1583,"CREATE TABLE ""ygo_set_name"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""set_name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""set_name"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_set_name_1,ygo_set_name,1585,
|
||||
table,ygo_set_code,ygo_set_code,1590,"CREATE TABLE ""ygo_set_code"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""set_code"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""set_code"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_set_code_1,ygo_set_code,1591,
|
||||
table,ygo_set_rarity,ygo_set_rarity,1592,"CREATE TABLE ""ygo_set_rarity"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""rarity"" STRING NOT NULL,
|
||||
""code"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_set_edition,ygo_set_edition,1594,"CREATE TABLE ""ygo_set_edition"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""set_edition"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""set_edition"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_set_edition_1,ygo_set_edition,1596,
|
||||
table,ygo_linkmarker_name,ygo_linkmarker_name,1600,"CREATE TABLE ""ygo_linkmarker_name"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_linkmarker,ygo_linkmarker,1601,"CREATE TABLE ""ygo_linkmarker"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""bottom_id"" INTEGER,
|
||||
""bottom_left_id"" INTEGER,
|
||||
""bottom_right_id"" INTEGER,
|
||||
""left_id"" INTEGER,
|
||||
""right_id"" INTEGER,
|
||||
""top_id"" INTEGER,
|
||||
""top_left_id"" INTEGER,
|
||||
""top_right_id"" INTEGER,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_format_name,ygo_format_name,1603,"CREATE TABLE ""ygo_format_name"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_format,ygo_format,1613,"CREATE TABLE ""ygo_format"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER,
|
||||
""common_charity_id"" INTEGER,
|
||||
""duel_links_id"" INTEGER,
|
||||
""edison_id"" INTEGER,
|
||||
""goat_id"" INTEGER,
|
||||
""ocg_id"" INTEGER,
|
||||
""ocg_goat_id"" INTEGER,
|
||||
""speed_duel_id"" INTEGER,
|
||||
""tcg_id"" INTEGER,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_banlist_name,ygo_banlist_name,1620,"CREATE TABLE ""ygo_banlist_name"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""name"" STRING NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_banlist,ygo_banlist,1624,"CREATE TABLE ""ygo_banlist"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""ban_goat_id"" INTEGER,
|
||||
""ban_ocg_id"" INTEGER,
|
||||
""ban_tcg_id"" INTEGER,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP,
|
||||
UNIQUE (""passcode_id"")
|
||||
)"
|
||||
index,sqlite_autoindex_ygo_banlist_1,ygo_banlist,1625,
|
||||
table,ygo_alternative_artwork,ygo_alternative_artwork,1629,"CREATE TABLE ""ygo_alternative_artwork"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""alternate_id"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_price,ygo_price,1632,"CREATE TABLE ""ygo_price"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""cardmarket_price"" INTEGER NOT NULL,
|
||||
""tcgplayer_price"" INTEGER NOT NULL,
|
||||
""ebay_price"" INTEGER NOT NULL,
|
||||
""amazon_price"" INTEGER NOT NULL,
|
||||
""coolstuffinc_price"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
table,ygo_set,ygo_set,1597,"CREATE TABLE ""ygo_set"" (
|
||||
""id"" INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
""passcode_id"" INTEGER NOT NULL,
|
||||
""name_id"" INTEGER NOT NULL,
|
||||
""code_id"" INTEGER NOT NULL,
|
||||
""rarity_id"" INTEGER NOT NULL,
|
||||
""edition_id"" INTEGER NOT NULL,
|
||||
""price"" INTEGER NOT NULL,
|
||||
""created_at"" TIMESTAMP,
|
||||
""updated_at"" TIMESTAMP
|
||||
)"
|
||||
|
421
db/schema.sql
Normal file
421
db/schema.sql
Normal file
@ -0,0 +1,421 @@
|
||||
CREATE TABLE feedback (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
user_id INTEGER NOT NULL,
|
||||
body TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE user_role (
|
||||
user_id INTEGER NOT NULL,
|
||||
role_name VARCHAR(64) NOT NULL,
|
||||
PRIMARY KEY (user_id, role_name)
|
||||
);
|
||||
CREATE TABLE role (
|
||||
name VARCHAR(64) NOT NULL,
|
||||
PRIMARY KEY (name)
|
||||
);
|
||||
CREATE TABLE user (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
email TEXT NOT NULL,
|
||||
password_hash CHAR(64) NOT NULL,
|
||||
password_salt BINARY(20) NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (email)
|
||||
);
|
||||
CREATE TABLE ygo_cc_item (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
item_id INTEGER NOT NULL,
|
||||
variant_id INTEGER NOT NULL,
|
||||
qty INTEGER NOT NULL,
|
||||
opt_qty INTEGER NOT NULL,
|
||||
buy_price INTEGER NOT NULL,
|
||||
sell_price INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE cc_item (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
category TEXT NOT NULL,
|
||||
total_qty INTEGER NOT NULL,
|
||||
wishlists INTEGER NOT NULL,
|
||||
buy_price INTEGER NOT NULL,
|
||||
sell_price INTEGER NOT NULL,
|
||||
url TEXT,
|
||||
barcode TEXT,
|
||||
manufacturer_sku TEXT,
|
||||
amazon_asin TEXT,
|
||||
msrp INTEGER,
|
||||
brand TEXT,
|
||||
weight TEXT NOT NULL,
|
||||
description TEXT,
|
||||
max_qty INTEGER,
|
||||
domestic_only INTEGER NOT NULL,
|
||||
tax_exempt INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE sold_decks (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
category_id INTEGER,
|
||||
created_by TEXT NOT NULL,
|
||||
sell_price INTEGER,
|
||||
ydk_deck_id INTEGER NOT NULL,
|
||||
deck_sold INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE constructed_deck (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
category_id INTEGER,
|
||||
created_by TEXT NOT NULL,
|
||||
sell_price INTEGER,
|
||||
ydk_deck_id INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE constructed_deck_item (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
ygo_card_id INTEGER NOT NULL,
|
||||
deck_id INTEGER NOT NULL,
|
||||
sell_price INTEGER,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_set_item (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
item_id INTEGER NOT NULL,
|
||||
variant_id INTEGER NOT NULL,
|
||||
qty INTEGER NOT NULL,
|
||||
opt_qty INTEGER NOT NULL,
|
||||
buy_price INTEGER NOT NULL,
|
||||
sell_price INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_price (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
cardmarket_price INTEGER NOT NULL,
|
||||
tcgplayer_price INTEGER NOT NULL,
|
||||
ebay_price INTEGER NOT NULL,
|
||||
amazon_price INTEGER NOT NULL,
|
||||
coolstuffinc_price INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_alternative_artwork (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
alternate_id INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_banlist (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
ban_goat_id INTEGER,
|
||||
ban_ocg_id INTEGER,
|
||||
ban_tcg_id INTEGER,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (passcode_id)
|
||||
);
|
||||
CREATE TABLE ygo_format (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER,
|
||||
common_charity_id INTEGER,
|
||||
duel_links_id INTEGER,
|
||||
edison_id INTEGER,
|
||||
goat_id INTEGER,
|
||||
ocg_id INTEGER,
|
||||
ocg_goat_id INTEGER,
|
||||
speed_duel_id INTEGER,
|
||||
tcg_id INTEGER,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_linkmarker (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
bottom_id INTEGER,
|
||||
bottom_left_id INTEGER,
|
||||
bottom_right_id INTEGER,
|
||||
left_id INTEGER,
|
||||
right_id INTEGER,
|
||||
top_id INTEGER,
|
||||
top_left_id INTEGER,
|
||||
top_right_id INTEGER,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_set (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
name_id INTEGER NOT NULL,
|
||||
code_id INTEGER NOT NULL,
|
||||
rarity_id INTEGER NOT NULL,
|
||||
rarity_code_id INTEGER NOT NULL,
|
||||
edition_id INTEGER NOT NULL,
|
||||
url TEXT NOT NULL,
|
||||
price INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_set_edition (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_set_rarity (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_set_code (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_set_name (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_misc_info (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode_id INTEGER NOT NULL,
|
||||
views INTEGER NOT NULL,
|
||||
viewsweek INTEGER NOT NULL,
|
||||
upvotes INTEGER NOT NULL,
|
||||
downvotes INTEGER NOT NULL,
|
||||
beta_id INTEGER,
|
||||
beta_name_id INTEGER,
|
||||
staple INTEGER,
|
||||
konami_id INTEGER NOT NULL,
|
||||
treated_as_id INTEGER,
|
||||
has_effect INTEGER,
|
||||
question_atk INTEGER,
|
||||
question_def INTEGER,
|
||||
tcg_date TIMESTAMP,
|
||||
ocg_date TIMESTAMP,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_card (
|
||||
id INTEGER NOT NULL PRIMARY KEY,
|
||||
name TEXT NOT NULL,
|
||||
desc TEXT NOT NULL,
|
||||
archetype_id INTEGER,
|
||||
attribute_id INTEGER,
|
||||
atk INTEGER,
|
||||
def INTEGER,
|
||||
scale INTEGER,
|
||||
level INTEGER,
|
||||
frame_type_id INTEGER NOT NULL,
|
||||
race_id INTEGER NOT NULL,
|
||||
card_type_id INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_card_attribute (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_archetype (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_race (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_frame_type (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_type (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_card_name (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_name_mixin (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_set_rarity_code (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE ygo_linkmarker_name (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_format_name (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_banlist_name (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE variant_language (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE variant_condition (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE variant (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ydk_deck (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
category_id INTEGER,
|
||||
created_by TEXT NOT NULL,
|
||||
name TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (name)
|
||||
);
|
||||
CREATE TABLE deck_item (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
deck_id INTEGER NOT NULL,
|
||||
kind INTEGER NOT NULL,
|
||||
passcode INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_format (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode INTEGER NOT NULL,
|
||||
format TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_misc (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode INTEGER NOT NULL,
|
||||
beta_name INTEGER NOT NULL,
|
||||
views INTEGER NOT NULL,
|
||||
viewsweek INTEGER NOT NULL,
|
||||
upvotes INTEGER NOT NULL,
|
||||
downvotes INTEGER NOT NULL,
|
||||
tcg_date TEXT NOT NULL,
|
||||
ocg_date TEXT NOT NULL,
|
||||
konami_id INTEGER NOT NULL,
|
||||
has_effect INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_price (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
passcode INTEGER NOT NULL,
|
||||
cardmarket REAL NOT NULL,
|
||||
tcgplayer REAL NOT NULL,
|
||||
ebay REAL NOT NULL,
|
||||
amazon REAL NOT NULL,
|
||||
coolstuffinc REAL NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_set (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
code TEXT NOT NULL,
|
||||
name TEXT NOT NULL,
|
||||
passcode INTEGER NOT NULL,
|
||||
price REAL NOT NULL,
|
||||
rarity TEXT NOT NULL,
|
||||
rarity_code TEXT NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE ygo_info (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
desc TEXT NOT NULL,
|
||||
frame_type TEXT NOT NULL,
|
||||
type TEXT NOT NULL,
|
||||
passcode INTEGER NOT NULL,
|
||||
name TEXT NOT NULL,
|
||||
race TEXT NOT NULL,
|
||||
archetype TEXT,
|
||||
attribute TEXT,
|
||||
linkmarkers TEXT,
|
||||
atk INTEGER,
|
||||
def INTEGER,
|
||||
level INTEGER,
|
||||
linkval INTEGER,
|
||||
scale INTEGER,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE category (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
name TEXT NOT NULL,
|
||||
left INTEGER NOT NULL,
|
||||
right INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP
|
||||
);
|
||||
CREATE TABLE attachment (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
file_key VARCHAR(255) NOT NULL,
|
||||
content_type VARCHAR(255) NOT NULL,
|
||||
file_size INTEGER NOT NULL,
|
||||
created_at TIMESTAMP,
|
||||
updated_at TIMESTAMP,
|
||||
UNIQUE (file_key)
|
||||
);
|
||||
315
doc/about.md
Normal file
315
doc/about.md
Normal file
@ -0,0 +1,315 @@
|
||||
# What it is
|
||||
|
||||
***Note:** Since the application is still in development, it is common
|
||||
for components to be unavailable, unresponsive, or outright
|
||||
unusable. If you're able to, please [submit a message](/contact) with
|
||||
the text of the page with Copy/Paste (Ctrl+A, Ctrl+C, Ctrl+V) and any
|
||||
additional information.*
|
||||
|
||||
**cl-deck-builder2** is really three things:
|
||||
|
||||
- [Inventory Management](#inventory)
|
||||
- [Deck Builder](#builder)
|
||||
- [Unifying User Interface](#ui)
|
||||
|
||||
This application merges these things into a web interface where you
|
||||
can create, modify, and update decks, pricing, and inventory data.
|
||||
|
||||
It is a web app written in [Common Lisp](https://lisp-lang.org/learn/first-steps)
|
||||
using [Caveman2](https://github.com/fukamachi/caveman).
|
||||
|
||||
## Inventory Management
|
||||
|
||||
The inventory manager is located here: [/cards](/cards).
|
||||
|
||||
**cl-deck-builder2** aims to suppliment Crystal Commerce Product
|
||||
Manager tools.
|
||||
|
||||
The original intent was to allow CSV upload of Product Names from
|
||||
Crystal Commerce. This proved to be unnecessary, as YGOProDeck has all
|
||||
of the information in the `card_sets` arrays for each card.
|
||||
|
||||
The Inventory editor has been superseded by the YGOProDeck editor.
|
||||
|
||||
The CSV components and all of the Crystal Commerce code is in
|
||||
maintenance mode, and due to be removed, as there is no way to access
|
||||
or update this information currently.
|
||||
|
||||
### How To Use It
|
||||
|
||||
Currently the following features are supported:
|
||||
|
||||
- Partial List of Inventory Items: [Inventory List](/cards)
|
||||
|
||||
- Clicking on the card image will take you to the Inventory for that card
|
||||
|
||||
- Each Card has a `YGO-SET` associated with it, and each `YGO-SET` has
|
||||
one of five `VARIANT-CONDITION` associated with that. The two
|
||||
together create a `YGO-SET-ITEM` which is where the inventory and
|
||||
pricing information is contained.
|
||||
|
||||
- The information displayed is: `Card Name - Set Code - Set Edition - Set Rarity - Set Price`
|
||||
|
||||
- Clicking the Gear displays the `YGO-SET-ITEM` for this particular card.
|
||||
|
||||
- Editing of individual inventory items: [Edit #1](/cards/1/view)
|
||||
|
||||
- Extraction of additional data on import: exact card name, set
|
||||
Code, Rarity, and Edition.
|
||||
|
||||
- Import of YGOProDeck Extra data: passcodes and linked images based
|
||||
on passcodes
|
||||
|
||||
## Deck Builder
|
||||
|
||||
The deck builder is located here: [/builder](/builder).
|
||||
|
||||
The Deck Builder component currently supports searching by full card
|
||||
name name, e.g. `Magician of Faith`. Any text matching this pattern
|
||||
entered into the Deck List box will return a list of matching results.
|
||||
|
||||
Currently, there are approximately 12000 entries in the database. This
|
||||
list came from the YGOProDeck API.
|
||||
|
||||
### How To Use It
|
||||
|
||||
Simply paste a list of matching cards into the list.
|
||||
|
||||
YGOProDeck Decks with extension `.ydk` can be uploaded with an
|
||||
incomplete public interface which can be found at [/ydk/](/ydk).
|
||||
|
||||
## User Interface
|
||||
|
||||
The user interface is a [Caveman2](https://github.com/fukamachi/caveman)
|
||||
web app with Common Lisp back-end. All of the things that can be done on
|
||||
the web front-end have supporting code in the CL back-end. You may load
|
||||
the source code into your editor and mess around with card information
|
||||
yourself.
|
||||
|
||||
### How To Use It
|
||||
|
||||
You're using it right now!
|
||||
|
||||
## Source Code
|
||||
|
||||
The source code is available [here](http://[2601:198:100:1261:d250:99ff:fe2e:566a]/git/).
|
||||
|
||||
# Completed Feature List
|
||||
|
||||
## Categories
|
||||
|
||||
We're using the [Nested Set Model](https://en.wikipedia.org/wiki/Nested_set_model#Example).
|
||||
|
||||
You may create Parent Nodes (Left) and Child Nodes (Right). It needs a lot of work and is pretty SQL heavy.
|
||||
|
||||
## Sort By Many Fields
|
||||
|
||||
When searching for results, we try to support "Not Just Alphabetical,"
|
||||
e.g. more than alphabetical sort. You may sort by Qty, Category, Race,
|
||||
Type, Card Text...
|
||||
|
||||
Some of these aren't actually implemented because it's quite a bit of
|
||||
work. But the majority of the sort patterns are there.
|
||||
|
||||
## Deck Constraints
|
||||
|
||||
The constraints placed on a deck during construction at the `/builder`
|
||||
resource are kind-of arbitrary. Here is the breakdown.
|
||||
|
||||
First of all, at the database level, there are no restrictions on a
|
||||
deck. See [here](https://www.formatlibrary.com/decktypes/inzektor?format=ravine_ruler)
|
||||
for an example. You will notice in the "Popular Extra Deck Cards" area
|
||||
there are *20* cards. You may download the `.ydk` file from the
|
||||
`Download` button at the top. If you import this deck into the app, it
|
||||
will accept it as is. You will end up with an Extra Deck with 20 cards
|
||||
in it. This is intended.
|
||||
|
||||
You may also notice, that, by design, when you create a new deck,
|
||||
there will be zero cards in it. This is allowed as well.
|
||||
|
||||
However, if you continue to construct a deck, you will eventually be
|
||||
constrained to 60 cards in your main deck, as well as 15 cards in
|
||||
extra and side decks. There is no way to prevent this limiting from
|
||||
occurring.
|
||||
|
||||
Ideally, I would like to have a way to switch between "free builder"
|
||||
and "constrained builder." A problem thus far has been "Where does the
|
||||
constraint checking happen?" And the current solution lies in the way
|
||||
the app is structured.
|
||||
|
||||
So if you imagine each deck you construct as a template, then the deck
|
||||
builder is really a template constructor. There is a queue of Saved
|
||||
Deck Configurations, which can be categorized, with the
|
||||
[Categories](#categories) feature above.
|
||||
|
||||
- Main deck max cards 60
|
||||
- Side Deck max cards 15
|
||||
- Extra Deck max cards 15
|
||||
|
||||
As it stands, these constraints are hard coded. I'm not sure how I would
|
||||
implement this, but if I were to, it would be something like, setting
|
||||
a cookie and doing constraint checking in-line with some kind of CLOS
|
||||
object.
|
||||
|
||||
### Card Priority
|
||||
|
||||
Cards will be added in this order:
|
||||
|
||||
- Drag and drop: the card goes where you dropped it, provided the above numeric constraints are met.
|
||||
- Right click: the card is added at the "end" of the deck list, in
|
||||
this order: main deck, extra deck, side deck, trying to meet the
|
||||
above numeric constraints.
|
||||
|
||||
Following this, when you save a deck, a priority number is assigned to
|
||||
the card as follows:
|
||||
|
||||
- "normal" 0
|
||||
- "effect" 1
|
||||
- "ritual" 2
|
||||
- "fusion" 3
|
||||
- "link" 4
|
||||
- "skill" 5
|
||||
- "synchro" 6
|
||||
- "token" 7
|
||||
- "xyz" 8
|
||||
- "spell" 9
|
||||
- "trap" 10
|
||||
- "effect_pendulum" 11
|
||||
- "fusion_pendulum" 12
|
||||
- "normal_pendulum" 13
|
||||
- "ritual_pendulum" 14
|
||||
- "synchro_pendulum" 15
|
||||
- "xyz_pendulum" 16
|
||||
- Everything Else 17
|
||||
|
||||
Lower numbers get put "earlier" in the deck listing. The next time you
|
||||
load the deck it will be sorted in this order.
|
||||
|
||||
## User Profiles
|
||||
|
||||
You may currently register, login, logout, view the user list. This
|
||||
code has hardly been touched since it was implemented. If I spent more
|
||||
time working on the user code, I could also implement the "free
|
||||
builder" toggle system.
|
||||
|
||||
The web framework system we're using gives us access to request and
|
||||
session information, and we can store cookies. There is also a
|
||||
database extension for managing all of this information persistently
|
||||
in a database. Our current database model is very simple. There is a
|
||||
user, with a password, and some metadata.
|
||||
|
||||
We currently hash passwords, as well. So your passwords are stored
|
||||
securely. You currently may not change your password.
|
||||
|
||||
When you register an account we ask for an email. We currently do
|
||||
nothing with this. An email server would take additional time to
|
||||
configure. A rudimentary setup would most likely be caught in your
|
||||
spam filters. This also highlights another issue with the app. We don't
|
||||
currently have a domain name. But that is another topic.
|
||||
|
||||
### Trade Between Profiles
|
||||
|
||||
Theoretically this is no different than assigning a `category_id` to a
|
||||
`ydk_deck`. Simply add a `user_id` field to indicate the user which
|
||||
created the deck. However, this is not implemented, because I have not
|
||||
spent the required time looking at user management, as stated above.
|
||||
|
||||
## Charts / Metrics
|
||||
|
||||
We have rudimentary charts and metrics provided by
|
||||
[RRDtool](https://oss.oetiker.ch/rrdtool/). These charts are just host
|
||||
information. We can feed it all kinds of data. It will take time to
|
||||
research the data format it ingests and how to produce a chart.
|
||||
|
||||
I'm not sure if Crystal Commerce offers pricing or inventory charts or metrics.
|
||||
|
||||
## Picture of Finalized Deck
|
||||
|
||||
We use [ImageMagick](https://www.imagemagick.org/) to generate deck
|
||||
images and other various image manipulations. We have complete control
|
||||
over the process. Currently output is very rudimentary. However I have
|
||||
complete control over the pipeline, and at this stage, more time could
|
||||
be spent developing this pipeline. It is currently sufficient for our
|
||||
purposes.
|
||||
|
||||
The output is currently four static images, the main deck, extra, and
|
||||
side decks, then a concatenation of the three images. Additionally, we
|
||||
output the intermediate concatenation images as well.
|
||||
|
||||
## Different Card Games
|
||||
|
||||
This is possible, all of the application is currently hard-coded to
|
||||
use Yu-Gi-Oh!. It would take a quite a bit of time to re-factor all of
|
||||
the routes to handle this scenario instead of possibly just running
|
||||
multiple copies of the app, or having dedicated instances of the app
|
||||
connected to dedicated database back-ends.
|
||||
|
||||
Regardless, currently we only support Yu-Gi-Oh!. If more work were
|
||||
done on the User component, I could make it configurable as a cookie.
|
||||
|
||||
## Builder Controls
|
||||
|
||||
Click on a card in the search results to see its information (card text, ATK, DEF, ...).
|
||||
|
||||
### Advanced Search
|
||||
|
||||
In the Advanced Search menu you may search by card type, e.g. `frame_type` => `trap` will show you all trap cards.
|
||||
|
||||
## Decks Overview
|
||||
|
||||
There is currently a rudimentary decks overview page.
|
||||
|
||||
## Constructed Deck Workflow
|
||||
|
||||
The workflow for constructing decks is as follows:
|
||||
|
||||
1. Create deck of cards. Currently we select from all cards. Maybe we
|
||||
should just select cards from inventory. The majority of this
|
||||
functionality in place and isn't expected to change. A deck will
|
||||
always just be a list of cards plus metadata.
|
||||
|
||||
2. The deck of cards has metadata about author, name of deck, time of
|
||||
creation. The main content of the deck is three lists, comprising
|
||||
the main, extra, and side decks. This information is not expected
|
||||
to change in the future. Decks created by a particular user for
|
||||
example. The underlying metadata representation is what's being
|
||||
worked on. Currently each item in the database has all information
|
||||
duplicated from the rest of the database. Changing the price for
|
||||
one card changes the price for only that one card matching that row
|
||||
in the database. There will be additional tables to store pricing
|
||||
information in the next step.
|
||||
|
||||
3. On the Deck Overview page, selecting "Pull Deck" will decrease the
|
||||
inventory of the lowest priced card in inventory by one for every
|
||||
card in the deck. This is like "add to cart" in an online shopping
|
||||
platform, with additional inventory keeping. This is analogous to
|
||||
the deck construction step, except instead of selecting cards to be
|
||||
put into a deck, that information is provided prior, and we use
|
||||
that list of information to construct secondary lists.
|
||||
|
||||
4. On the pulled deck page, for every card in the deck, you will be
|
||||
able to select cards by edition, condition, and rarity of every
|
||||
card in the inventory matching that card's passcode. I can
|
||||
conceive a very simple concept where you attempt to check out, and
|
||||
then are returned with error messages saying which items had
|
||||
errors. This is the current approach.
|
||||
|
||||
5. There will be an intermediate stage. Once there is enough inventory
|
||||
and the deck is "pulled" it will enter an area where each
|
||||
individual card will be selected. e.g. selecting the rarity or set
|
||||
of a particular card in each deck.
|
||||
|
||||
6. Once all "errors" are resolved (banlists, constraints, etc), the
|
||||
"pulled" deck will allow you to "construct" it, which will finalize
|
||||
the state of this pulled deck in the database, moving it to another
|
||||
table, the list of decks for sale.
|
||||
|
||||
7. The list of decks for sale is just pulled, constructed decks with
|
||||
pricing information attached and whether or not it was sold and
|
||||
what price it was sold at and when.
|
||||
|
||||
## Formats
|
||||
|
||||
It appears that I began working on format integration from
|
||||
YGOProDeck. I have not found a way to integrate this information into
|
||||
the builder yet.
|
||||
40
doc/flowcharts/card-doc.dot
Normal file
40
doc/flowcharts/card-doc.dot
Normal file
@ -0,0 +1,40 @@
|
||||
digraph G {
|
||||
fontname="Helvetica,Arial,sans-serif"
|
||||
edge [fontname="Helvetica,Arial,sans-serif"]
|
||||
node [fontname="Helvetica,Arial,sans-serif"];
|
||||
|
||||
subgraph cluster_0 {
|
||||
style=filled;
|
||||
color=lightgrey;
|
||||
node [style=filled,color=white];
|
||||
"YGO-SET-PASSCODE" -> "YGO-SET-ID";
|
||||
label = "YGO-SET";
|
||||
}
|
||||
|
||||
subgraph cluster_1 {
|
||||
node [style=filled];
|
||||
label = "YGO-CARD";
|
||||
"YGO-CARD-PASSCODE";
|
||||
color=blue;
|
||||
}
|
||||
|
||||
start -> "Mystic Tomato" -> 83011278;
|
||||
|
||||
83011278 -> "YGO-CARD-PASSCODE";
|
||||
83011278 -> "YGO-SET-PASSCODE";
|
||||
|
||||
"YGO-CARD-PASSCODE" -> "YGO-SET-PASSCODE";
|
||||
"YGO-SET-PASSCODE" -> "YGO-CARD-PASSCODE";
|
||||
|
||||
// "YGO-CARD-PASSCODE" -> end;
|
||||
// "YGO-SET-PASSCODE" -> end;
|
||||
|
||||
83011277 -> "YGO-ALTERNATE-ID" -> "YGO-CARD-PASSCODE";
|
||||
"VARIANT-CONDITION" -> "YGO-SET-ITEM";
|
||||
"YGO-SET-ID" -> "YGO-SET-ITEM";
|
||||
|
||||
"YGO-SET-ITEM" -> end;
|
||||
|
||||
start [shape=Mdiamond];
|
||||
end [shape=Msquare];
|
||||
}
|
||||
BIN
doc/flowcharts/card-doc.png
Normal file
BIN
doc/flowcharts/card-doc.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 67 KiB |
32
doc/flowcharts/cluster.dot
Normal file
32
doc/flowcharts/cluster.dot
Normal file
@ -0,0 +1,32 @@
|
||||
// https://graphviz.org/Gallery/directed/cluster.html
|
||||
|
||||
digraph G {
|
||||
fontname="Helvetica,Arial,sans-serif"
|
||||
node [fontname="Helvetica,Arial,sans-serif"]
|
||||
edge [fontname="Helvetica,Arial,sans-serif"]
|
||||
|
||||
subgraph cluster_0 {
|
||||
style=filled;
|
||||
color=lightgrey;
|
||||
node [style=filled,color=white];
|
||||
a0 -> a1 -> a2 -> a3;
|
||||
label = "process #1";
|
||||
}
|
||||
|
||||
subgraph cluster_1 {
|
||||
node [style=filled];
|
||||
b0 -> b1 -> b2 -> b3;
|
||||
label = "process #2";
|
||||
color=blue
|
||||
}
|
||||
start -> a0;
|
||||
start -> b0;
|
||||
a1 -> b3;
|
||||
b2 -> a3;
|
||||
a3 -> a0;
|
||||
a3 -> end;
|
||||
b3 -> end;
|
||||
|
||||
start [shape=Mdiamond];
|
||||
end [shape=Msquare];
|
||||
}
|
||||
71
doc/flowcharts/constructed-deck-doc.dot
Normal file
71
doc/flowcharts/constructed-deck-doc.dot
Normal file
@ -0,0 +1,71 @@
|
||||
digraph G {
|
||||
fontname="Helvetica,Arial,sans-serif"
|
||||
node [fontname="Helvetica,Arial,sans-serif"]
|
||||
edge [fontname="Helvetica,Arial,sans-serif"]
|
||||
|
||||
subgraph cluster_0 {
|
||||
style=filled;
|
||||
color=goldenrod3;
|
||||
node [style=filled,color=white];
|
||||
ydk_main [label="MAIN-DECK"];
|
||||
ydk_side [label="SIDE-DECK"];
|
||||
ydk_extra [label="EXTRA-DECK"];
|
||||
label = "YDK (Dragon Turbo)";
|
||||
labeljust=r;
|
||||
}
|
||||
|
||||
subgraph cluster_1 {
|
||||
style=filled;
|
||||
color=palegreen;
|
||||
node [style=filled,color=white];
|
||||
ydk_deck_item [label="..."];
|
||||
ydk_deck_item_1 [label="YDK-DECK-ITEM"];
|
||||
ydk_deck_item_2 [label="..."];
|
||||
ydk_deck_item -> ydk_deck_item_1 -> ydk_deck_item_2;
|
||||
label="YDK-DECK";
|
||||
labeljust=l;
|
||||
}
|
||||
|
||||
subgraph cluster_2 {
|
||||
style=filled;
|
||||
color=lightcoral;
|
||||
node [style=filled,color=white];
|
||||
constructed_deck_item [label="..."];
|
||||
constructed_deck_item_1 [label="CONSTRUCTED-DECK-ITEM"];
|
||||
constructed_deck_item_2 [label="..."];
|
||||
constructed_deck_item -> constructed_deck_item_1 -> constructed_deck_item_2;
|
||||
ydk_deck_item -> constructed_deck_item;
|
||||
label="CONSTRUCTED-DECK";
|
||||
labeljust=r;
|
||||
}
|
||||
|
||||
ygo_alternate_id [label="YGO-ALTERNATE-ID"];
|
||||
ygo_card_passcode [label="YGO-CARD-PASSCODE"];
|
||||
variant_condition [label="VARIANT-CONDITION"];
|
||||
ygo_set [label="YGO-SET"];
|
||||
ygo_set_item [label="YGO-SET-ITEM"];
|
||||
|
||||
ydk_main -> "Mystic Tomato" -> 83011278;
|
||||
ydk_extra -> "Mystic Tomato";
|
||||
|
||||
83011278 -> ygo_card_passcode;
|
||||
|
||||
ygo_card_passcode -> ygo_set;
|
||||
ygo_card_passcode -> ydk_deck_item;
|
||||
ygo_card_passcode -> constructed_deck_item;
|
||||
ygo_set -> ygo_set_item;
|
||||
ygo_set_item -> constructed_deck_item [ltail=cluster_2];
|
||||
|
||||
ydk_side -> 83011277 -> ygo_alternate_id -> ygo_card_passcode;
|
||||
variant_condition -> ygo_set_item;
|
||||
|
||||
// "Item 1" -> "Item 3" [ltail=cluster_0 lhead=cluster_1];
|
||||
start -> "Dragon Turbo";
|
||||
"Dragon Turbo" -> ydk_main [lhead=cluster_0];
|
||||
// ydk_main -> ydk [ltail=cluster_0];
|
||||
|
||||
constructed_deck_item_2 -> end;
|
||||
|
||||
start [shape=Mdiamond];
|
||||
end [shape=Msquare];
|
||||
}
|
||||
BIN
doc/flowcharts/constructed-deck-doc.png
Normal file
BIN
doc/flowcharts/constructed-deck-doc.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 116 KiB |
6
doc/label-maker.md
Normal file
6
doc/label-maker.md
Normal file
@ -0,0 +1,6 @@
|
||||
1. Download the [LabelMaker.csv](/public/LabelMaker.csv) template.
|
||||
2. **Import** Character Set: UTF-8; **Separator Options** Separated By: Comma.
|
||||
3. Edit the **Description**, **Price** and **Bar Code** columns.
|
||||
The **Label No.** column does nothing and is ignored.
|
||||
4. Be sure to save as a **CSV**!
|
||||
5. Upload your CSV. It will be available as labels.pdf.
|
||||
8
doc/release-checklist.org
Normal file
8
doc/release-checklist.org
Normal file
@ -0,0 +1,8 @@
|
||||
* Release Checklist
|
||||
|
||||
- [ ] make docker-build
|
||||
- [ ] make routes.org
|
||||
- [ ] make declt
|
||||
- [ ] make diagrams
|
||||
- [ ] make statusreport
|
||||
- [ ] make invoice
|
||||
190
doc/routes.org
Normal file
190
doc/routes.org
Normal file
@ -0,0 +1,190 @@
|
||||
* Resources
|
||||
|
||||
https://github.com/fukamachi/caveman/issues/112
|
||||
|
||||
* Static Pages
|
||||
|
||||
* Index
|
||||
#+BEGIN_SRC
|
||||
(defroute index "/" ()
|
||||
#+END_SRC
|
||||
|
||||
* About
|
||||
#+BEGIN_SRC
|
||||
(defroute "/about" ()
|
||||
#+END_SRC
|
||||
|
||||
* News
|
||||
#+BEGIN_SRC
|
||||
(defroute "/news" ()
|
||||
#+END_SRC
|
||||
|
||||
* TODO List
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/todo" :method :GET) ()
|
||||
#+END_SRC
|
||||
|
||||
* Markdown Viewer
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/markdown" :method :GET) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Documentation
|
||||
#+BEGIN_SRC
|
||||
(defroute doc "/doc" (&key |org|)
|
||||
#+END_SRC
|
||||
|
||||
* Simple Forms
|
||||
|
||||
* YDKs
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/ydk" :method :GET) ()
|
||||
(defroute ("/ydk" :method :POST) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Label Maker
|
||||
#+BEGIN_SRC
|
||||
GET /label-maker
|
||||
/label-maker/
|
||||
(defroute ("/label-maker" :method :POST) (&key _parsed)
|
||||
(defroute ("/label-maker" :method :GET) ()
|
||||
(defroute ("/label-maker/instructions" :method :GET) ()
|
||||
#+END_SRC
|
||||
|
||||
* QR Code
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/qr" :method :GET) ()
|
||||
(defroute ("/qr" :method :POST) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Register
|
||||
|
||||
* Contact
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/contact" :method :GET) ()
|
||||
(defroute ("/contact/admin" :method :GET) ()
|
||||
(defroute ("/contact" :method :DELETE) ()
|
||||
(defroute ("/contact/:id/delete" :method :DELETE) (&key id)
|
||||
(defroute ("/contact" :method :POST) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Attachments
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/upload" :method :GET) ()
|
||||
(defroute ("/upload" :method :POST) (&key _parsed)
|
||||
(defroute ("/upload/:id" :method :DELETE) (&key id)
|
||||
#+END_SRC
|
||||
|
||||
|
||||
* Cards
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/cards" :method :GET) (&key _parsed)
|
||||
(defroute ("/cards/search" :method :POST) (&key _parsed)
|
||||
(defroute ("/cards/:id/view" :method :GET) (&key id)
|
||||
(defroute ("/cards/ygo-set-items" :method :GET) (&key |set-id| |variant-id|)
|
||||
(defroute ("/cards/:id/image" :method :GET) (&key id)
|
||||
#+END_SRC
|
||||
|
||||
|
||||
* Categories
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/category/new-child" :method :POST) (&key _parsed)
|
||||
(defroute ("/category/explain" :method :GET) ()
|
||||
(defroute ("/category" :method :GET) (&key _parsed)
|
||||
(defroute ("/category/search" :method :POST) (&key _parsed)
|
||||
(defroute ("/category/:id/view" :method :GET) (&key id)
|
||||
(defroute ("/category/list" :method :GET) (&key _parsed)
|
||||
(defroute ("/category/:id/delete" :method :DELETE) (&key id)
|
||||
(defroute ("/category/:id/rename" :method :POST) (&key id _parsed)
|
||||
(defroute ("/category/fake-data" :method :GET) ()
|
||||
(defroute ("/category/new-parent" :method :POST) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Constructed Decks
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/construct" :method :GET) ()
|
||||
(defroute ("/construct/:id/view" :method :GET) (&key id)
|
||||
(defroute ("/construct/:id/view" :method :POST) (&key id _parsed)
|
||||
(defroute ("/construct/:id/select-sets" :method :GET) (&key id)
|
||||
#+END_SRC
|
||||
|
||||
* Deck Templates
|
||||
* Decks
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/decks/:id/view" :method :GET) (&key id)
|
||||
(defroute ("/decks/:id/generate-cover-images" :method :GET) (&key id)
|
||||
(defroute ("/decks/:id/delete-generated-images" :method :DELETE) (&key id)
|
||||
(defroute ("/decks/:id/to-category" :method :POST) (&key id _parsed)
|
||||
(defroute ("/decks/:id/rename" :method :POST) (&key id _parsed)
|
||||
(defroute ("/decks/:id/pull" :method :GET) (&key id)
|
||||
(defroute ("/decks/cards-in-decks" :method :GET) (&key _parsed)
|
||||
(defroute ("/decks/:id/name" :method :GET) (&key id)
|
||||
(defroute ("/decks/by-category/:id" :method :GET) (&key id _parsed)
|
||||
(defroute ("/decks/:id/html-listing" :method :GET) (&key id _parsed)
|
||||
(defroute ("/decks/:id/html-text-listing" :method :GET) (&key id _parsed)
|
||||
(defroute ("/decks/:id/text-listing" :method :GET) (&key id _parsed)
|
||||
(defroute ("/decks/:id/image-listing" :method :GET) (&key id _parsed)
|
||||
(defroute ("/decks/:id/delete" :method :DELETE) (&key id)
|
||||
(defroute ("/decks/search" :method :GET) (&key _parsed)
|
||||
(defroute ("/decks/search" :method :POST) (&key _parsed)
|
||||
(defroute ("/decks/deck-select" :method :GET) (&key |id|)
|
||||
(defroute ("/decks/category-select" :method :GET) (&key |deck-id| |category-id|)
|
||||
(defroute ("/decks/kde/:id" :method :GET) (&key id)
|
||||
(defroute ("/decks" :method :GET) (&key _parsed)
|
||||
#+END_SRC
|
||||
|
||||
* Users
|
||||
* Login
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/user/login" :method :GET) ()
|
||||
(defroute ("/user/login" :method :POST) (&key _parsed)
|
||||
(defroute "/user/logout" ()
|
||||
(defroute ("/user/register" :method :GET) ()
|
||||
(defroute ("/user/register" :method :POST) (&key _parsed)
|
||||
(defroute ("/user" :method :DELETE) (&key _parsed)
|
||||
(defroute ("/user/:id/roles" :method :GET) (&key id)
|
||||
(defroute ("/user/admin" :method :GET) ()
|
||||
(defroute ("/user" :method :GET) ()
|
||||
#+END_SRC
|
||||
|
||||
* Deck Builder
|
||||
#+BEGIN_SRC
|
||||
GET /builder
|
||||
POST /builder name= race= archetype= attribute= passcode=
|
||||
GET /builder/current-deck
|
||||
POST /builder/current-deck action=load id=N
|
||||
POST /builder/current-deck action=save
|
||||
POST /builder/current-deck action=clear
|
||||
POST /builder/current-deck action=rename name="New Name"
|
||||
|
||||
POST /builder/current-deck action=add deck=main,side,extra passcode=N
|
||||
POST /builder/current-deck action=remove deck=main,side,extra index=N
|
||||
|
||||
(defroute ("/builder/delete" :method :DELETE) (&key _parsed)
|
||||
|
||||
GET /builder/saved-categories id=N
|
||||
GET /builder/saved-decks
|
||||
#+END_SRC
|
||||
|
||||
* Inventory
|
||||
** TODO Multi Inventory
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/inventory/new" :method :POST) (&key _parsed)
|
||||
(defroute ("/inventory/import" :method :GET) ()
|
||||
(defroute ("/inventory/:id/edit" :method :GET) (&key id)
|
||||
(defroute ("/inventory/:id/edit" :method :POST) (&key id _parsed)
|
||||
(defroute ("/inventory/patch" :method :PATCH) (&key _parsed)
|
||||
(defroute ("/inventory/:id/delete" :method :DELETE) (&key id)
|
||||
(defroute ("/inventory/variants/:id" :method :GET) (&key id)
|
||||
(defroute ("/inventory" :method :GET) (&key _parsed)
|
||||
(defroute ("/inventory" :method :POST) (&key _parsed)
|
||||
(defroute ("/inventory/search" :method :POST) (&key _parsed)
|
||||
(defroute ("/inventory/new" :method :GET) ()
|
||||
#+END_SRC
|
||||
|
||||
* Workbench
|
||||
#+BEGIN_SRC
|
||||
(defroute ("/chat" :method :GET) ()
|
||||
(defroute ("/html" :method :GET) (&key |path|)
|
||||
(defroute ("/test" :method :GET) (&key _parsed)
|
||||
#+END_SRC
|
||||
33
doc/store/LabelMaker.csv
Normal file
33
doc/store/LabelMaker.csv
Normal file
@ -0,0 +1,33 @@
|
||||
Label No.,Description,Price,Bar Code
|
||||
1,Nice – Great – Good,$69.99,99988877766
|
||||
2,Nice – Great – Good,$79.99,99988877767
|
||||
3,Nice – Great – Good,$89.99,99988877768
|
||||
4,Nice – Great – Good,$99.99,99988877769
|
||||
5,Nice – Great – Good,$109.99,99988877716
|
||||
6,Nice – Great – Good,$119.99,99988877726
|
||||
7,Nice – Great – Good,$129.99,99988877736
|
||||
8,Nice – Great – Good,$139.99,99988877746
|
||||
9,Nice – Great – Good,$149.99,99988877756
|
||||
10,Nice – Great – Good,$159.99,99988876766
|
||||
11,Nice – Great – Good,$169.99,99988876766
|
||||
12,Nice – Great – Good,$179.99,99988873766
|
||||
13,Nice – Great – Good,$189.99,99988872766
|
||||
14,Nice – Great – Good,$199.99,99988871766
|
||||
15,Nice – Great – Good,$209.99,99988873766
|
||||
16,Nice – Great – Good,$219.99,99988872766
|
||||
17,Nice – Great – Good,$229.99,99988871766
|
||||
18,Nice – Great – Good,$239.99,97988877766
|
||||
19,Nice – Great – Good,$249.99,99888877766
|
||||
20,Nice – Great – Good,$259.99,99938877766
|
||||
21,Nice – Great – Good,$269.99,99982877766
|
||||
22,Nice – Great – Good,$279.99,99988277766
|
||||
23,Nice – Great – Good,$289.99,99988827766
|
||||
24,Nice – Great – Good,$299.99,99988872766
|
||||
25,Nice – Great – Good,$309.99,99988877266
|
||||
26,Nice – Great – Good,$319.99,99988877726
|
||||
27,Nice – Great – Good,$329.99,99988877766
|
||||
28,Nice – Great – Good,$339.99,19988877766
|
||||
29,Nice – Great – Good,$349.99,91988877766
|
||||
30,Nice – Great – Good,$359.99,99188877766
|
||||
31,Nice – Great – Good,$369.99,99918877766
|
||||
32,Nice – Great – Good,$379.99,99981877766
|
||||
|
227
doc/store/S-20247.pdf
Normal file
227
doc/store/S-20247.pdf
Normal file
File diff suppressed because one or more lines are too long
43
doc/store/S-20247.tpl.tex
Normal file
43
doc/store/S-20247.tpl.tex
Normal file
@ -0,0 +1,43 @@
|
||||
\documentclass{article}
|
||||
\usepackage{microtype}
|
||||
\usepackage[paper=letterpaper,layoutwidth=11in,layoutheight=8.5in,portrait]{geometry}
|
||||
\usepackage[newdimens]{labels}% let the package do the work...
|
||||
\usepackage{graphicx}
|
||||
\usepackage[scaled]{helvet}
|
||||
\usepackage[T1]{fontenc}
|
||||
\graphicspath{ {.} {/tmp/labels/} }
|
||||
\renewcommand\familydefault{\sfdefault}
|
||||
%
|
||||
\LabelGridtrue
|
||||
\LabelInfotrue
|
||||
%
|
||||
%\LabelGridfalse
|
||||
%\LabelInfofalse
|
||||
%
|
||||
\LabelCols=4
|
||||
\LabelRows=8
|
||||
%
|
||||
\LeftPageMargin=0.25in
|
||||
\RightPageMargin=0.25in
|
||||
\TopPageMargin=0.5in
|
||||
\BottomPageMargin=0.5in
|
||||
%
|
||||
\InterLabelColumn=0mm% adjust as required
|
||||
\InterLabelRow=0mm
|
||||
%
|
||||
\RightLabelBorder=1mm% adjust to taste
|
||||
\LeftLabelBorder=1mm
|
||||
\TopLabelBorder=6mm
|
||||
\BottomLabelBorder=1mm
|
||||
%
|
||||
\setlength{\baselineskip}{0pt}
|
||||
\setlength{\emergencystretch}{3em}
|
||||
\setlength{\lineskip}{0pt}
|
||||
\setlength{\parindent}{0pt}
|
||||
\setlength{\parskip}{0pt}
|
||||
\setlength{\tabcolsep}{0pt}
|
||||
%
|
||||
\numberoflabels=1% set to 1 when you fill in the individual labels - this will just repeat 1 instance 20 times to show the layout.
|
||||
%
|
||||
\begin{document}
|
||||
%
|
||||
59
doc/store/avery-5160.tex
Normal file
59
doc/store/avery-5160.tex
Normal file
@ -0,0 +1,59 @@
|
||||
\documentclass{article}
|
||||
%\usepackage[default]{comicneue}
|
||||
%\usepackage[sfdefault]{noto}
|
||||
\usepackage[scaled]{helvet}
|
||||
\usepackage[T1]{fontenc}
|
||||
\usepackage[T1]{fontenc}
|
||||
\usepackage[paper=letterpaper,layoutwidth=11in,layoutheight=8.5in,portrait]{geometry}
|
||||
\usepackage[newdimens]{labels}% let the package do the work...
|
||||
\usepackage{graphicx}
|
||||
\usepackage{ragged2e}
|
||||
\usepackage{microtype}
|
||||
\graphicspath{ {.} {/tmp/labels/} }
|
||||
\renewcommand\familydefault{\sfdefault}
|
||||
%
|
||||
\LabelGridtrue
|
||||
\LabelInfotrue
|
||||
%
|
||||
%\LabelGridfalse
|
||||
%\LabelInfofalse
|
||||
%
|
||||
\LabelCols=3
|
||||
\LabelRows=10
|
||||
%
|
||||
\LeftPageMargin=0.21975in
|
||||
\RightPageMargin=0.21975in
|
||||
\TopPageMargin=0.5in
|
||||
\BottomPageMargin=0.5in
|
||||
%
|
||||
\InterLabelColumn=0.14in % adjust as required
|
||||
\InterLabelRow=0mm
|
||||
%
|
||||
\RightLabelBorder=1mm% adjust to taste
|
||||
\LeftLabelBorder=1mm
|
||||
\TopLabelBorder=0.3in
|
||||
\BottomLabelBorder=1mm
|
||||
%
|
||||
\numberoflabels=30% set to 1 when you fill in the individual labels - this will just repeat 1 instance 20 times to show the layout.
|
||||
%
|
||||
\tolerance=9999
|
||||
\emergencystretch=10pt
|
||||
\hyphenpenalty=100000
|
||||
\exhyphenpenalty=100
|
||||
\setlength{\parskip}{0pt}
|
||||
\setlength{\lineskip}{0pt}
|
||||
\setlength{\baselineskip}{0pt}
|
||||
\fontdimen2\font=0pt
|
||||
%
|
||||
\begin{document}
|
||||
|
||||
\genericlabel{%
|
||||
\begin{minipage}{2in}% adjust as desired
|
||||
%{\scriptsize \textls[-60]{REALLY VERY LONG, REALLY, REALLY, REALLY, LONG, REALLY VERY LONG, REALLY, REALLY, REALLY, LONG, LONG LONG, PRODUCT NAME}} \vspace*{1pt} \\
|
||||
{\scriptsize \textls[-60]{{Hello World}}} \vspace*{1pt} \\
|
||||
\begin{tabular}{p{0.59\linewidth} p{0.41\linewidth}}
|
||||
{\Huge PRICE} & {\includegraphics[trim={0 0.5in 0 0.5in},clip,width=1in]{1}} \\
|
||||
\end{tabular}
|
||||
\end{minipage}}
|
||||
|
||||
\end{document}
|
||||
69
doc/todo.md
Normal file
69
doc/todo.md
Normal file
@ -0,0 +1,69 @@
|
||||
# Backend Changes
|
||||
- [Done] Abritrary drag and drop (e.g. from main deck -> extra deck)
|
||||
- [Done] optimum qty - cards in decks
|
||||
- [Done] The "Optimum Qty" is "The number of times the card appears in
|
||||
each deck (e.g. 3) times the number of decks it appears in times
|
||||
5". I think that's just SELECT COUNT(PASSCODE) ? And for
|
||||
constructed decks it would be the same.
|
||||
|
||||
- [In Progress] Constrcuted-Deck-Overview
|
||||
- [In Progress] Storing / Saving / Updating optimum Qty
|
||||
- [In Progress] Number in inventory of this card - what is this? The total SUM count from all YGO-SET-ITEMs?
|
||||
- [In Progress] Created / Sold status - I think this is done already...
|
||||
- [In Progress] Inverse Priority system (more cards = sell more, less cards = hold more)
|
||||
|
||||
- [ ] Arbitrary inventories (Secondary Inventory, ...)
|
||||
|
||||
# Categories
|
||||
|
||||
- [In Progress] Better UI
|
||||
- [ ] Show Decks from "subcategories" of current Category
|
||||
|
||||
# Database
|
||||
- [Done] Yu-Gi-Oh
|
||||
- [Not Implemented] Images from CrystalCommerce
|
||||
We just got API access too.
|
||||
|
||||
- [Not Implemented] Attach card image to specific card
|
||||
Nobody seemed to want to upload card images individiually.
|
||||
|
||||
- [Done] Qty of card: number of times card appears in decks x multiplier (default x1)
|
||||
This is implemented but it doesn't display on the web frontend.
|
||||
|
||||
- [ ] Pokemon
|
||||
- [ ] Magic
|
||||
|
||||
# Constructed Deck Overview
|
||||
|
||||
- [ ] TODO
|
||||
|
||||
# Inventory
|
||||
|
||||
We deleted the Crystal Commerce stuff. Maybe it will make a comeback.
|
||||
|
||||
# UI Improvements
|
||||
- [In progress] Many, many, many, subtle UI bugs...
|
||||
|
||||
- [ ] Deck-Overview shows:
|
||||
- [ ] constructed Decks based on this deck
|
||||
- [ ] sold decks
|
||||
- [ ] Use this information x a multiplier to construct "optimal qty." of cards to keep in stock.
|
||||
- [ ] Deck Builder Sub children category
|
||||
|
||||
# Other
|
||||
|
||||
- [ ] Constructed Deck Overview Panel
|
||||
- [ ] when its sold and how often it sells based on deck sells
|
||||
- [ ] Remove Category removes decks from category
|
||||
- [ ] Peronsalized decks via inventory qty
|
||||
- [ ] CC API for DB Connect
|
||||
- [ ] Output to text / CSV
|
||||
- [ ] Environment variable for translation WITH-LOCALE
|
||||
|
||||
# Not Implemented Yet
|
||||
- [ ] Import new stuff from Crystal Commerce on the Web UI
|
||||
- [ ] Export to CSV for TCGPlayer Card Sorting Machines
|
||||
- [ ] Sync with our App - TCG Machines? I looked into their stuff. It
|
||||
looks very proprietary. Perhaps I should take a look at it.
|
||||
|
||||
Check your notepad for notes
|
||||
27
doc/web/nginx/deck-builder
Normal file
27
doc/web/nginx/deck-builder
Normal file
@ -0,0 +1,27 @@
|
||||
server {
|
||||
listen [::]:80;
|
||||
listen 80;
|
||||
|
||||
server_name phntsm.ddns.net;
|
||||
|
||||
root /var/www/html;
|
||||
|
||||
location / {
|
||||
return 301 https://$host$request_uri;
|
||||
}
|
||||
|
||||
location /.well-known/acme-challenge/ {
|
||||
alias /var/www/challenges/;
|
||||
try_files $uri =404;
|
||||
}
|
||||
|
||||
location ~ /\.ht {
|
||||
deny all;
|
||||
}
|
||||
|
||||
location /nginx_status {
|
||||
stub_status;
|
||||
allow 127.0.0.1; #only allow requests from localhost
|
||||
deny all; #deny all other hosts
|
||||
}
|
||||
}
|
||||
122
doc/web/nginx/deck-builder-tls
Normal file
122
doc/web/nginx/deck-builder-tls
Normal file
@ -0,0 +1,122 @@
|
||||
server {
|
||||
listen [::]:443 default_server ssl;
|
||||
listen 443 default_server ssl;
|
||||
|
||||
server_name phntsm.ddns.net;
|
||||
|
||||
ssl_certificate "/etc/ssl/nginx/phntsm.ddns.net.crt";
|
||||
ssl_certificate_key "/etc/ssl/nginx/phntsm.ddns.net.key";
|
||||
ssl_dhparam "/etc/ssl/nginx/phntsm.ddns.net.dhparam";
|
||||
|
||||
ssl_session_timeout 5m;
|
||||
ssl_protocols TLSv1.2;
|
||||
ssl_ciphers ECDHE-RSA-AES256-GCM-SHA384:ECDHE-RSA-AES128-GCM-SHA256:DHE-RSA-AES256-GCM-SHA384;
|
||||
ssl_session_cache shared:SSL:50m;
|
||||
ssl_prefer_server_ciphers on;
|
||||
|
||||
root /var/www/html;
|
||||
index index.html;
|
||||
|
||||
location / {
|
||||
# First attempt to serve request as file, then
|
||||
# as directory, then fall back to displaying a 404.
|
||||
# try_files $uri $uri/ =404;
|
||||
|
||||
set_real_ip_from unix:;
|
||||
real_ip_header X-Forwarded-For;
|
||||
real_ip_recursive on;
|
||||
|
||||
client_max_body_size 8m;
|
||||
#auth_basic "Restricted Content";
|
||||
#auth_basic_user_file /etc/nginx/.htpasswd;
|
||||
|
||||
proxy_read_timeout 300;
|
||||
proxy_connect_timeout 300;
|
||||
proxy_send_timeout 300;
|
||||
fastcgi_read_timeout 300;
|
||||
|
||||
proxy_pass http://127.0.0.1:5005;
|
||||
include /etc/nginx/fastcgi_params;
|
||||
include /etc/nginx/proxy_params;
|
||||
}
|
||||
|
||||
# /~user web directories
|
||||
location ~ ^/~(.+?)(/.*)?$ {
|
||||
alias /home/$1/www$2;
|
||||
index index.html index.htm;
|
||||
autoindex on;
|
||||
}
|
||||
|
||||
# location /_/static/assets/ {
|
||||
# alias /home/git/public/;
|
||||
# }
|
||||
|
||||
location /git/ {
|
||||
auth_basic "Restricted Content";
|
||||
auth_basic_user_file /etc/nginx/.htpasswd;
|
||||
|
||||
proxy_read_timeout 300;
|
||||
proxy_connect_timeout 300;
|
||||
proxy_send_timeout 300;
|
||||
fastcgi_read_timeout 300;
|
||||
|
||||
client_max_body_size 512M;
|
||||
# make nginx use unescaped URI, keep "%2F" as is
|
||||
rewrite ^ $request_uri;
|
||||
rewrite ^/git(/.*) $1 break;
|
||||
proxy_pass http://127.0.0.1:3000$uri;
|
||||
include /etc/nginx/fastcgi_params;
|
||||
include /etc/nginx/proxy_params;
|
||||
}
|
||||
|
||||
location ~ /collectd/ {
|
||||
gzip off;
|
||||
root /home/user/code/alpine-collectd-web;
|
||||
|
||||
auth_basic "Restricted Content";
|
||||
auth_basic_user_file /etc/nginx/.htpasswd;
|
||||
|
||||
proxy_read_timeout 300;
|
||||
proxy_connect_timeout 300;
|
||||
proxy_send_timeout 300;
|
||||
fastcgi_read_timeout 300;
|
||||
|
||||
#proxy_http_version 1.1;
|
||||
rewrite ^/collectd/(.*) /$1 break;
|
||||
proxy_pass http://127.0.0.1:8888;
|
||||
}
|
||||
|
||||
location ~ /psy/ {
|
||||
auth_basic "Restricted Content";
|
||||
auth_basic_user_file /etc/nginx/.htpasswd;
|
||||
|
||||
proxy_read_timeout 300;
|
||||
proxy_connect_timeout 300;
|
||||
proxy_send_timeout 300;
|
||||
fastcgi_read_timeout 300;
|
||||
|
||||
#proxy_http_version 1.1;
|
||||
# rewrite ^/psy/(.*) /$1 break;
|
||||
include /etc/nginx/proxy_params;
|
||||
proxy_pass http://127.0.0.1:9292;
|
||||
}
|
||||
|
||||
# location ~ \.php$ {
|
||||
# include /etc/nginx/fastcgi_params;
|
||||
# include /etc/nginx/proxy_params;
|
||||
# fastcgi_param SCRIPT_FILENAME $document_root$fastcgi_script_name;
|
||||
# # fastcgi_pass unix:/var/run/php/php7.4-fpm.sock;
|
||||
# fastcgi_pass unix:/var/run/php/php-fpm.sock;
|
||||
# }
|
||||
|
||||
# location ~ /phpmyadmin/ {
|
||||
# auth_basic "Restricted Content";
|
||||
# auth_basic_user_file /etc/nginx/.htpasswd;
|
||||
# index index.php;
|
||||
# }
|
||||
|
||||
location ~ /\.ht {
|
||||
deny all;
|
||||
}
|
||||
|
||||
}
|
||||
91
doc/web/nginx/default
Normal file
91
doc/web/nginx/default
Normal file
@ -0,0 +1,91 @@
|
||||
##
|
||||
# You should look at the following URL's in order to grasp a solid understanding
|
||||
# of Nginx configuration files in order to fully unleash the power of Nginx.
|
||||
# https://www.nginx.com/resources/wiki/start/
|
||||
# https://www.nginx.com/resources/wiki/start/topics/tutorials/config_pitfalls/
|
||||
# https://wiki.debian.org/Nginx/DirectoryStructure
|
||||
#
|
||||
# In most cases, administrators will remove this file from sites-enabled/ and
|
||||
# leave it as reference inside of sites-available where it will continue to be
|
||||
# updated by the nginx packaging team.
|
||||
#
|
||||
# This file will automatically load configuration files provided by other
|
||||
# applications, such as Drupal or Wordpress. These applications will be made
|
||||
# available underneath a path with that package name, such as /drupal8.
|
||||
#
|
||||
# Please see /usr/share/doc/nginx-doc/examples/ for more detailed examples.
|
||||
##
|
||||
|
||||
# Default server configuration
|
||||
#
|
||||
server {
|
||||
listen 80 default_server;
|
||||
listen [::]:80 default_server;
|
||||
|
||||
# SSL configuration
|
||||
#
|
||||
# listen 443 ssl default_server;
|
||||
# listen [::]:443 ssl default_server;
|
||||
#
|
||||
# Note: You should disable gzip for SSL traffic.
|
||||
# See: https://bugs.debian.org/773332
|
||||
#
|
||||
# Read up on ssl_ciphers to ensure a secure configuration.
|
||||
# See: https://bugs.debian.org/765782
|
||||
#
|
||||
# Self signed certs generated by the ssl-cert package
|
||||
# Don't use them in a production server!
|
||||
#
|
||||
# include snippets/snakeoil.conf;
|
||||
|
||||
root /var/www/html;
|
||||
|
||||
# Add index.php to the list if you are using PHP
|
||||
index index.html index.htm index.nginx-debian.html;
|
||||
|
||||
server_name _;
|
||||
|
||||
location / {
|
||||
# First attempt to serve request as file, then
|
||||
# as directory, then fall back to displaying a 404.
|
||||
try_files $uri $uri/ =404;
|
||||
}
|
||||
|
||||
# pass PHP scripts to FastCGI server
|
||||
#
|
||||
#location ~ \.php$ {
|
||||
# include snippets/fastcgi-php.conf;
|
||||
#
|
||||
# # With php-fpm (or other unix sockets):
|
||||
# fastcgi_pass unix:/run/php/php7.4-fpm.sock;
|
||||
# # With php-cgi (or other tcp sockets):
|
||||
# fastcgi_pass 127.0.0.1:9000;
|
||||
#}
|
||||
|
||||
# deny access to .htaccess files, if Apache's document root
|
||||
# concurs with nginx's one
|
||||
#
|
||||
#location ~ /\.ht {
|
||||
# deny all;
|
||||
#}
|
||||
}
|
||||
|
||||
|
||||
# Virtual Host configuration for example.com
|
||||
#
|
||||
# You can move that to a different file under sites-available/ and symlink that
|
||||
# to sites-enabled/ to enable it.
|
||||
#
|
||||
#server {
|
||||
# listen 80;
|
||||
# listen [::]:80;
|
||||
#
|
||||
# server_name example.com;
|
||||
#
|
||||
# root /var/www/example.com;
|
||||
# index index.html;
|
||||
#
|
||||
# location / {
|
||||
# try_files $uri $uri/ =404;
|
||||
# }
|
||||
#}
|
||||
55
doc/wiki.org
Normal file
55
doc/wiki.org
Normal file
@ -0,0 +1,55 @@
|
||||
#+TITLE: Wiki KB
|
||||
|
||||
* Abbreviations
|
||||
|
||||
- CG :: Card Game
|
||||
- TCG :: Trading Card Game
|
||||
- OCG :: Official Card Game
|
||||
|
||||
* Links
|
||||
|
||||
** Reference
|
||||
- [[http://cheat.markdunkley.com/][Liquid Cheat Sheet]]
|
||||
- [[https://challonge.com/pricing][Challonge]]
|
||||
- [[https://decks.tcgplayer.com/magic][TCGPlayer Deck Builder - MTG]]
|
||||
- [[https://jqlang.github.io/jq/tutorial/][JQ Tutorial]]
|
||||
- [[https://keyrune.andrewgioia.com][Keyrune Magic: the Gathering set symbol font]]
|
||||
- [[https://lisptips.com/post/11728375873/initform-and-default-initargs][:initform and :default-initargs]]
|
||||
- [[https://npm.io/package/ydke][ydke]]
|
||||
- [[https://scryfall.com/docs/api][Scryfall is a powerful Magic: The Gathering card search]]
|
||||
- [[https://www.db.yugioh-card.com/yugiohdb/][Konami Yu-Gi-Oh! DB]]
|
||||
- [[https://www.masterduelmeta.com/][Master Duel Meta]]
|
||||
- [[https://www.noip.com/integrate/request][No-IP Dynamic DNS Support]]
|
||||
- [[https://www.sqlite.org/lang_analyze.html]]
|
||||
- [[https://www.toptal.com/designers/htmlarrows/][HTML Arrows]]
|
||||
- [[https://yugioh.fandom.com/wiki/Template:Rarities][Template:Rarities]]
|
||||
- [[https://yugipedia.com/wiki/][Yugipedia]]
|
||||
- [[https://www.db.yugioh-card.com/yugiohdb/forbidden_limited.action][Forbidden / Limited List]]
|
||||
- [[https://www.youtube.com/watch?v=sy7dtW8CvQ4][How Do MTG Card Sorting Machines Compare?]]
|
||||
|
||||
*** Might Be Useful
|
||||
- [[https://dev.pokemontcg.io/][PokemonTCG API Dev Portal]]
|
||||
- [[https://github.com/FelixRilling/yugioh-deck-tool][Yu-Gi-Oh! Deck Tool]]
|
||||
- https://github.com/AccelerationNet/function-cache
|
||||
- https://github.com/OpenBookStore/openbookstore
|
||||
- https://github.com/lispnik/iup
|
||||
- https://github.com/mmontone/sxql-composer
|
||||
|
||||
** Fun
|
||||
- [[https://ygopro.org/yugioh-card-maker/][Custom Yu-Gi-Oh Card Maker]]
|
||||
- [[https://pokecardmaker.net/creator][Custom Pokémon Card Creator]]
|
||||
- [[https://www.duelingbook.com/][Dueling Book]]
|
||||
- [[https://gimp-tools.sourceforge.net/tools.shtml][Ofnuts' Gimp Tools]]
|
||||
- [[https://www.deviantart.com/teufik2305/art/Yu-Gi-Oh-Playmat-60x35cm-with-Labeled-Zones-853628853][Yu-Gi-Oh! Playmat with Labeled Zones]]
|
||||
- [[https://www.metamats.com/1-player-templates][1 Player Templates - Metamats]]
|
||||
- [[https://images.squarespace-cdn.com/content/v1/58f293311b631b9852e71d4b/1591657147889-DOEJSUD8UN7KZ61YPYNQ/1Player+Zones-01.png?format=2500w]]
|
||||
- [[https://images.squarespace-cdn.com/content/v1/58f293311b631b9852e71d4b/1591657047085-J5LQ9ABPX7HJQZD9DDEZ/1player+zones+Transparent-01-01.png?format=2500w]]
|
||||
|
||||
** Tools
|
||||
|
||||
- [[https://dnschecker.org/all-dns-records-of-domain.php][DNS Checker]]
|
||||
- [[https://gitlab.com/fisxoj/sly-docker-poc/-/tree/master]]
|
||||
- [[https://www.freecodecamp.org/news/rest-api-design-best-practices-build-a-rest-api/]]
|
||||
- [[https://restfulapi.net/rest-api-design-tutorial-with-example/]]
|
||||
- [[https://stackoverflow.com/a/34001943][multiple javascript queryselectors conditions]]
|
||||
- [[https://dba.stackexchange.com/questions/89051/stored-procedure-to-update-an-adjacency-model-to-nested-sets-model]]
|
||||
50
doc/workflow.md
Normal file
50
doc/workflow.md
Normal file
@ -0,0 +1,50 @@
|
||||
# Workflow Design Doc
|
||||
|
||||
## Overview
|
||||
|
||||
The workflow for constructing decks is as follows:
|
||||
|
||||
1. Create deck of cards. Currently we select from all cards. Maybe we
|
||||
should just select cards from inventory. The majority of this
|
||||
functionality in place and isn't expected to change. A deck will
|
||||
always just be a list of cards plus metadata.
|
||||
|
||||
2. The deck of cards has metadata about author, name of deck, time of
|
||||
creation. The main content of the deck is three lists, comprising
|
||||
the main, extra, and side decks. This information is not expected
|
||||
to change in the future. Decks created by a particular user for
|
||||
example. The underlying metadata representation is what's being
|
||||
worked on. Currently each item in the database has all information
|
||||
duplicated from the rest of the database. Changing the price for
|
||||
one card changes the price for only that one card matching that row
|
||||
in the database. There will be additional tables to store pricing
|
||||
information in the next step.
|
||||
|
||||
3. On the Deck Overview page, selecting "Pull Deck" will decrease the
|
||||
inventory of the lowest priced card in inventory by one for every
|
||||
card in the deck. This is like "add to cart" in an online shopping
|
||||
platform, with additional inventory keeping. This is analagous to
|
||||
the deck construction step, except instead of selecting cards to be
|
||||
put into a deck, that information is provided a priori, and we use
|
||||
that list of information to construct secondary lists.
|
||||
|
||||
4. On the pulled deck page, for every card in the deck, you will be
|
||||
able to select cards by edition, condition, and rarity of every
|
||||
card in the inventory matching that card's passcode. I can
|
||||
conceive a very simple concept where you attempt to check out, and
|
||||
then are returned with error messages saying which items had
|
||||
errors. This is the current approach.
|
||||
|
||||
5. There will be an intermediate stage. Once there is enough inventory
|
||||
and the deck is "pulled" it will enter an area where each
|
||||
individual card will be selected. e.g. selecting the rarity or set
|
||||
of a particular card in each deck.
|
||||
|
||||
6. Once all "errors" are resolved (banlists, constraings, etc), the
|
||||
"pulled" deck will allow you to "construct" it, which will finalize
|
||||
the state of this pulled deck in the database, moving it to another
|
||||
table, the list of decks for sale.
|
||||
|
||||
7. The list of decks for sale is just pulled, constructed decks with
|
||||
pricing information attached and whether or not it was sold and
|
||||
what price it was sold at and when.
|
||||
149
doc/ygoprodeck-import.md
Normal file
149
doc/ygoprodeck-import.md
Normal file
@ -0,0 +1,149 @@
|
||||
# Introduction
|
||||
|
||||
The [Yu-Gi-Oh! API by YGOPRODeck](https://ygoprodeck.com/api-guide/) provides the following information.
|
||||
|
||||
# Data
|
||||
|
||||
The base data for cards. This is always returned, without asking for `?misc=Yes`.
|
||||
|
||||
JSON Node Name: `data`
|
||||
|
||||
## All Cards
|
||||
|
||||
Every card has these attributes.
|
||||
|
||||
- `id`: Passcode on the bottom left of the card.
|
||||
- `desc`: Card description / effect text.
|
||||
- `frameType`: The backdrop type that this card uses (normal, effect, synchro, spell, trap, etc.).
|
||||
- `name`: Name of the card.
|
||||
- `type`: The type of card you are viewing (Normal Monster, Effect Monster, Synchro Monster, Spell Card, Trap Card, etc.).
|
||||
|
||||
## Monster Cards
|
||||
|
||||
Cards that attack or defende have ATK and DEF. E.g. Spell and Trap do
|
||||
not have these attributes, except Race. The Race of a Spell card is
|
||||
"Spell" and the Race of a trap card is "Trap".
|
||||
|
||||
- `atk`: The ATK value of the card.
|
||||
- `attribute`: The attribute of the card.
|
||||
- `def`: The DEF value of the card.
|
||||
- `level`: The Level/RANK of the card.
|
||||
- `race`: The card race which is officially called type (Spellcaster, Warrior, Insect, etc).
|
||||
|
||||
## Spell/Trap Cards
|
||||
|
||||
- `race`: The card race which is officially called type for Spell/Trap Cards (Field, Equip, Counter, etc).
|
||||
|
||||
## Card Archetype
|
||||
|
||||
- `archetype`: The Archetype that the card belongs to. Alan takes
|
||||
feedback on Archetypes
|
||||
[here](https://github.com/AlanOC91/YGOPRODeck/issues/10).
|
||||
|
||||
## Additional Response for Pendulum Monsters
|
||||
|
||||
- `scale`: The Pendulum Scale Value.
|
||||
|
||||
## Additional Response for Link Monsters
|
||||
|
||||
- `linkval`: The Link Value of the card if it's of type "Link Monster".
|
||||
- `linkmarkers`: The Link Markers of the card if it's of type "Link Monster". This information is returned as an array.
|
||||
|
||||
# Set Info
|
||||
|
||||
JSON Node Name: `data.card_sets`
|
||||
|
||||
Fields:
|
||||
|
||||
- `set_code`
|
||||
- `set_name`
|
||||
- `set_price`
|
||||
- `set_rarity`
|
||||
- `set_rarity_code`
|
||||
|
||||
# Images
|
||||
|
||||
JSON Node Name: `data.card_images`
|
||||
|
||||
Fields:
|
||||
|
||||
- `image_url`
|
||||
- `image_url_cropped`
|
||||
- `image_url_small`
|
||||
|
||||
# Pricing
|
||||
|
||||
JSON Node Name: `data.card_prices`
|
||||
|
||||
Fields:
|
||||
|
||||
- `amazon_price`
|
||||
- `cardmarket_price`
|
||||
- `coolstuffinc_price`
|
||||
- `ebay_price`
|
||||
- `tcgplayer_price`
|
||||
|
||||
# `misc_info`
|
||||
|
||||
JSON Node Name: `data.misc_info`
|
||||
|
||||
Fields:
|
||||
|
||||
- `beta_id`
|
||||
- `beta_name`
|
||||
- `downvotes`
|
||||
- `has_effect`
|
||||
- `konami_id`
|
||||
- `misc_info`
|
||||
- `ocg_date`
|
||||
- `question_atk`
|
||||
- `question_def`
|
||||
- `staple`
|
||||
- `tcg_date`
|
||||
- `treated_as`
|
||||
- `upvotes`
|
||||
- `views`
|
||||
- `viewsweek`
|
||||
|
||||
[Using &misc=yes will now show question_atk and/or question_def to be 1 for true if a card is found to have a ? in the data.]
|
||||
(https://github.com/AlanOC91/YGOPRODeck/issues/152#issuecomment-1032552854)
|
||||
|
||||
## Banlist Info
|
||||
|
||||
JSON Node Name: `data.misc_info.banlist_info`
|
||||
|
||||
Fields:
|
||||
|
||||
- `ban_goat`
|
||||
- `ban_ocg`
|
||||
- `ban_tcg`
|
||||
|
||||
## Formats
|
||||
|
||||
JSON Node Name: `data.misc_info.formats`
|
||||
|
||||
Values:
|
||||
|
||||
- `Common Charity`
|
||||
- `Duel Links`
|
||||
- `Edison`
|
||||
- `GOAT`
|
||||
- `OCG`
|
||||
- `OCG GOAT`
|
||||
- `Speed Duel`
|
||||
- `TCG`
|
||||
|
||||
## Link Markers
|
||||
|
||||
JSON Node Name: `data.misc_info.linkmarkers`
|
||||
|
||||
Values:
|
||||
|
||||
- `Top`
|
||||
- `Top-Right`
|
||||
- `Right`
|
||||
- `Bottom-Right`
|
||||
- `Bottom`
|
||||
- `Bottom-Left`
|
||||
- `Left`
|
||||
- `Top-Left`
|
||||
BIN
locale/en_US/LC_MESSAGES/cl-deck-builder2.mo
Normal file
BIN
locale/en_US/LC_MESSAGES/cl-deck-builder2.mo
Normal file
Binary file not shown.
242
locale/en_US/LC_MESSAGES/cl-deck-builder2.po
Normal file
242
locale/en_US/LC_MESSAGES/cl-deck-builder2.po
Normal file
@ -0,0 +1,242 @@
|
||||
#: templates/builder/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck Builder"
|
||||
msgstr ""
|
||||
|
||||
#: templates/construct/select-sets.html
|
||||
#, lisp-format
|
||||
msgid "Select Card Sets"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Nothing to see here!"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Oops"
|
||||
msgstr "Oops"
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Feedback Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Try typing it up in Notepad, then Copy/Paste."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid ""
|
||||
"You can type up a message here and submit it for the administrator to see."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Contact Us"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/_field_control_select.html
|
||||
#, lisp-format
|
||||
msgid "None"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck List"
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, fuzzy, lisp-format
|
||||
msgid "Click the links at the top to get started."
|
||||
msgstr "Click the links in the sidebar to get started."
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Welcome to cl-deck-builder2!"
|
||||
msgstr "Welcome to cl-deck-builder2!"
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Index"
|
||||
msgstr "Index"
|
||||
|
||||
#: templates/kde-team.html
|
||||
#, lisp-format
|
||||
msgid "KDE Team Deck Listing"
|
||||
msgstr ""
|
||||
|
||||
#: templates/label-maker.html
|
||||
#, lisp-format
|
||||
msgid "Label Maker"
|
||||
msgstr ""
|
||||
|
||||
#: templates/qr.html
|
||||
#, lisp-format
|
||||
msgid "QR Code Generator"
|
||||
msgstr ""
|
||||
|
||||
#: templates/tabs.html
|
||||
#, lisp-format
|
||||
msgid "Tabs"
|
||||
msgstr ""
|
||||
|
||||
#: templates/upload.html
|
||||
#, lisp-format
|
||||
msgid "File Uploader"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/admin.html
|
||||
#, lisp-format
|
||||
msgid "User Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/login.html
|
||||
#, lisp-format
|
||||
msgid "Login"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/register.html
|
||||
#, lisp-format
|
||||
msgid "Register"
|
||||
msgstr ""
|
||||
|
||||
# English translations for cl-deck-builder package.
|
||||
# Copyright (C) 2023 THE cl-deck-builder'S COPYRIGHT HOLDER
|
||||
# This file is distributed under the same license as the cl-deck-builder package.
|
||||
# Automatically generated, 2023.
|
||||
#
|
||||
msgid ""
|
||||
msgstr ""
|
||||
"Project-Id-Version: cl-deck-builder 2\n"
|
||||
"Report-Msgid-Bugs-To: \n"
|
||||
"POT-Creation-Date: 2023-10-10 19:17+0000\n"
|
||||
"PO-Revision-Date: 2023-09-20 23:11+0000\n"
|
||||
"Last-Translator: Automatically generated\n"
|
||||
"Language-Team: none\n"
|
||||
"Language: en_US\n"
|
||||
"MIME-Version: 1.0\n"
|
||||
"Content-Type: text/plain; charset=ISO-8859-1\n"
|
||||
"Content-Transfer-Encoding: 8bit\n"
|
||||
"Plural-Forms: nplurals=2; plural=(n != 1);\n"
|
||||
|
||||
#: src/i18n.lisp:60
|
||||
msgid "Please login to continue"
|
||||
msgstr "Please login to continue"
|
||||
|
||||
#: src/web/upload.lisp:67
|
||||
#, lisp-format
|
||||
msgid "Upload success! <a href=\"~a\">~a</a>"
|
||||
msgstr "Upload success! <a href=\"~a\">~a</a>"
|
||||
|
||||
#: src/web/upload.lisp:70
|
||||
msgid "Error uploading file. Try again?"
|
||||
msgstr "Error uploading file. Try again?"
|
||||
|
||||
#: src/web/upload.lisp:85
|
||||
#, lisp-format
|
||||
msgid "No such attachment #~d"
|
||||
msgstr "No such attachment #~d"
|
||||
|
||||
#: src/web/contact.lisp:45
|
||||
msgid "Feedback cleared."
|
||||
msgstr "Feedback cleared."
|
||||
|
||||
#: src/web/contact.lisp:47 src/web/contact.lisp:72 src/web/qr.lisp:38
|
||||
#: src/web/ydk.lisp:14 src/web/ydk.lisp:25 src/web/decks.lisp:121
|
||||
#: src/web/decks.lisp:138 src/web/label-maker.lisp:125 src/web/user.lisp:79
|
||||
#: src/web/user.lisp:83
|
||||
msgid "Something went wrong. Try again?"
|
||||
msgstr "Something went wrong. Try again?"
|
||||
|
||||
#: src/web/contact.lisp:71
|
||||
msgid "Thanks! We got your message."
|
||||
msgstr "Thanks! We got your message."
|
||||
|
||||
#: src/web/category.lisp:65 src/web/decks.lisp:137
|
||||
msgid "Success!"
|
||||
msgstr "Success!"
|
||||
|
||||
#: src/web/builder.lisp:220
|
||||
#, lisp-format
|
||||
msgid "Deck ~a already exists in database; loading..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:224
|
||||
#, lisp-format
|
||||
msgid "Creating deck ~a into database."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:279
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); loading...~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:298
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); renaming to ~a.~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:64
|
||||
msgid "Nothing to see here..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:242
|
||||
msgid "No Name"
|
||||
msgstr "No Name"
|
||||
|
||||
#: src/web/decks.lisp:290
|
||||
#, lisp-format
|
||||
msgid "Deck ~a deleted success!"
|
||||
msgstr "Deck ~a deleted success!"
|
||||
|
||||
#: src/web/toolkit.lisp:29
|
||||
msgid "Please log in."
|
||||
msgstr "Please log in."
|
||||
|
||||
#: src/web/label-maker.lisp:108
|
||||
msgid "No files."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/label-maker.lisp:122
|
||||
#, lisp-format
|
||||
msgid "Success! Download link: <a href=\"/public/~a.pdf\">labels.pdf</a>"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:23
|
||||
#, fuzzy, lisp-format
|
||||
msgid "You are already logged in as: ~a"
|
||||
msgstr "You aren't logged in."
|
||||
|
||||
#: src/web/user.lisp:29
|
||||
msgid "A user with that email is already registered."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:43
|
||||
#, lisp-format
|
||||
msgid "Hello, ~a!"
|
||||
msgstr "Hello, ~a!"
|
||||
|
||||
#: src/web/user.lisp:47
|
||||
msgid "Incorrect password."
|
||||
msgstr "Incorrect password."
|
||||
|
||||
#: src/web/user.lisp:50
|
||||
msgid "No user corresponding to this email address."
|
||||
msgstr "No user corresponding to this email address."
|
||||
|
||||
#: src/web/user.lisp:76
|
||||
#, fuzzy
|
||||
msgid "Success! Please log in."
|
||||
msgstr "Please log in."
|
||||
|
||||
#: src/web/user.lisp:123
|
||||
msgid "Logged out."
|
||||
msgstr "Logged out."
|
||||
|
||||
#: src/web/user.lisp:124
|
||||
msgid "You aren't logged in."
|
||||
msgstr "You aren't logged in."
|
||||
0
locale/templates/LC_MESSAGES/.gitignore
vendored
Normal file
0
locale/templates/LC_MESSAGES/.gitignore
vendored
Normal file
241
locale/templates/LC_MESSAGES/cl-deck-builder2.pot
Normal file
241
locale/templates/LC_MESSAGES/cl-deck-builder2.pot
Normal file
@ -0,0 +1,241 @@
|
||||
#: templates/builder/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck Builder"
|
||||
msgstr ""
|
||||
|
||||
#: templates/construct/select-sets.html
|
||||
#, lisp-format
|
||||
msgid "Select Card Sets"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Nothing to see here!"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Oops"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Feedback Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Try typing it up in Notepad, then Copy/Paste."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid ""
|
||||
"You can type up a message here and submit it for the administrator to see."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Contact Us"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/_field_control_select.html
|
||||
#, lisp-format
|
||||
msgid "None"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck List"
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Click the links at the top to get started."
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Welcome to cl-deck-builder2!"
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Index"
|
||||
msgstr ""
|
||||
|
||||
#: templates/kde-team.html
|
||||
#, lisp-format
|
||||
msgid "KDE Team Deck Listing"
|
||||
msgstr ""
|
||||
|
||||
#: templates/label-maker.html
|
||||
#, lisp-format
|
||||
msgid "Label Maker"
|
||||
msgstr ""
|
||||
|
||||
#: templates/qr.html
|
||||
#, lisp-format
|
||||
msgid "QR Code Generator"
|
||||
msgstr ""
|
||||
|
||||
#: templates/tabs.html
|
||||
#, lisp-format
|
||||
msgid "Tabs"
|
||||
msgstr ""
|
||||
|
||||
#: templates/upload.html
|
||||
#, lisp-format
|
||||
msgid "File Uploader"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/admin.html
|
||||
#, lisp-format
|
||||
msgid "User Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/login.html
|
||||
#, lisp-format
|
||||
msgid "Login"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/register.html
|
||||
#, lisp-format
|
||||
msgid "Register"
|
||||
msgstr ""
|
||||
|
||||
# SOME DESCRIPTIVE TITLE.
|
||||
# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER
|
||||
# This file is distributed under the same license as the PACKAGE package.
|
||||
# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
|
||||
#
|
||||
#, fuzzy
|
||||
msgid ""
|
||||
msgstr ""
|
||||
"Project-Id-Version: PACKAGE VERSION\n"
|
||||
"Report-Msgid-Bugs-To: \n"
|
||||
"POT-Creation-Date: 2023-10-10 19:17+0000\n"
|
||||
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
|
||||
"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
|
||||
"Language-Team: LANGUAGE <LL@li.org>\n"
|
||||
"Language: \n"
|
||||
"MIME-Version: 1.0\n"
|
||||
"Content-Type: text/plain; charset=CHARSET\n"
|
||||
"Content-Transfer-Encoding: 8bit\n"
|
||||
|
||||
#: src/i18n.lisp:60
|
||||
msgid "Please login to continue"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:67
|
||||
#, lisp-format
|
||||
msgid "Upload success! <a href=\"~a\">~a</a>"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:70
|
||||
msgid "Error uploading file. Try again?"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:85
|
||||
#, lisp-format
|
||||
msgid "No such attachment #~d"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:45
|
||||
msgid "Feedback cleared."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:47 src/web/contact.lisp:72 src/web/qr.lisp:38
|
||||
#: src/web/ydk.lisp:14 src/web/ydk.lisp:25 src/web/decks.lisp:121
|
||||
#: src/web/decks.lisp:138 src/web/label-maker.lisp:125 src/web/user.lisp:79
|
||||
#: src/web/user.lisp:83
|
||||
msgid "Something went wrong. Try again?"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:71
|
||||
msgid "Thanks! We got your message."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/category.lisp:65 src/web/decks.lisp:137
|
||||
msgid "Success!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:220
|
||||
#, lisp-format
|
||||
msgid "Deck ~a already exists in database; loading..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:224
|
||||
#, lisp-format
|
||||
msgid "Creating deck ~a into database."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:279
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); loading...~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:298
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); renaming to ~a.~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:64
|
||||
msgid "Nothing to see here..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:242
|
||||
msgid "No Name"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:290
|
||||
#, lisp-format
|
||||
msgid "Deck ~a deleted success!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/toolkit.lisp:29
|
||||
msgid "Please log in."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/label-maker.lisp:108
|
||||
msgid "No files."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/label-maker.lisp:122
|
||||
#, lisp-format
|
||||
msgid "Success! Download link: <a href=\"/public/~a.pdf\">labels.pdf</a>"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:23
|
||||
#, lisp-format
|
||||
msgid "You are already logged in as: ~a"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:29
|
||||
msgid "A user with that email is already registered."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:43
|
||||
#, lisp-format
|
||||
msgid "Hello, ~a!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:47
|
||||
msgid "Incorrect password."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:50
|
||||
msgid "No user corresponding to this email address."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:76
|
||||
msgid "Success! Please log in."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:123
|
||||
msgid "Logged out."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:124
|
||||
msgid "You aren't logged in."
|
||||
msgstr ""
|
||||
105
locale/templates/LC_MESSAGES/djula.pot
Normal file
105
locale/templates/LC_MESSAGES/djula.pot
Normal file
@ -0,0 +1,105 @@
|
||||
|
||||
#: templates/builder/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck Builder"
|
||||
msgstr ""
|
||||
|
||||
#: templates/construct/select-sets.html
|
||||
#, lisp-format
|
||||
msgid "Select Card Sets"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Nothing to see here!"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Oops"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/admin.html
|
||||
#, lisp-format
|
||||
msgid "Feedback Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Try typing it up in Notepad, then Copy/Paste."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "You can type up a message here and submit it for the administrator to see."
|
||||
msgstr ""
|
||||
|
||||
#: templates/contact/index.html
|
||||
#, lisp-format
|
||||
msgid "Contact Us"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/_field_control_select.html
|
||||
#, lisp-format
|
||||
msgid "None"
|
||||
msgstr ""
|
||||
|
||||
#: templates/decks/index.html
|
||||
#, lisp-format
|
||||
msgid "Deck List"
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Click the links at the top to get started."
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Welcome to cl-deck-builder2!"
|
||||
msgstr ""
|
||||
|
||||
#: templates/index.html
|
||||
#, lisp-format
|
||||
msgid "Index"
|
||||
msgstr ""
|
||||
|
||||
#: templates/kde-team.html
|
||||
#, lisp-format
|
||||
msgid "KDE Team Deck Listing"
|
||||
msgstr ""
|
||||
|
||||
#: templates/label-maker.html
|
||||
#, lisp-format
|
||||
msgid "Label Maker"
|
||||
msgstr ""
|
||||
|
||||
#: templates/qr.html
|
||||
#, lisp-format
|
||||
msgid "QR Code Generator"
|
||||
msgstr ""
|
||||
|
||||
#: templates/tabs.html
|
||||
#, lisp-format
|
||||
msgid "Tabs"
|
||||
msgstr ""
|
||||
|
||||
#: templates/upload.html
|
||||
#, lisp-format
|
||||
msgid "File Uploader"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/admin.html
|
||||
#, lisp-format
|
||||
msgid "User Admin Panel"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/login.html
|
||||
#, lisp-format
|
||||
msgid "Login"
|
||||
msgstr ""
|
||||
|
||||
#: templates/user/register.html
|
||||
#, lisp-format
|
||||
msgid "Register"
|
||||
msgstr ""
|
||||
135
locale/templates/LC_MESSAGES/lisp.pot
Normal file
135
locale/templates/LC_MESSAGES/lisp.pot
Normal file
@ -0,0 +1,135 @@
|
||||
# SOME DESCRIPTIVE TITLE.
|
||||
# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER
|
||||
# This file is distributed under the same license as the PACKAGE package.
|
||||
# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
|
||||
#
|
||||
#, fuzzy
|
||||
msgid ""
|
||||
msgstr ""
|
||||
"Project-Id-Version: PACKAGE VERSION\n"
|
||||
"Report-Msgid-Bugs-To: \n"
|
||||
"POT-Creation-Date: 2023-10-10 19:17+0000\n"
|
||||
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
|
||||
"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
|
||||
"Language-Team: LANGUAGE <LL@li.org>\n"
|
||||
"Language: \n"
|
||||
"MIME-Version: 1.0\n"
|
||||
"Content-Type: text/plain; charset=CHARSET\n"
|
||||
"Content-Transfer-Encoding: 8bit\n"
|
||||
|
||||
#: src/i18n.lisp:60
|
||||
msgid "Please login to continue"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:67
|
||||
#, lisp-format
|
||||
msgid "Upload success! <a href=\"~a\">~a</a>"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:70
|
||||
msgid "Error uploading file. Try again?"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/upload.lisp:85
|
||||
#, lisp-format
|
||||
msgid "No such attachment #~d"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:45
|
||||
msgid "Feedback cleared."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:47 src/web/contact.lisp:72 src/web/qr.lisp:38
|
||||
#: src/web/ydk.lisp:14 src/web/ydk.lisp:25 src/web/decks.lisp:121
|
||||
#: src/web/decks.lisp:138 src/web/label-maker.lisp:125 src/web/user.lisp:79
|
||||
#: src/web/user.lisp:83
|
||||
msgid "Something went wrong. Try again?"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/contact.lisp:71
|
||||
msgid "Thanks! We got your message."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/category.lisp:65 src/web/decks.lisp:137
|
||||
msgid "Success!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:220
|
||||
#, lisp-format
|
||||
msgid "Deck ~a already exists in database; loading..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:224
|
||||
#, lisp-format
|
||||
msgid "Creating deck ~a into database."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:279
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); loading...~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/builder.lisp:298
|
||||
#, lisp-format
|
||||
msgid "Found entry ~A (~d); renaming to ~a.~%"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:64
|
||||
msgid "Nothing to see here..."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:242
|
||||
msgid "No Name"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/decks.lisp:290
|
||||
#, lisp-format
|
||||
msgid "Deck ~a deleted success!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/toolkit.lisp:29
|
||||
msgid "Please log in."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/label-maker.lisp:108
|
||||
msgid "No files."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/label-maker.lisp:122
|
||||
#, lisp-format
|
||||
msgid "Success! Download link: <a href=\"/public/~a.pdf\">labels.pdf</a>"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:23
|
||||
#, lisp-format
|
||||
msgid "You are already logged in as: ~a"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:29
|
||||
msgid "A user with that email is already registered."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:43
|
||||
#, lisp-format
|
||||
msgid "Hello, ~a!"
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:47
|
||||
msgid "Incorrect password."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:50
|
||||
msgid "No user corresponding to this email address."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:76
|
||||
msgid "Success! Please log in."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:123
|
||||
msgid "Logged out."
|
||||
msgstr ""
|
||||
|
||||
#: src/web/user.lisp:124
|
||||
msgid "You aren't logged in."
|
||||
msgstr ""
|
||||
3
old/api/api-v0.lisp
Normal file
3
old/api/api-v0.lisp
Normal file
@ -0,0 +1,3 @@
|
||||
(in-package #:cl-deck-builder2.api)
|
||||
|
||||
(defclass api-v0 ())
|
||||
14
old/api/api-v1.lisp
Normal file
14
old/api/api-v1.lisp
Normal file
@ -0,0 +1,14 @@
|
||||
(in-package #:cl-deck-builder2.api)
|
||||
|
||||
(defclass api-v1 (api-v0))
|
||||
|
||||
(defclass db-metaclass (standard-object)
|
||||
((create)
|
||||
(find)
|
||||
(select)
|
||||
(update)
|
||||
(delete)))
|
||||
|
||||
(defclass deck ()
|
||||
()
|
||||
(:metaclass db-metaclass))
|
||||
6
old/api/package.lisp
Normal file
6
old/api/package.lisp
Normal file
@ -0,0 +1,6 @@
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.api
|
||||
(:use :cl))
|
||||
|
||||
(in-package #:cl-deck-builder2.api)
|
||||
43
old/hermetic.lisp
Normal file
43
old/hermetic.lisp
Normal file
@ -0,0 +1,43 @@
|
||||
;;;; src/web/hermetic.lisp
|
||||
;;;;
|
||||
;;;; demo quick reference
|
||||
;;;;
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defroute ("/hermetic" :method :GET) ()
|
||||
(if (hermetic:logged-in-p)
|
||||
(progn
|
||||
(flash :messages (format nil "Welcome, ~A!" (hermetic:user-name)))
|
||||
(render-with-env #P"/user/index.html"))
|
||||
(render-with-env #P"/user/login.html")))
|
||||
|
||||
(defroute ("/hermetic/login" :method :POST) (&key _parsed)
|
||||
(let ((username (query-param "username" _parsed))
|
||||
(password (query-param "password" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:string username)
|
||||
(:string password))
|
||||
(let ((params (list :|username| username :|password| password)))
|
||||
(login params
|
||||
(cl-markup:html5 (:h1 "You are logged in"))
|
||||
(cl-markup:html5 (:h1 "Wrong password :c"))
|
||||
(cl-markup:html5 (:h1 "No such username " params)))))
|
||||
(ratify:combined-error (e)
|
||||
(flash :errors e)
|
||||
(redirect "/hermetic")))))
|
||||
|
||||
(defroute ("/hermetic/logout" :method :GET) ()
|
||||
(logout
|
||||
(cl-markup:html5 (:h1 "You are logged out"))
|
||||
(cl-markup:html5 (:h1 "You are not logged in."))))
|
||||
|
||||
(defroute ("/hermetic/users-only" :method :GET) ()
|
||||
(auth (:user)
|
||||
(cl-markup:html5 (:h1 "If you are seeing this, you are a user."))))
|
||||
|
||||
(defroute ("/hermetic/admins-only" :method :GET) ()
|
||||
(hermetic:auth (:admin)
|
||||
(cl-markup:html5 (:h1 "If you are seeing this, you are an admin."))
|
||||
(cl-markup:html5 (:h1 "Custom auth denied page. You are not authorized!"))))
|
||||
168
old/lack-middleware-secure.lisp
Normal file
168
old/lack-middleware-secure.lisp
Normal file
@ -0,0 +1,168 @@
|
||||
;;;
|
||||
;;; See http://diary.wshito.com/comp/lisp/clack/lack-middleware-session/
|
||||
;;; for explanation.
|
||||
;;;
|
||||
|
||||
(ql:quickload 'clack)
|
||||
(ql:quickload 'lack)
|
||||
|
||||
(defun starts-with (str prefix)
|
||||
(when (>= (length str) (length prefix))
|
||||
(string= (subseq str 0 (length prefix)) prefix)))
|
||||
|
||||
;;; Middleware to proctect the secure area
|
||||
;;; :uidが設定されていない場合，protected-pathにアクセスすると
|
||||
;;; redirect関数を呼び出してログインページへリダイレクトする．
|
||||
(defun secure-mw (redirect protected-path)
|
||||
(lambda (app)
|
||||
(lambda (env)
|
||||
;; preprocessing
|
||||
(let* ((url (getf env :path-info))
|
||||
(session (getf env :lack.session))
|
||||
(uid (gethash :uid session)))
|
||||
(if (and (null uid)
|
||||
(dolist (prefix protected-path)
|
||||
(when (starts-with url prefix) (return t))))
|
||||
(progn
|
||||
;;当初のアクセス先をセッション変数に保存
|
||||
(setf (gethash :prev-url session) url)
|
||||
(funcall redirect))
|
||||
(funcall app env))))))
|
||||
|
||||
;;; ログインページへリダイレクトするレスポンスを返す．
|
||||
(defun redirect-to-login-page ()
|
||||
'(303 (:location "/login") ("")))
|
||||
|
||||
(defun get-uid (env)
|
||||
(gethash :uid (getf env :lack.session)))
|
||||
|
||||
(defun get-session-id (env)
|
||||
(getf (getf env :lack.session.options) :id))
|
||||
|
||||
(defun get-change-id (env)
|
||||
(format nil "~A" (getf (getf env :lack.session.options) :change-id)))
|
||||
|
||||
(defun page-header (env)
|
||||
`("<html><h1>Lack Session Middleware Test</h1>
|
||||
<h2>--- Login Logout Example ---</h2>
|
||||
<ul>
|
||||
<li>Access any directories. Any directories under '<b>/private</b>' needs to be logged in to access.</li>
|
||||
<li>Session ID: " ,(get-session-id env) "</li>
|
||||
<li>:change-id = " ,(get-change-id env) "</li>
|
||||
</ul>
|
||||
<hr />"))
|
||||
|
||||
(defun status (uid)
|
||||
(if uid
|
||||
`("<p>You are logged in as " ,uid ". (<a href='/logout'>logout</a>)</p>")
|
||||
`("<p><a href='/login'>Login</a></p>")))
|
||||
|
||||
(defun page-footer ()
|
||||
'("</html>"))
|
||||
|
||||
(defun login-form ()
|
||||
;; /auth にuidとpasswdをPOST
|
||||
'("<p>Use '<b>wshito</b>' for username, '<b>mypass</b>' for password.</p>
|
||||
<form action='/auth' method='post'>
|
||||
<p>Username:
|
||||
<input type='text' name='uname' maxlength='32' autocomplete='OFF' /></p>
|
||||
<p>Password:
|
||||
<input type='password' name='passwd' maxlength='32' autocomplete='OFF' /></p>
|
||||
<p><input type='submit' value='Login' /></p>
|
||||
</form>"))
|
||||
|
||||
;;; ログインページ
|
||||
(defparameter *login*
|
||||
(lambda (env)
|
||||
(let ((uid (get-uid env)))
|
||||
`(200 (:content-type "text/html")
|
||||
,(append (page-header env)
|
||||
(if uid
|
||||
(list "<p>You are already logged in as " uid ".</p>")
|
||||
(login-form))
|
||||
(page-footer))))))
|
||||
|
||||
;;; ログアウトページ
|
||||
(defparameter *logout*
|
||||
(lambda (env)
|
||||
(setf (getf (getf env :lack.session.options) :expire) t)
|
||||
`(200 (:content-type "text/html")
|
||||
,(append (page-header env)
|
||||
(list "<p>You have logged out.</p>")
|
||||
(page-footer)))))
|
||||
|
||||
;;; 認証関数
|
||||
(defun authenticate (name password)
|
||||
(and (string= name "wshito")
|
||||
(string= password "mypass")))
|
||||
|
||||
;;; :body-parameters内にはPOSTで送られたパラメータが，ドット対
|
||||
;;; のリストとして保持されている．この場合だと，
|
||||
;;; (("uname" . "wshito") ("passwd" . "mypass"))
|
||||
(defparameter *auth*
|
||||
(lambda (env)
|
||||
(let* ((params (getf env :body-parameters))
|
||||
(name (cdr (assoc "uname" params :test #'string=)))
|
||||
(pass (cdr (assoc "passwd" params :test #'string=))))
|
||||
(if (and (= (length params) 2)
|
||||
(authenticate name pass))
|
||||
(let* ((session (getf env :lack.session))
|
||||
(url (gethash :prev-url session "/")))
|
||||
(setf (gethash :uid session "/") name)
|
||||
(setf (getf (getf env :lack.session.options) :change-id) t)
|
||||
`(303 (:location ,url) ("")))
|
||||
(redirect-to-login-page)))))
|
||||
|
||||
;;; ログインが必要なprivateエリア
|
||||
(defparameter *private*
|
||||
(lambda (env)
|
||||
(let* ((session (getf env :lack.session))
|
||||
(uid (gethash :uid session nil))
|
||||
;; /privateにmountしているのでpathには/privateが含まれない
|
||||
(path (concatenate 'string "/private" (getf env :path-info))))
|
||||
`(200 (:content-type "text/html")
|
||||
,(append (page-header env)
|
||||
(status uid)
|
||||
(list "<p>Private Area: path = " path "</p>")
|
||||
(page-footer))))))
|
||||
|
||||
;;;
|
||||
;;; Main App
|
||||
;;;
|
||||
(defparameter *sample-app*
|
||||
(lambda (env)
|
||||
(let* ((session (getf env :lack.session))
|
||||
(uid (gethash :uid session))
|
||||
(path (getf env :path-info)))
|
||||
(when (null uid) (setf (gethash :prev-url session) path))
|
||||
`(200 (:content-type "text/html")
|
||||
,(append (page-header env)
|
||||
(status uid)
|
||||
(list "<p>path = " path "</p>")
|
||||
(page-footer))))))
|
||||
|
||||
;;;
|
||||
;;; Creates Lack Application
|
||||
;;; builderチェーンの最後だけが1重lambdaで，それ以外は2重lambda．
|
||||
;;; builderされ*app*に渡される内容は外側のlambda式がfuncallで呼びだされた
|
||||
;;; 後の結果．外側のlambdaはbuilder時に実行される．
|
||||
(defparameter *app*
|
||||
(lack:builder
|
||||
:session
|
||||
(secure-mw #'redirect-to-login-page '("/private"))
|
||||
(:mount "/login" *login*)
|
||||
(:mount "/auth" *auth*)
|
||||
(:mount "/logout" *logout*)
|
||||
(:mount "/private" *private*)
|
||||
*sample-app*))
|
||||
|
||||
;;;
|
||||
;;; Starts the Web server
|
||||
;;;
|
||||
(defparameter *handler*
|
||||
(clack:clackup *app*))
|
||||
|
||||
;;;
|
||||
;;; Stops the Web server
|
||||
;;;
|
||||
;; (clack:stop *handler*)
|
||||
1
old/readme.md
Normal file
1
old/readme.md
Normal file
@ -0,0 +1 @@
|
||||
old code
|
||||
34
old/web-route-test.lisp
Normal file
34
old/web-route-test.lisp
Normal file
@ -0,0 +1,34 @@
|
||||
;;;;
|
||||
;;;; src/web/web-test.lisp
|
||||
;;;;
|
||||
;;;; This is a test for Lack.Middleware.Mount
|
||||
;;;;
|
||||
;;;; Eventually I want all the web routes to be their own package,
|
||||
;;;; maybe integrated better with the models.
|
||||
;;;;
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
;; TODO I could probably start moving all this stuff into packages.lisp
|
||||
|
||||
(defpackage #:cl-deck-builder2.web.web-test
|
||||
(:use :cl
|
||||
:caveman2)
|
||||
(:local-nicknames
|
||||
(#:v #:org.shirakumo.verbose))
|
||||
(:import-from :cl-deck-builder2.view
|
||||
:render)
|
||||
(:export :*web-test*))
|
||||
|
||||
(in-package #:cl-deck-builder2.web.web-test)
|
||||
|
||||
;;
|
||||
;; Application
|
||||
;;
|
||||
|
||||
(defclass <web> (<app>) ())
|
||||
(defvar *web-test* (make-instance '<web>))
|
||||
(clear-routing-rules *web-test*)
|
||||
|
||||
(defroute "/" ()
|
||||
(format nil "Test!~%"))
|
||||
137
old/ygoprodeck-json.lisp
Normal file
137
old/ygoprodeck-json.lisp
Normal file
@ -0,0 +1,137 @@
|
||||
#|
|
||||
|
||||
Legacy Code
|
||||
|
||||
Scheduled For Deletion
|
||||
|
||||
YGOProDeck v1 JSON Importer
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.json
|
||||
(:use :cl
|
||||
:cl-deck-builder2.db
|
||||
:cl-deck-builder2.models.ygoprodeck)
|
||||
(:local-nicknames
|
||||
(#:v #:org.shirakumo.verbose))
|
||||
(:export :json-import-cardinfo))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.json)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar *json* nil
|
||||
"The currently loaded \"cardinfo.php\" data pulled from YGOProDeck
|
||||
API. You may have to munge it into \"cardinfo.json\" with jq:
|
||||
|
||||
$ jq . < cardinfo.php > cardinfo.json
|
||||
")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; GET-NEW-CARDINFO got renamed to YGOPRODECK2:FETCH-CARDINFO.
|
||||
;; Actually, basically everything got moved into YGOPRODECK2. This is
|
||||
;; legacy code.
|
||||
|
||||
|
||||
(defun json-import-cardinfo (path &optional (force nil))
|
||||
(load-cardinfo path force)
|
||||
|
||||
(let ((lst ()))
|
||||
;; CARD is an ALIST
|
||||
(dolist (card *json*)
|
||||
(let (;; Banlist_Info: Unused
|
||||
;; (banlist-info (assoc-utils:aget card :banlist--info))
|
||||
|
||||
;; Card Images: Variant Artwork
|
||||
;; Skip the first one with REST
|
||||
(card-images (rest (assoc-utils:aget card :card--images)))
|
||||
|
||||
;; make a copy: we munge it
|
||||
(card-prices (copy-alist (assoc-utils:aget card :card--prices)))
|
||||
;; make a copy: we munge it
|
||||
(card-sets (copy-alist (assoc-utils:aget card :card--sets)))
|
||||
;; Link Markers: Unused
|
||||
;; (linkmarkers (assoc-utils:aget card :linkmarkers))
|
||||
|
||||
;; make a copy: we munge it
|
||||
(card-misc-info (copy-alist (assoc-utils:aget card :misc--info)))
|
||||
|
||||
;; '((:banlist--info)
|
||||
;; (:card--images)
|
||||
;; (:card--prices)
|
||||
;; (:card--sets)
|
||||
;; (:linkmarkers)
|
||||
;; (:misc--info))
|
||||
|
||||
(passcode (assoc-utils:aget card :id))
|
||||
(base-fields (assoc-utils:alist-plist
|
||||
(json-cardinfo-base-fields card))))
|
||||
|
||||
;; First import all the base data
|
||||
(push (apply #'make-instance 'ygo-info base-fields) lst)
|
||||
|
||||
;; Card images, variant artwork, I'm not sure how to handle
|
||||
;; it. Here's a dirty hack! If there are any variant images
|
||||
;; with passcodes, just create a duplicate entry with the same
|
||||
;; data from the parent. I'm sure a separate table is a better
|
||||
;; way to handle this information, but I don't know how to do
|
||||
;; that right now!
|
||||
(dolist (card-image card-images)
|
||||
(let ((id (assoc-utils:aget card-image :id)))
|
||||
(setf (getf base-fields :passcode) id)
|
||||
(push (apply #'make-instance 'ygo-info base-fields) lst)))
|
||||
|
||||
;; TODO Ban List Info
|
||||
;; Append :passcode to all banlist-info for this card
|
||||
;; (dolist (banlist banlist-info)
|
||||
;; (setf banlist (acons :passcode passcode banlist))
|
||||
;; (apply #'mito:create-dao 'banlist-info
|
||||
;; (assoc-utils:alist-plist banlist)))
|
||||
|
||||
;; Append :passcode to all card-prices for this card
|
||||
(dolist (card-price card-prices)
|
||||
(setf card-price (acons :passcode passcode card-price)
|
||||
;; Data Transformation
|
||||
(car (assoc :cardmarket--price card-price)) :cardmarket
|
||||
(car (assoc :tcgplayer--price card-price)) :tcgplayer
|
||||
(car (assoc :ebay--price card-price)) :ebay
|
||||
(car (assoc :amazon--price card-price)) :amazon
|
||||
(car (assoc :coolstuffinc--price card-price)) :coolstuffinc)
|
||||
(push (apply #'make-instance 'ygo-price (assoc-utils:alist-plist card-price))
|
||||
lst))
|
||||
|
||||
;; Append :passcode to all card-sets for this card
|
||||
(dolist (card-set card-sets)
|
||||
(setf card-set (acons :passcode passcode card-set)
|
||||
;; Data Transformation
|
||||
(car (assoc :set--name card-set)) :name
|
||||
(car (assoc :set--code card-set)) :code
|
||||
(car (assoc :set--rarity card-set)) :rarity
|
||||
(car (assoc :set--rarity--code card-set)) :rarity-code
|
||||
(car (assoc :set--price card-set)) :price)
|
||||
(push (apply #'make-instance 'ygo-set (assoc-utils:alist-plist card-set))
|
||||
lst))
|
||||
|
||||
;; misc_info + misc_info.formats
|
||||
;; (dolist (misc-info card-misc-info)
|
||||
;; (setf card-set (acons :passcode passcode card-set)
|
||||
;; ;; Data Transformation
|
||||
;; (car (assoc :set--name card-set)) :name
|
||||
;; (car (assoc :set--code card-set)) :code
|
||||
;; (car (assoc :set--rarity card-set)) :rarity
|
||||
;; (car (assoc :set--rarity--code card-set)) :rarity-code
|
||||
;; (car (assoc :set--price card-set)) :price)
|
||||
;; (push (apply #'make-instance 'ygo-set (assoc-utils:alist-plist card-set))
|
||||
;; lst))
|
||||
|
||||
))
|
||||
(do-grouped-insert lst)))
|
||||
|
||||
;; TODO linkmarkers
|
||||
;; Append :passcode to all linkmarkers for this card
|
||||
;; (dolist (linkmarker linkmarkers)
|
||||
;; (setf linkmarker (acons :passcode passcode linkmarker))
|
||||
;; Data Transformation
|
||||
;; (apply #'mito:create-dao 'linkmarker
|
||||
;; (assoc-utils:alist-plist linkmarker)))
|
||||
17
preamble.lisp
Normal file
17
preamble.lisp
Normal file
@ -0,0 +1,17 @@
|
||||
#|
|
||||
|
||||
preamble.lisp
|
||||
|
||||
For whatever reason, I don't keep this project in my
|
||||
~/quicklisp/local-projects directory. So I have this preamble bit
|
||||
of code that will push your current directory to Quicklisp.
|
||||
|
||||
|#
|
||||
|
||||
;; Assume the project is in the current working directory. It's
|
||||
;; harmless, probably.
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(pushnew (uiop:getcwd) ql:*local-project-directories*)
|
||||
|
||||
;; Load em' up. We use SLY so load SLYNK instead of SWANK here.
|
||||
(ql:quickload '(:cl-deck-builder2 :slynk)))
|
||||
24
print-deps.lisp
Normal file
24
print-deps.lisp
Normal file
@ -0,0 +1,24 @@
|
||||
#|
|
||||
|
||||
print-deps.lisp
|
||||
|
||||
Output dependency information extracted from the ASDF:DEFSYSTEM.
|
||||
|
||||
TODO Integrate this with the Dockerfile.
|
||||
|
||||
|#
|
||||
|
||||
(defparameter +extra-depends-on+
|
||||
'(:hunchentoot :woo :slynk/trace-dialog :slynk/profiler :slynk/mrepl :slynk/indentation
|
||||
:slynk/fancy-inspector :slynk/arglists :slynk))
|
||||
|
||||
(defun format-deps (system &optional (stream *standard-output*) extra-depends-on)
|
||||
(format stream "(ql:quickload (list ~{~s~^ ~}))~%" (system-deps system extra-depends-on)))
|
||||
|
||||
(defun system-deps (system &optional extra-depends-on)
|
||||
(mapcar (alexandria:compose #'alexandria:make-keyword #'string-upcase)
|
||||
(sort (remove-duplicates
|
||||
(append extra-depends-on
|
||||
(asdf:system-depends-on
|
||||
(asdf:find-system system))))
|
||||
#'string<)))
|
||||
21
ruby/config.ru
Normal file
21
ruby/config.ru
Normal file
@ -0,0 +1,21 @@
|
||||
# Easiest way to run Sidekiq::Web.
|
||||
# Run with "bundle exec rackup simple.ru"
|
||||
|
||||
require 'sidekiq'
|
||||
|
||||
# A Web process always runs as client, no need to configure server
|
||||
Sidekiq.configure_client do |config|
|
||||
config.redis = { :size => 1, url: 'redis://localhost:6379', namespace: 'psychiq' }
|
||||
end
|
||||
|
||||
# In a multi-process deployment, all Web UI instances should share
|
||||
# this secret key so they can all decode the encrypted browser cookies
|
||||
# and provide a working session.
|
||||
# Rails does this in /config/initializers/secret_token.rb
|
||||
secret_key = SecureRandom.hex(32)
|
||||
use Rack::Session::Cookie, secret: secret_key, same_site: true, max_age: 86400
|
||||
|
||||
require "sidekiq/web"
|
||||
map '/psy' do
|
||||
run Sidekiq::Web
|
||||
end
|
||||
1
src/.gitignore
vendored
Normal file
1
src/.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
*.fasl
|
||||
121
src/config.lisp
Normal file
121
src/config.lisp
Normal file
@ -0,0 +1,121 @@
|
||||
#|
|
||||
|
||||
src/config.lisp
|
||||
|
||||
Configuration skeleton generated by Caveman.
|
||||
|
||||
Additional changes:
|
||||
|
||||
*public-directory* :: This is where YGOProDeck images and things generated *by the "public" are stored.
|
||||
|
||||
Database Configuration:
|
||||
|
||||
We use :MEMORY for SQLite in-memory,currently :MAINDB is the default
|
||||
database which is an SQLite3 file in this directory, and :MYSQL is our
|
||||
MariaDB testbed server we're planning on migrating to.
|
||||
|
||||
|#
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.config
|
||||
(:use #:cl)
|
||||
(:import-from #:envy
|
||||
#:config-env-var
|
||||
#:defconfig)
|
||||
(:export #:config
|
||||
#:*application-root*
|
||||
#:*public-directory*
|
||||
#:*static-directory*
|
||||
#:*template-directory*
|
||||
|
||||
#:*app-log-file*
|
||||
|
||||
#:appenv
|
||||
#:developmentp
|
||||
#:productionp)
|
||||
(:documentation "Configuration package. Using Envy configuration switcher. Mostly default from Caveman2 skeleton generator. I added a bunch of documentation."))
|
||||
|
||||
(in-package :cl-deck-builder2.config)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(setf (config-env-var) "APP_ENV")
|
||||
|
||||
(defparameter *application-root*
|
||||
(asdf:system-source-directory :cl-deck-builder2)
|
||||
"The source directory of this web application.")
|
||||
(defparameter *public-directory*
|
||||
(probe-file #P"~/public/")
|
||||
"The absolute path to the directory where we serve public files from.")
|
||||
(defparameter *static-directory*
|
||||
(merge-pathnames #P"static/" *application-root*)
|
||||
"The absolute path to the directory where we serve static files from.")
|
||||
(defparameter *template-directory*
|
||||
(merge-pathnames #P"templates/" *application-root*)
|
||||
"The absolute path to the directory where we find and compile templates from.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defparameter *app-log-file*
|
||||
(merge-pathnames
|
||||
(make-pathname
|
||||
:name (local-time:format-timestring
|
||||
nil (local-time:now)
|
||||
:format local-time:+rfc3339-format/date-only+)
|
||||
:type "log")
|
||||
(merge-pathnames
|
||||
*public-directory*
|
||||
(user-homedir-pathname)))
|
||||
"The log file for this instance of the app to use. We don't really care about conflicts at this point, as we :APPEND.
|
||||
|
||||
Possibly in the future use the git commit id.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Configurations
|
||||
(defconfig :common
|
||||
`(:databases
|
||||
((:memory :sqlite3 :database-name ":memory:")
|
||||
(:maindb :sqlite3 :database-name
|
||||
,(asdf:system-relative-pathname
|
||||
:cl-deck-builder2 "deck_builder" :type "sqlite3"))
|
||||
(:mysql :mysql
|
||||
:host "127.0.0.1"
|
||||
:port 3306
|
||||
:database-name "deck_builder"
|
||||
:username "deck_builder"
|
||||
:password "deck_builder"))
|
||||
:server (:address "0.0.0.0" :port 5005 :server :woo)
|
||||
:slynk (:interface "0.0.0.0"
|
||||
:port 4005
|
||||
:style :spawn
|
||||
:dont-close t)
|
||||
:websocket (:address "0.0.0.0" :port 5001)))
|
||||
|
||||
(defconfig |development|
|
||||
'())
|
||||
|
||||
(defconfig |production|
|
||||
'())
|
||||
|
||||
(defconfig |test|
|
||||
'())
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun config (&optional key)
|
||||
"Query the configuration environment information.
|
||||
|
||||
ARGUMENTS
|
||||
KEY The key to query from the configuration."
|
||||
(envy:config #.(package-name *package*) key))
|
||||
|
||||
(defun appenv ()
|
||||
"Get the current environment variable value. Default is ~APP_ENV~."
|
||||
(uiop:getenv (config-env-var #.(package-name *package*))))
|
||||
|
||||
(defun developmentp ()
|
||||
"Return T if the application is in \"development\" mode."
|
||||
(string= (appenv) "development"))
|
||||
|
||||
(defun productionp ()
|
||||
"Return T if the application is in \"production\" mode."
|
||||
(string= (appenv) "production"))
|
||||
295
src/db.lisp
Normal file
295
src/db.lisp
Normal file
@ -0,0 +1,295 @@
|
||||
#|
|
||||
|
||||
src/db.lisp
|
||||
|
||||
Database / connection skeleton generated by Caveman.
|
||||
|
||||
Additional changes:
|
||||
|
||||
WITH-DATAFLY-CONNECTION :: Same as WITH-CONNECTION, but we use
|
||||
DATAFLY:*CONNECTION* instead of MITO.CORE:*CONNECTION*.
|
||||
|
||||
WITH-DATAFLY-TRANSACTION is the same.
|
||||
|
||||
TODO: I would like to be able to specify :MITO or :DATAFLY.
|
||||
|
||||
TODO Test this stuff
|
||||
|
||||
DONE Caveman has a db module and dbi manager middleware - Looks
|
||||
useless. We already have CONNECT-CACHED in db.lisp.
|
||||
|
||||
|#
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.db
|
||||
(:use #:cl)
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:config)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:grouped
|
||||
#:relative-pathname)
|
||||
(:import-from #:cl-dbi
|
||||
#:connect-cached)
|
||||
(:export #:connection-settings
|
||||
#:db
|
||||
#:with-connection
|
||||
#:with-transaction
|
||||
#:with-datafly-connection
|
||||
#:with-datafly-transaction
|
||||
#:with-includes
|
||||
|
||||
#:do-grouped-insert
|
||||
|
||||
#:count-dao
|
||||
#:create-dao
|
||||
#:delete-by-values
|
||||
#:delete-from
|
||||
#:delete-dao
|
||||
|
||||
#:create-table
|
||||
#:drop-table
|
||||
#:recreate-table
|
||||
|
||||
#:find-dao
|
||||
#:find-or-make-instance
|
||||
#:find-or-create-instance
|
||||
#:insert-dao
|
||||
#:max-dao
|
||||
#:retrieve-by-sql
|
||||
#:retrieve-dao
|
||||
#:save-dao
|
||||
#:select-dao
|
||||
#:update-dao)
|
||||
(:documentation "The database package.
|
||||
|
||||
This is more than just the default generated by Caveman2 skeleton.
|
||||
|
||||
It provides convenience functions for accessing database information and objects."))
|
||||
|
||||
(in-package #:cl-deck-builder2.db)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun connection-settings (&optional (db :maindb))
|
||||
"Query the Caveman configuration for these database settings. DB is the name of the configuration query, e.g. :MAINDB."
|
||||
(cdr (assoc db (config :databases))))
|
||||
|
||||
(defun db (&optional (db :maindb))
|
||||
"Get a handle to an open database, possibly cached with CONNECT-CACHED."
|
||||
(apply #'connect-cached (connection-settings db)))
|
||||
|
||||
(defmacro with-connection (conn &body body)
|
||||
"Wrap BODY using LEXICAL-LET to bind MITO.CORE:*CONNECTION* to CONN."
|
||||
;; TODO
|
||||
;; `(if (and (listp ,conn)
|
||||
;; (eq (type-of ,(car conn)) 'cl-dbi::dbi-connection))
|
||||
;; (let ((,(car conn) ,(cdr conn)))
|
||||
;; ,@body))
|
||||
`(let ((mito.core:*connection* ,conn))
|
||||
,@body))
|
||||
|
||||
(defmacro with-transaction (&body body)
|
||||
"Wrap BODY with CL-DBI:WITH-TRANSACTION."
|
||||
`(cl-dbi:with-transaction mito.core:*connection*
|
||||
,@body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; What's a better way to do this? DEFGENERIC?
|
||||
(defmacro with-datafly-connection (conn &body body)
|
||||
"Wrap BODY using LEXICAL-LET to bind DATAFLY:*CONNECTION* to CONN."
|
||||
`(let ((datafly:*connection* ,conn))
|
||||
;; (datafly:*trace-sql* t))
|
||||
,@body))
|
||||
|
||||
(defmacro with-datafly-transaction (&body body)
|
||||
"Wrap BODY with CL-DBI:WITH-TRANSACTION. Datafly variant."
|
||||
`(cl-dbi:with-transaction datafly:*connection*
|
||||
,@body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; I didn't realize that this implicitly only allows SELECT-DAO. I
|
||||
;; guess in the MITO documentation he only allows SELECT-DAO to have
|
||||
;; MITO:INCLUDES machinery. Where is that captured? For now, I assume
|
||||
;; you know this, and that WITH-INCLUDES is only compatible with
|
||||
;; SELECT-DAO anyway.
|
||||
(defmacro with-includes (class includes &body body)
|
||||
`(mito:select-dao ,class
|
||||
,includes
|
||||
,@body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; What happened here? It used to work now it's returning NIL. A LOOP
|
||||
;; is nicer than a DOLIST+SETF but...
|
||||
(defun do-grouped-insert (obj &key (n 1000) (fn #'mito:insert-dao))
|
||||
"Batch INSERT-DAO to the database. Display a progress bar."
|
||||
(let ((pos 0)
|
||||
(width 50)
|
||||
(grouped (grouped obj n)))
|
||||
(with-connection (db)
|
||||
(loop for group in grouped
|
||||
collect
|
||||
(prog1
|
||||
(with-transaction
|
||||
(mapcan fn group))
|
||||
(format t ".")
|
||||
(if (>= pos (1- width))
|
||||
(progn
|
||||
(setf pos 0)
|
||||
(format t "~%"))
|
||||
(incf pos))
|
||||
(finish-output))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO FIND-DAO-OR-MAKE-INSTANCE?
|
||||
;; TODO Maybe merge FIND-OR-MAKE-INSTANCE and FIND-OR-CREATE-INSTANCE
|
||||
(defun find-or-make-instance (class &rest args)
|
||||
"Wrap MITO:FIND-DAO and if no result is returned, issue MAKE-INSTANCE for CLASS."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(or (apply #'mito:find-dao class args)
|
||||
(apply #'make-instance class args)))))
|
||||
|
||||
(defun find-or-create-instance (class &rest args)
|
||||
"Wrap MITO:FIND-DAO and if no result is returned, issue CREATE-DAO for CLASS."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(or (apply #'mito:find-dao class args)
|
||||
(apply #'mito:create-dao class args)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; DAOs
|
||||
(defmacro select-dao (class &body body)
|
||||
"Select an object of CLASS from the database by wrapping MITO:SELECT-DAO in WITH-CONNECTION etc.
|
||||
|
||||
Note that SELECT-DAO is a DEFMACRO form.
|
||||
|
||||
You may additionally specify BODY parameters that are SXQL statements."
|
||||
`(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:select-dao ,class ,@body))))
|
||||
|
||||
(defun delete-from (class &rest clauses)
|
||||
"Delete entries for CLASS by wrapping SXQL:DELETE-FROM.
|
||||
|
||||
You may additionally specify CLAUSES parameters that are SXQL statements."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:execute-sql
|
||||
(apply #'sxql:make-statement :delete-from
|
||||
(sxql:make-sql-symbol
|
||||
(mito.class:table-name (find-class class)))
|
||||
clauses)))))
|
||||
|
||||
(defun count-dao (class &rest fields-and-values)
|
||||
"Count the number of entries matching this CLASS using FIELDS-AND-VALUES.
|
||||
|
||||
Simply wrap MITO:COUNT-DAO in WITH-CONNECTION etc."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'mito:count-dao class fields-and-values))))
|
||||
|
||||
(defun create-dao (class &rest initargs)
|
||||
"Create an entry for this CLASS by wrapping MITO:CREATE-DAO in WITH-CONNECTION etc."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'mito:create-dao class initargs))))
|
||||
|
||||
(defun max-dao (class &rest fields-and-values &key (field :id))
|
||||
"Select the aggregate MAX from the SQL database and return the result, if any.
|
||||
|
||||
You may additionally specify the FIELD to find the MAX by."
|
||||
(setf class (mito.util::ensure-class class))
|
||||
(let ((sql (sxql:select ((:as (:ifnull (:max field) 0) :max))
|
||||
(sxql:from (sxql:make-sql-symbol
|
||||
(mito.class:table-name class))))))
|
||||
(when fields-and-values
|
||||
(sxql:add-child sql (mito.dao::where-and fields-and-values class)))
|
||||
(getf (first
|
||||
(retrieve-by-sql sql))
|
||||
:max)))
|
||||
|
||||
(defun delete-by-values (class &rest fields-and-values)
|
||||
"Delete an entry for this CLASS by wrapping MITO:DELETE-BY-VALUES.
|
||||
|
||||
You may specify additional FIELDS-AND-VALUES to narrow your search."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'mito:delete-by-values class fields-and-values))))
|
||||
|
||||
(defun delete-dao (obj)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:delete-dao obj))))
|
||||
|
||||
(defun find-dao (class &rest fields-and-values)
|
||||
"Find an entry for this CLASS, if it exists, by wrapping MITO:FIND-DAO.
|
||||
|
||||
You may specify additional FIELDS-AND-VALUES to narrow your search."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'mito:find-dao class fields-and-values))))
|
||||
|
||||
(defun insert-dao (obj)
|
||||
"Insert an existing object OBJ into the database by wrapping MITO:INSERT-DAO in WITH-CONNECTION etc."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:insert-dao obj))))
|
||||
|
||||
(defun save-dao (obj)
|
||||
"Save an existing object OBJ into the database by wrapping MITO:SAVE-DAO in WITH-CONNECTION etc."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:save-dao obj))))
|
||||
|
||||
(defun update-dao (obj)
|
||||
"Update an existing object OBJ into the database by wrapping MITO:UPDATE-DAO in WITH-CONNECTION etc."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:update-dao obj))))
|
||||
|
||||
(defun retrieve-by-sql (sql &key binds)
|
||||
"Retrieve a query from the database by wrapping MITO:RETRIEVE-BY-SQL in WITH-CONNECTION etc.
|
||||
|
||||
I don't know what BINDS does. I think it has something to do with passing parameters to queries."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:retrieve-by-sql sql :binds binds))))
|
||||
|
||||
(defun retrieve-dao (class &rest fields-and-values)
|
||||
"Retrieve a row for this CLASS, if it exists, by wrapping MITO:RETRIEVE-DAO.
|
||||
|
||||
You may specify additional FIELDS-AND-VALUES to narrow your search."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'mito:retrieve-dao class fields-and-values))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tables
|
||||
(defun create-table (&rest classes)
|
||||
"Create tables for CLASSES by wrapping MITO:ENSURE-TABLE-EXISTS.
|
||||
|
||||
CLASSES may be a list of classes to create corresponding tables for."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar (alexandria:compose #'mito:ensure-table-exists #'find-class)
|
||||
classes))))
|
||||
|
||||
(defun drop-table (&rest classes)
|
||||
"Drop tables for CLASSES by wrapping SXQL:DROP-TABLE.
|
||||
|
||||
CLASSES may be a list of classes to drop corresponding tables for."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar (lambda (class)
|
||||
(mito:execute-sql
|
||||
(sxql:drop-table
|
||||
(sxql:make-sql-symbol
|
||||
(mito.class:table-name (find-class class)))
|
||||
:if-exists t)))
|
||||
classes))))
|
||||
|
||||
(defun recreate-table (&rest classes)
|
||||
"DROP-TABLE then CREATE-TABLE for CLASSES."
|
||||
(mapcar #'drop-table classes)
|
||||
(mapcar #'create-table classes))
|
||||
40
src/documentation.lisp
Normal file
40
src/documentation.lisp
Normal file
@ -0,0 +1,40 @@
|
||||
#|
|
||||
|
||||
src/documentation.lisp
|
||||
|
||||
DOCUMENTATION-UTILS helpers.
|
||||
|
||||
Currently not in use.
|
||||
|
||||
The intention of this file was to provide supplimental documentation.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2)
|
||||
|
||||
(setf docs.ext:*documentation*
|
||||
(docs.ext:make-documentation-collection))
|
||||
|
||||
(defclass my-formatter (documentation-utils-extensions:rich-aggregating-formatter)
|
||||
())
|
||||
|
||||
(docs:define-docs
|
||||
:formatter my-formatter)
|
||||
|
||||
(defun find-undocumented-packages ()
|
||||
(mapcar
|
||||
(lambda (pkg)
|
||||
(documentation-utils:check :package (find-package pkg)))
|
||||
'(cl-deck-builder2
|
||||
cl-deck-builder2-test
|
||||
cl-deck-builder2.app
|
||||
cl-deck-builder2.db
|
||||
cl-deck-builder2.draw
|
||||
cl-deck-builder2.toolkit
|
||||
cl-deck-builder2.models
|
||||
cl-deck-builder2.models.ygoprodeck
|
||||
cl-deck-builder2.models.user
|
||||
cl-deck-builder2.models.ydk
|
||||
cl-deck-builder2.models.crystal-commerce
|
||||
cl-deck-builder2.models.feedback
|
||||
cl-deck-builder2.web)))
|
||||
277
src/draw.lisp
Normal file
277
src/draw.lisp
Normal file
@ -0,0 +1,277 @@
|
||||
#|
|
||||
|
||||
draw.lisp
|
||||
|
||||
The main drawing stuff from ImageMagick is handled here. We use
|
||||
UIOP:RUN-PROGRAM. It's pretty clumsy, but it works for the types
|
||||
of files we're working with.
|
||||
|
||||
It could probably use some polishing up. Particularly the command
|
||||
processing. Using INFERIOR-SHELL just calls UIOP:RUN-PROGRAM under the
|
||||
hood anyway. Is it worth it for the extra param processing? It might
|
||||
be slightly safer, certainly LISP-ier...
|
||||
|
||||
|#
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.draw
|
||||
(:use #:cl)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:make-static-filename-kind
|
||||
#:relative-file-list
|
||||
#:ygo-probe-file-list
|
||||
#:static-probe-file-list)
|
||||
(:import-from #:cl-deck-builder2.models
|
||||
#:ydk-main-deck-of
|
||||
#:ydk-extra-deck-of
|
||||
#:ydk-side-deck-of)
|
||||
(:export :draw-deck-image)
|
||||
(:documentation "The Drawing package.
|
||||
|
||||
We currently wrap ImageMagick on the command line using UIOP:RUN-PROGRAM.
|
||||
|
||||
Cairo2 does not support JPEG. We generate a command pipeline with ~montage~ and ~convert~ binaries."))
|
||||
|
||||
(in-package #:cl-deck-builder2.draw)
|
||||
|
||||
;; Rough class abstraction:
|
||||
(defclass draw-pipeline ()
|
||||
())
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defparameter *command* nil
|
||||
"The current command line used in the drawing process. Useful for inspection/debug purposes.")
|
||||
|
||||
(defparameter +convert-binary+ "convert"
|
||||
"The path to ImageMagick ~convert~ binary.")
|
||||
|
||||
(defparameter +montage-binary+ "montage"
|
||||
"The path to ImageMagick ~montage~ binary.")
|
||||
|
||||
;; This is for full deck list. I can have a few params for different
|
||||
;; decks e.g. main, side, extra.
|
||||
;;
|
||||
;; TODO Having all these params is ugly. Maybe a hash table?
|
||||
(defparameter +command-line-params-main-deck+
|
||||
;;"-resize '421x614>' -geometry +5+5 -tile 10x")
|
||||
; "-geometry +5+5 -tile 10x -texture '/home/user/public/noise.png'" ;;'#ff8b53'"
|
||||
"-geometry +5+5 -tile 10x -background '#FF8B53'"
|
||||
"Parameters for making the MAIN deck. It's 10x cards wide, There's 5 px between cards. The color is from <https://yugioh.fandom.com/wiki/Card_colors>.
|
||||
|
||||
This is for full main deck list. I can have a few params for different decks e.g. main, side, extra. This one is for the main deck. Parameters for making the MAIN deck: It's 10x cards wide,There's 5 px between cards.")
|
||||
|
||||
(defparameter +command-line-params-extra-deck+
|
||||
;; "-resize '421x614>' -geometry +5+5 -tile 15x")
|
||||
"-geometry +5+5 -tile 15x -background '#BC5A84'"
|
||||
"Parameters for making the EXTRA deck. It's 15x cards wide,There's 5 px between cards.")
|
||||
|
||||
(defparameter +command-line-params-side-deck+
|
||||
;; "-resize '421x614>' -geometry +5+5 -tile 15x")
|
||||
"-geometry +5+5 -tile 15x -background '#1D9E74'"
|
||||
"Parameters for making the SIDE deck. It's 15x cards wide,There's 5 px between cards.")
|
||||
|
||||
(defparameter +command-line-params-main-deck-output+
|
||||
;; "-resize '421x614>' -geometry +5+5 -tile 15x")
|
||||
;; "-geometry '4310x2496>'"
|
||||
;; "-geometry '2560x>' -background '#FF8B53' -gravity South -splice 0x10"
|
||||
"-background '#FF8B53' -gravity South -splice 0x10"
|
||||
"Parameters for final output of the MAIN deck. It's the width of the MAIN deck output, which will be set to 2560.
|
||||
|
||||
TODO: Use identify to query this information.")
|
||||
|
||||
(defparameter +command-line-params-extra-deck-output+
|
||||
;; "-resize '421x614>' -geometry +5+5 -tile 15x")
|
||||
;; "-geometry '4310x2496>'"
|
||||
"-geometry '4310>'"
|
||||
"Parameters for final output of the EXTRA and SIDE decks. It's exactly the width of the MAIN deck output, which happens to be 4310x2496.
|
||||
|
||||
TODO: Use identify to query this information.
|
||||
|
||||
Parameters for final output of the EXTRA and SIDE decks. It's exactly the width of the MAIN deck output, which happens to be 4310x2496. Card images are almost always 421x614 px in size, and we add 5 px of padding around all sides. So that's where this number comes from (((421+10)*10) = 4310).")
|
||||
|
||||
(defparameter +command-line-params-final-output+
|
||||
;; "-resize '421x614>' -geometry +0+0 -tile 1x")
|
||||
"-geometry +0+0 -tile 1x -background none"
|
||||
"The options passed to convert for the final image result. Smoosh everything together into one 1x wide image!")
|
||||
|
||||
(defparameter +command-line-params-watermark-lower-right+
|
||||
"-gravity southeast -geometry +10+10 -draw \"image Over 32,32 256,256 'runew.png'\""
|
||||
"Draw a watermark in the bottom right with this command.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun command-setup (file-list pathname &key (deck-type :main) (dry-run nil))
|
||||
"Set up the *COMMAND* parameter for use in COMMAND-EXEC.
|
||||
|
||||
You can kind of see the structure of the command:
|
||||
|
||||
~A ~A ~{\"~A\" ~} miff:- | ~A miff:- ~A \"~A\"
|
||||
|
||||
That's \"montage [input-options] [list-of-input-filenames] miff:- | convert miff:- [output-options] [output-filename]\".
|
||||
|
||||
We use the MIFF format to speed up the whole montage process.
|
||||
|
||||
ARGUMENTS:
|
||||
|
||||
FILE-LIST The list of files to be used in the generation of the deck image. The files must exist.
|
||||
PATHNAME The pathname of the output file.
|
||||
DECK-TYPE The kind of deck we'll be generating. Allowed values are :MAIN :SIDE :EXTRA and :FINAL. The default is :MAIN.
|
||||
DRY-RUN If DRY-RUN is T, instead of filling in a whole file list, which can be clunky to view, we replace the list of files with ~'(FILE LIST)~. Very kludgy.
|
||||
|
||||
SEE *COMMAND*
|
||||
SEE COMMAND-EXEC"
|
||||
(let* ((extra-params (case deck-type
|
||||
(:main +command-line-params-main-deck+)
|
||||
(:extra +command-line-params-extra-deck+)
|
||||
(:side +command-line-params-side-deck+)
|
||||
(:final +command-line-params-final-output+)
|
||||
(otherwise "")))
|
||||
(output-params (case deck-type
|
||||
(:main +command-line-params-main-deck-output+)
|
||||
((:side :extra) +command-line-params-extra-deck-output+)
|
||||
(otherwise "")))
|
||||
(command (format nil "~A ~A ~{\"~A\" ~} miff:- | ~A miff:- ~A \"~A\""
|
||||
+montage-binary+
|
||||
extra-params
|
||||
(if dry-run
|
||||
'(file list)
|
||||
file-list)
|
||||
+convert-binary+
|
||||
output-params
|
||||
pathname)))
|
||||
(setf *command* command)))
|
||||
|
||||
(defun command-exec (&key (command *command*) (dry-run nil))
|
||||
"Execute the command with UIOP:RUN-PROGRAM, or do a dry run.
|
||||
|
||||
ARGUMENTS:
|
||||
COMMAND The command line to execute. It doesn't have to be anything to do with ImageMagick. This is a generic wrapper around UIOP:RUN-PROGRAM. The default command line to pass is *COMMAND*.
|
||||
DRY-RUN If DRY-RUN is T, use FORMAT to output a string instead."
|
||||
(if dry-run
|
||||
(v:info :draw "~a" command)
|
||||
(uiop:run-program command
|
||||
:output t
|
||||
:error-output t)))
|
||||
|
||||
|
||||
(defun identify-image (pathname &optional (dry-run nil))
|
||||
"Wrapper around ImageMagick IDENTIFY.
|
||||
|
||||
PATHNAME The path to the file to identify.
|
||||
DRY-RUN Inform COMMAND-EXEC that this is a DRY-RUN. "
|
||||
(command-exec :command (format nil "identify \"~A\"" pathname)
|
||||
:dry-run dry-run))
|
||||
|
||||
;; TODO The way we pass args around like this is ugly af. Maybe a STRUCT?
|
||||
;;
|
||||
;; This absolutely needs a rewrite. I should be using classes for this.
|
||||
(defun make-passcode-files-list (types pathname-name ydk)
|
||||
"Build TYPES -> MERGE-PATHNAMES ASSOCIATION-LIST. TYPES gets filled in
|
||||
with PATHNAME-NAME and PASSCODE info:
|
||||
|
||||
(:MAIN OG_bechi_21-Chaos Turbo-main.jpg ( main deck ... ))
|
||||
(:SIDE OG_bechi_21-Chaos Turbo-side.jpg ( side deck ... ))
|
||||
(:EXTRA OG_bechi_21-Chaos Turbo-extra.jpg ( extra deck ... ))
|
||||
|
||||
Then the :FINAL image instead of a list of passcodes, is a list of
|
||||
files passed to STATIC-RELATIVE-FILE-LIST:
|
||||
|
||||
(:FINAL OG_bechi_21-Chaos Turbo-final.jpg (OG_bechi_21-Chaos Turbo-main.jpg
|
||||
OG_bechi_21-Chaos Turbo-extra.jpg
|
||||
OG_bechi_21-Chaos Turbo-side.jpg))
|
||||
|
||||
ARGUMENTS:
|
||||
types A LIST of the types of images we want to generate. May be one of :MAIN, :SIDE, :EXTRA, or :FINAL.
|
||||
pathname-name The PATHNAME-NAME of the file you want to create. E.g. if you had a YDK file named \"Chaos Turbo 2023.ydk\" you should pass the output of (PATHNAME-NAME #P\"Chaos Turbo 2023.ydk\"
|
||||
ydk The YDK information we're generating the deck for."
|
||||
(loop for type in types
|
||||
collect
|
||||
(list type
|
||||
(make-static-filename-kind pathname-name type)
|
||||
(case type
|
||||
(:main (ydk-main-deck-of ydk))
|
||||
(:extra (ydk-extra-deck-of ydk))
|
||||
(:side (ydk-side-deck-of ydk))))))
|
||||
|
||||
(defun draw-deck-image (ydk pathname &key (dry-run nil))
|
||||
"Parse a YDK, setup a bunch of command lines, and generate a deck image. Very clunky and clumsy, most likely candidate for a rewrite right here.
|
||||
|
||||
ARGUMENTS
|
||||
DATA Raw YDK data. May be anything that INITIALIZE-WITH-CONTENT can process.
|
||||
PATHNAME The path to where the output images will be stored. The PATHNAME-NAME will be munged to have ~-main~,~-side~,~-extra-~, or ~-final~ appended to it.
|
||||
DRY-RUN Do a dry run.
|
||||
|
||||
SEE INITIALIZE-WITH-CONTENT"
|
||||
|
||||
(v:info :draw "DRAW-DECK-IMAGE: ~a" pathname)
|
||||
|
||||
(let* ((pathname-name (typecase pathname
|
||||
(pathname (pathname-name pathname))
|
||||
(string pathname)
|
||||
(integer (princ-to-string pathname))))
|
||||
(datum (make-passcode-files-list '(:main :extra :side)
|
||||
pathname-name ydk)))
|
||||
|
||||
;; Build the three images
|
||||
(loop for data in datum do
|
||||
(destructuring-bind (kind path lst)
|
||||
data
|
||||
(if (not lst)
|
||||
(progn
|
||||
;; Whatever item this is, there are no cards in
|
||||
;; it. Remove it from the query.
|
||||
;; (format t "~A~%" datum)
|
||||
(setf datum (delete kind datum :key #'car)))
|
||||
(progn
|
||||
;; There are cards in it.
|
||||
(v:info :draw "Generating ~A deck: ~A (~A cards)" kind path (length lst))
|
||||
(if (probe-file path)
|
||||
(v:info :draw "File exists: ~A" path)
|
||||
(progn
|
||||
(command-setup (ygo-probe-file-list lst) path :deck-type kind :dry-run dry-run)
|
||||
(command-exec :dry-run dry-run)))))))
|
||||
|
||||
(let* (;; KEY-PAIRS is :MAIN + (:MAIN :EXTRA:) + (:MAIN :SIDE) if they exist.
|
||||
;; If we filtered out something above, it won't show up in this list...
|
||||
(key-pairs (alexandria:map-product 'list
|
||||
'(:main)
|
||||
(remove :main (mapcar #'first datum))))
|
||||
;; COMBINATIONS-LIST is every file name combined,
|
||||
;; e.g. Deck-Name-MAIN, Deck-Name-MAIN-EXTRA,
|
||||
;; Deck-Name-FINAL; the ones from KEY-PAIRS noted above
|
||||
;; combined with PATHNAME-NAME. It's in a similar format as
|
||||
;; the output from MAKE-PASSCODE-FILES-LIST.
|
||||
(combinations-list
|
||||
(loop for key-pair in key-pairs
|
||||
collect
|
||||
(list
|
||||
;; double loop ... ? Who cares, it works...
|
||||
(loop for key-pair in key-pair
|
||||
collect (make-static-filename-kind pathname-name key-pair))
|
||||
(make-static-filename-kind pathname-name key-pair))))
|
||||
(final-filenames
|
||||
(append
|
||||
(mapcar #'second datum)
|
||||
(mapcar #'second combinations-list)
|
||||
(list (make-static-filename-kind pathname-name :final)))))
|
||||
|
||||
(merge-images (car (last final-filenames)) (mapcar #'second datum))
|
||||
(loop for combination in combinations-list do
|
||||
(merge-images (second combination) (first combination) dry-run))
|
||||
|
||||
(relative-file-list final-filenames))))
|
||||
|
||||
(defun merge-images (final-filename image-lst &optional dry-run)
|
||||
"Merge images in IMAGE-LST into FINAL-FILENAME.
|
||||
|
||||
IMAGE-LST The list of images to be merged. Will be merged in order specified.
|
||||
FINAL-FILENAME The output filename.
|
||||
DRY-RUN Do a dry run."
|
||||
(v:info :draw "Generating final image: ~A ~a" final-filename image-lst)
|
||||
;; MAPCAR #'SECOND??? Oh Well, it works.
|
||||
(if (probe-file final-filename)
|
||||
(v:info :draw "File exists: ~A" final-filename)
|
||||
(progn
|
||||
(command-setup (static-probe-file-list image-lst)
|
||||
final-filename :deck-type :final :dry-run dry-run)
|
||||
(command-exec :dry-run dry-run))))
|
||||
146
src/i18n.lisp
Normal file
146
src/i18n.lisp
Normal file
@ -0,0 +1,146 @@
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.i18n
|
||||
(:use :cl)
|
||||
(:import-from :gettext #:*current-locale*)
|
||||
(:export
|
||||
#:_
|
||||
#:n_
|
||||
#:reload-translations
|
||||
#:list-loaded-locales
|
||||
#:*current-locale*
|
||||
#:set-locale
|
||||
#:with-locale
|
||||
#:update-djula.pot
|
||||
#:generate-templates-list)
|
||||
(:documentation "Internationalization Utilities"))
|
||||
|
||||
(in-package #:cl-deck-builder2.i18n)
|
||||
|
||||
(defun setup-gettext ()
|
||||
(setf djula:*translation-backend* :gettext
|
||||
(gettext:textdomain) "cl-deck-builder2")
|
||||
(gettext:setup-gettext #.*package* "cl-deck-builder2"))
|
||||
|
||||
(setup-gettext)
|
||||
|
||||
(defun reload-translations ()
|
||||
(format *debug-io* "~%Reading all *.mo files...")
|
||||
;; Clear gettext's cache
|
||||
(clrhash gettext::*catalog-cache*)
|
||||
(setup-gettext)
|
||||
(gettext:preload-catalogs
|
||||
;; Tell gettext where to find the .mo files
|
||||
#.(asdf:system-relative-pathname :cl-deck-builder2 "locale/"))
|
||||
;; What about this?
|
||||
(setf djula::*gettext-domain* "cl-deck-builder2"))
|
||||
|
||||
;; Only preload the translations into the image if we're not deployed yet.
|
||||
(unless (deploy:deployed-p)
|
||||
(reload-translations))
|
||||
|
||||
;; Run this when developping to reload the translations
|
||||
#+ (or)
|
||||
(progn
|
||||
;; Clear gettext's cache
|
||||
(clrhash gettext::*catalog-cache*)
|
||||
(gettext:preload-catalogs
|
||||
;; Tell gettext where to find the .mo files
|
||||
#.(asdf:system-relative-pathname :cl-deck-builder2 "locale/")))
|
||||
|
||||
;; Run this to see the list of loaded message for a specific locale
|
||||
#+ (or)
|
||||
(gettext::catalog-messages
|
||||
(gethash '("es_ES" :LC_MESSAGES "cl-deck-builder2")
|
||||
gettext::*catalog-cache*))
|
||||
|
||||
;; Test the translation of a string
|
||||
#+ (or)
|
||||
(with-locale ("es_ES")
|
||||
(_ "Please login to continue"))
|
||||
|
||||
|
||||
#+ (or)
|
||||
(set-locale "es_ES")
|
||||
|
||||
#+ (or)
|
||||
*current-locale*
|
||||
|
||||
(defun list-loaded-locales ()
|
||||
"Get the list of locales loaded in gettext's cache."
|
||||
(remove-duplicates
|
||||
(mapcar #'first
|
||||
(alexandria:hash-table-keys
|
||||
gettext::*catalog-cache*))
|
||||
:test #'string=))
|
||||
|
||||
(defun set-locale (locale)
|
||||
"Setf gettext:*current-locale* and djula:*current-language* if LOCALE seems valid."
|
||||
;; It is valid to set the locale to nil.
|
||||
(when (and locale
|
||||
(not (member locale (list-loaded-locales)
|
||||
:test 'string=)))
|
||||
(error "Locale not valid or not available: ~s" locale))
|
||||
(setf *current-locale* locale
|
||||
djula:*current-language* locale))
|
||||
|
||||
(defmacro with-locale ((locale) &body body)
|
||||
"Calls BODY with gettext:*current-locale* and djula:*current-language* set to LOCALE."
|
||||
`(let (*current-locale* djula:*current-language*)
|
||||
(set-locale ,locale)
|
||||
,@body))
|
||||
|
||||
;; (trace _)
|
||||
|
||||
;; (trace djula:translate gettext:gettext* gettext::lookup)
|
||||
|
||||
;; (_ "hi")
|
||||
|
||||
#|
|
||||
This could technically be just
|
||||
(mapcan #'djula.locale:file-template-translate-strings
|
||||
(djula:list-asdf-system-templates :cl-deck-builder2 "templates"))
|
||||
|
||||
But I (fstamour) made it just a bit more complex in order to keep track of the source (just the
|
||||
filename) of each translatable strings. Hence why the hash-table returned is named `locations`.
|
||||
|#
|
||||
(defun extract-translate-strings ()
|
||||
"Extract all {_ ... _} string from the djula templates."
|
||||
(loop
|
||||
:with locations = (make-hash-table :test 'equal)
|
||||
:for path :in (djula:list-asdf-system-templates :cl-deck-builder2 "templates")
|
||||
:for strings = (djula.locale:file-template-translate-strings path)
|
||||
:do (loop :for string :in strings
|
||||
:unless (gethash string locations)
|
||||
:do (setf (gethash string locations) path))
|
||||
:finally (return locations)))
|
||||
|
||||
(defun update-djula.pot ()
|
||||
"Update djula.pot from *.html files."
|
||||
(with-open-file (s (asdf:system-relative-pathname
|
||||
:cl-deck-builder2 "locale/templates/LC_MESSAGES/djula.pot")
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(let* ((locations (extract-translate-strings))
|
||||
(strings (alexandria:hash-table-keys locations)))
|
||||
(loop
|
||||
:for string :in strings
|
||||
:for location = (gethash string locations)
|
||||
:do
|
||||
(format s "~%#: ~a~%#, lisp-format~%msgid ~s~%msgstr \"\" ~%"
|
||||
(enough-namestring
|
||||
location
|
||||
(asdf:system-source-directory :cl-deck-builder2))
|
||||
string)))))
|
||||
|
||||
;; TODO UPDATE-STATIC-TEMPLATE-FILES
|
||||
(defun generate-templates-list ()
|
||||
"Generate a list of all files in the \"templates/\" subdirectory, in the form of (:STATIC-FILE \"file...\"). Currently you have to copy/paste this into the ASDF file whenever you add a template."
|
||||
(let* ((lst '())
|
||||
(root (asdf:system-relative-pathname :cl-deck-builder2 "templates/")))
|
||||
(cl-fad:walk-directory
|
||||
root
|
||||
(lambda (name)
|
||||
(push (list :static-file (namestring (uiop:enough-pathname name root))) lst)))
|
||||
lst))
|
||||
112
src/main.lisp
Normal file
112
src/main.lisp
Normal file
@ -0,0 +1,112 @@
|
||||
;;;; src/main.lisp
|
||||
;;;;
|
||||
;;;; Main App Definition And Entry Point
|
||||
;;;;
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.draw
|
||||
#:cl-deck-builder2.toolkit
|
||||
#:cl-deck-builder2.models
|
||||
;;#:cl-deck-builder2-test
|
||||
)
|
||||
(:local-nicknames
|
||||
(#:v #:org.shirakumo.verbose))
|
||||
(:import-from :cl-deck-builder2.config
|
||||
:config
|
||||
:*app-log-file*)
|
||||
(:import-from :clack
|
||||
:clackup)
|
||||
(:export
|
||||
:start
|
||||
:stop
|
||||
:my/start
|
||||
:main)
|
||||
(:documentation "The main package for the deck builder project.
|
||||
|
||||
This package exports the START and STOP functions, as well as the convenience function MY/START."))
|
||||
|
||||
(in-package :cl-deck-builder2)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar *appfile-path*
|
||||
(asdf:system-relative-pathname :cl-deck-builder2 #P"app.lisp")
|
||||
"The application path we pass to CLACK:CLACKUP.")
|
||||
|
||||
(defvar *clack-handler* nil
|
||||
"The CLACK handler currently running. NIL if there is no server running.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun start (&rest args &key server port debug &allow-other-keys)
|
||||
"Start the app. If the app is already running, raise an ERROR."
|
||||
(declare (ignore server port debug))
|
||||
(when *clack-handler*
|
||||
(restart-case (error "Server is already running.")
|
||||
(restart-server ()
|
||||
:report "Restart the server"
|
||||
(stop))))
|
||||
(v:info :main "CLACKUP")
|
||||
(setf *clack-handler* (apply #'clackup *appfile-path* args)))
|
||||
|
||||
(defun stop ()
|
||||
"Stop the app, if it is running."
|
||||
(v:info :main "CLACK:STOP")
|
||||
(prog1
|
||||
(clack:stop *clack-handler*)
|
||||
(setf *clack-handler* nil)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun my/start (&rest args)
|
||||
"Convenience function for invoking RESTART-SERVER in the case that the server is already running."
|
||||
(handler-bind
|
||||
((simple-error (lambda (c)
|
||||
(format t "~A~&Invoking RESTART-SERVER." c)
|
||||
(invoke-restart 'restart-server))))
|
||||
;; TODO Multiple Addresses?
|
||||
;; TODO Put it behind NGINX?
|
||||
;; TODO sslh?
|
||||
(apply #'start args)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Loader Customize
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defmacro start-helper (service-name &body body)
|
||||
`(progn
|
||||
(v:info :app "~&Starting ~a ...~&" ,service-name)
|
||||
(if ,@body
|
||||
(v:info :app "~&... started.~&")
|
||||
(v:info :app "~&... failed?~&"))))
|
||||
|
||||
;; Initialize Logging
|
||||
;;
|
||||
;; (v:output-here *standard-output*)
|
||||
;;
|
||||
(defun main ()
|
||||
(v:output-here (open *app-log-file* :direction :output
|
||||
:if-does-not-exist :create
|
||||
:if-exists :append))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(v:start v:*global-controller*)
|
||||
|
||||
(start-helper "slynk server"
|
||||
(apply #'slynk:create-server (config :slynk)))
|
||||
|
||||
(v:info :app "~&Constructing database...~&")
|
||||
;; (apply #'create-table *class-list*)
|
||||
(ensure-tables-exist)
|
||||
(v:info :app "~&...complete~%")
|
||||
|
||||
(start-helper "web app"
|
||||
(apply #'my/start (config :server)))
|
||||
|
||||
(start-helper "WebSocket Server Side Client"
|
||||
(handler-case
|
||||
(apply #'cl-deck-builder2.web::make-chat-client (config :websocket))
|
||||
(usocket:connection-refused-error () nil)
|
||||
(usocket:connection-reset-error () nil))))
|
||||
46
src/models/attachment.lisp
Normal file
46
src/models/attachment.lisp
Normal file
@ -0,0 +1,46 @@
|
||||
#|
|
||||
|
||||
# File Attachments
|
||||
|
||||
Attachment class for saving metadata into RDBMS
|
||||
|
||||
See MITO-ATTACHMENT for more information: <https://github.com/fukamachi/mito-attachment>
|
||||
|
||||
TODO AWS Storage / CC API Upload?
|
||||
|
||||
Here's the bit of code for the FILEs:
|
||||
|
||||
;; (destructuring-bind (content filename content-type)
|
||||
;; file
|
||||
;; (if (and (eq (type-of content) 'flex::vector-input-stream)
|
||||
;; (> (length (flex::vector-stream-vector content)) 0))
|
||||
;; ...))
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.attachment)
|
||||
|
||||
(defclass attachment (mito-attachment:attachment) ()
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun create-attachment (content file-key content-type)
|
||||
"Use CREATE-DAO to construct a new ATTACHMENT instance. Return the instance if successful, NIL otherwise."
|
||||
(create-dao 'attachment
|
||||
:content content
|
||||
:file-key file-key
|
||||
:content-type content-type))
|
||||
|
||||
(defun attachment-valid-p (file)
|
||||
"Helper function. Ensure FILE data from Caveman has valid:
|
||||
|
||||
- Type: 'FLEX::VECTOR-INPUT-STREAM
|
||||
- Filename: Length > 0
|
||||
- File Length: Content Length > 0"
|
||||
(destructuring-bind (content filename content-type)
|
||||
file
|
||||
;; XXX Don't ignore content type?
|
||||
(declare (ignore content-type))
|
||||
(and (eq (type-of content) 'flex::vector-input-stream)
|
||||
(> (length (flex::vector-stream-vector content)) 0)
|
||||
(> (length filename) 0))))
|
||||
198
src/models/category-2.lisp
Normal file
198
src/models/category-2.lisp
Normal file
@ -0,0 +1,198 @@
|
||||
#|
|
||||
|
||||
src/models/category-2.lisp
|
||||
|
||||
Category v2
|
||||
|
||||
Based on DB_NestedSet <https://pear.php.net/manual/en/package.DB_NestedSet.php>
|
||||
|
||||
It looks like keepAsArray controls whether or not it outputs a list or
|
||||
something passed through MAKE-INSTANCE.
|
||||
|
||||
|#
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.category-2
|
||||
(:use #:cl))
|
||||
|
||||
(:in-package #:cl-deck-builder2.models.category-2)
|
||||
|
||||
;; CLASSES
|
||||
|
||||
|
||||
#|
|
||||
# The table which holds the structure
|
||||
CREATE TABLE tb_nodes (
|
||||
STRID int(11) NOT NULL auto_increment,
|
||||
ROOTID int(11) NOT NULL default '0',
|
||||
l int(11) NOT NULL default '0',
|
||||
r int(11) NOT NULL default '0',
|
||||
PARENT int(11) NOT NULL default '0',
|
||||
STREH int(11) NOT NULL default '0',
|
||||
LEVEL int(11) NOT NULL default '0',
|
||||
STRNA char(128) NOT NULL default '',
|
||||
PRIMARY KEY (STRID),
|
||||
KEY ROOTID (ROOTID),
|
||||
KEY STREH (STREH),
|
||||
KEY l (l),
|
||||
KEY r (r),
|
||||
KEY LEVEL (LEVEL),
|
||||
KEY SRLR (ROOTID,l,r),
|
||||
KEY parent (PARENT)
|
||||
) TYPE=MyISAM COMMENT='NestedSet table';
|
||||
|#
|
||||
|
||||
(defclass db-nested-set-node (registered-table-class)
|
||||
((root-id :col-type :integer :default 1)
|
||||
(left :col-type :integer :default 1)
|
||||
(right :col-type :integer :default 1)
|
||||
(parent :col-type :integer :default 1))
|
||||
;; (streh :col-type :integer :default 0)
|
||||
;; (level :col-type :integer :default 0)
|
||||
;; (strna :col-type (:varchar 128) :default "")
|
||||
(:documentation "Class for DB_NestedSet Nodes."))
|
||||
|
||||
(defmethod closer-mop:validate-superclass ((class db-nested-set-node)
|
||||
(superclass registered-table-class))
|
||||
t)
|
||||
|
||||
|
||||
|
||||
#|
|
||||
# A table which is used for a little table locking to avoid conflicts
|
||||
CREATE TABLE tb_locks (
|
||||
lockID char(32) NOT NULL default '',
|
||||
lockTable char(32) NOT NULL default '',
|
||||
lockStamp int(11) NOT NULL default '0',
|
||||
PRIMARY KEY (lockID,lockTable)
|
||||
) TYPE=MyISAM COMMENT='Table locks for NestedSet';
|
||||
|#
|
||||
|
||||
(defclass db-nested-set-lock ()
|
||||
(;; TODO Being able to switch the table name would be cool. With
|
||||
;; MITO It would be a class. I'm not sure how to code that.
|
||||
(lock-table :col-type (:varchar 32))
|
||||
(lock-stamp :col-type :timestamp
|
||||
:initform (local-time:now)
|
||||
:inflate #'local-time:universal-to-timestamp
|
||||
:deflate #'local-time:timestamp-to-universal))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "Class for DB_NestedSet Locks Table."))
|
||||
|
||||
;; Helper Class
|
||||
(defclass db-nested-set ()
|
||||
((db-nested-set-nodes :accessor nested-set-nodes
|
||||
:initform '())
|
||||
(db-nested-set-locks :accessor nested-set-nodes
|
||||
:initform '())))
|
||||
|
||||
;; GENERICS
|
||||
|
||||
(defgeneric create-root-node (obj))
|
||||
(defgeneric create-left-node (obj))
|
||||
(defgeneric create-right-node (obj))
|
||||
(defgeneric create-sub-node (obj))
|
||||
|
||||
(defgeneric delete-node (obj))
|
||||
|
||||
(defgeneric get-all-nodes (obj))
|
||||
(defgeneric get-root-nodes (obj))
|
||||
|
||||
(defgeneric pick-node (obj))
|
||||
|
||||
(defgeneric update-node (obj))
|
||||
|
||||
(defgeneric get-branch (obj))
|
||||
(defgeneric get-children (obj))
|
||||
(defgeneric get-parent (obj))
|
||||
(defgeneric get-parents (obj))
|
||||
(defgeneric get-siblings (obj))
|
||||
(defgeneric get-sub-branch (obj))
|
||||
|
||||
(defgeneric is-parent (obj))
|
||||
|
||||
(defgeneric move-across (obj))
|
||||
(defgeneric move-cleanup (obj))
|
||||
(defgeneric move-root-to-root (obj))
|
||||
(defgeneric move-tree (obj))
|
||||
|
||||
;; METHODS
|
||||
|
||||
(defmethod create-root-node ((obj db-nested-set)))
|
||||
(defmethod create-left-node ((obj db-nested-set)))
|
||||
(defmethod create-right-node ((obj db-nested-set)))
|
||||
(defmethod create-sub-node ((obj db-nested-set)))
|
||||
|
||||
(defmethod delete-node ((obj db-nested-set)))
|
||||
|
||||
(defmethod get-all-nodes ((obj db-nested-set)))
|
||||
(defmethod get-root-nodes ((obj db-nested-set)))
|
||||
|
||||
(defmethod pick-node ((obj db-nested-set)))
|
||||
|
||||
(defmethod update-node ((obj db-nested-set)))
|
||||
|
||||
(defmethod get-branch ((obj db-nested-set)))
|
||||
(defmethod get-children ((obj db-nested-set)))
|
||||
(defmethod get-parent ((obj db-nested-set)))
|
||||
(defmethod get-parents ((obj db-nested-set)))
|
||||
(defmethod get-siblings ((obj db-nested-set)))
|
||||
(defmethod get-sub-branch ((obj db-nested-set)))
|
||||
|
||||
(defmethod is-parent ((obj db-nested-set)))
|
||||
|
||||
(defmethod move-across ((obj db-nested-set)))
|
||||
(defmethod move-cleanup ((obj db-nested-set)))
|
||||
(defmethod move-root-to-root ((obj db-nested-set)))
|
||||
(defmethod move-tree ((obj db-nested-set)))
|
||||
|
||||
#|
|
||||
@$this->cache->flush('function_cache');
|
||||
function & factory($driver, $dsn, $params = array()) {
|
||||
function DB_NestedSet($params) {
|
||||
function _DB_NestedSet() {
|
||||
function _addSQL($addSQL, $type, $prefix = false) {
|
||||
function _debugMessage($msg) {
|
||||
function _getMessage($code) {
|
||||
function _getSelectFields($aliasFields) {
|
||||
function _lockGC() {
|
||||
function _moveAcross($source, $target, $pos, $first = false) {
|
||||
function _moveCleanup($copy = false) {
|
||||
function _moveRoot2Root($source, $target, $pos) {
|
||||
function _processResultSet($sql, $keepAsArray, $fieldsAreAliased) {
|
||||
function _raiseError($code, $mode, $option, $epr = array()) {
|
||||
function _releaseLock($exclusive = false) {
|
||||
function _secSort($nodeSet) {
|
||||
function _secSortCollect($segment, $deepArray, $reset = false) {
|
||||
function _setLock($exclusive = false) {
|
||||
function _testFatalAbort($errobj, $file, $line) {
|
||||
function _values2InsertQuery($values, $addval = false) {
|
||||
function _values2UpdateQuery($values, $addval = false) {
|
||||
function _verifyUserValues($caller, & $values) {
|
||||
function addListener($event, & $listener) {
|
||||
function apiVersion() {
|
||||
function convertTreeModel(& $orig, & $copy, $_parent = false) {
|
||||
function createLeftNode($id, $values) {
|
||||
function createRightNode($id, $values) {
|
||||
function createRootNode($values, $id = false, $first = false, $pos = NESE_MOVE_AFTER) {
|
||||
function createSubNode($id, $values) {
|
||||
function deleteNode($id) {
|
||||
function getAllNodes($keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function getBranch($id, $keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function getChildren($id, $keepAsArray = false, $aliasFields = true, $forceNorder = false, $addSQL = array()) {
|
||||
function getParent($id, $keepAsArray = false, $aliasFields = true, $addSQL = array(), $useDB = true) {
|
||||
function getParents($id, $keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function getRootNodes($keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function getSiblings($id, $keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function getSubBranch($id, $keepAsArray = false, $aliasFields = true, $addSQL = array()) {
|
||||
function isParent($parent, $child) {
|
||||
function moveTree($id, $targetid, $pos, $copy = false) {
|
||||
function pickNode($id, $keepAsArray = false, $aliasFields = true, $idfield = 'id', $addSQL = array()) {
|
||||
function removeListener($event, $listenerID) {
|
||||
function setAttr($attr) {
|
||||
function setDbOption($option, $val) {
|
||||
function setsortMode($sortMode = false) {
|
||||
function testLock() {
|
||||
function triggerEvent($event, & $node, $eparams = false) {
|
||||
function updateNode($id, $values, $_internal = false) {
|
||||
register_shutdown_function(array(& $this, '_DB_NestedSet'));
|
||||
|#
|
||||
877
src/models/category.lisp
Normal file
877
src/models/category.lisp
Normal file
@ -0,0 +1,877 @@
|
||||
#|
|
||||
|
||||
src/models/category.lisp
|
||||
|
||||
TODO All of this needs a serious rewrite.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.category)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defclass category ()
|
||||
((name :accessor name-of
|
||||
:col-type (:varchar 64)
|
||||
:initarg :name)
|
||||
(left :accessor category-left-of
|
||||
:col-type :integer
|
||||
:initarg :left)
|
||||
(right :accessor category-right-of
|
||||
:col-type :integer
|
||||
:initarg :right))
|
||||
(:metaclass registered-table-class)
|
||||
(:unique-key name)
|
||||
(:documentation "Category implementation based on Joe Celko's Nested Set Hierarchy from one of his books."))
|
||||
|
||||
(defun create-category (name left right)
|
||||
(create-dao 'category :name name
|
||||
:left left
|
||||
:right right))
|
||||
|
||||
;; (defmacro category (&body body)
|
||||
;; `(select-dao 'category ,@body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defmethod category-rename ((category category) new-name)
|
||||
(setf (category-name-of category) new-name)
|
||||
(update-dao category))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; Joe Celko Nested Set Hierarchy
|
||||
;;;;
|
||||
;;;; <https://mikehillyer.com/articles/managing-hierarchical-data-in-mysql/>
|
||||
;;;;
|
||||
;;;; * The Nested Set Model
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; CREATE TABLE nested_category (
|
||||
;;;; category_id INT AUTO_INCREMENT PRIMARY KEY,
|
||||
;;;; name VARCHAR(20) NOT NULL,
|
||||
;;;; lft INT NOT NULL,
|
||||
;;;; rgt INT NOT NULL
|
||||
;;;; );
|
||||
;;;;
|
||||
;;;; INSERT INTO nested_category VALUES
|
||||
;;;; (1,'ELECTRONICS',1,20),
|
||||
;;;; (2,'TELEVISIONS',2,9),
|
||||
;;;; (3,'TUBE',3,4),
|
||||
;;;; (4,'LCD',5,6),
|
||||
;;;; (5,'PLASMA',7,8),
|
||||
;;;; (6,'PORTABLE ELECTRONICS',10,19),
|
||||
;;;; (7,'MP3 PLAYERS',11,14),
|
||||
;;;; (8,'FLASH',12,13),
|
||||
;;;; (9,'CD PLAYERS',15,16),
|
||||
;;;; (10,'2 WAY RADIOS',17,18);
|
||||
;;;;
|
||||
;;;; SELECT * FROM nested_category ORDER BY category_id;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-insert-fake-data ()
|
||||
"Insert Fake Data. These LEFT-IDs will mess with your stuff...
|
||||
|
||||
TODO Figure out how to fix that."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar (lambda (values-list)
|
||||
(destructuring-bind (name left right)
|
||||
values-list
|
||||
(mito:create-dao 'category
|
||||
:name name
|
||||
:left left
|
||||
:right right)))
|
||||
'(("ELECTRONICS" 1 20)
|
||||
("TELEVISIONS" 2 9)
|
||||
("TUBE" 3 4)
|
||||
("LCD" 5 6)
|
||||
("PLASMA" 7 8)
|
||||
("PORTABLE ELECTRONICS" 10 19)
|
||||
("MP3 PLAYERS" 11 14)
|
||||
("FLASH" 12 13)
|
||||
("CD PLAYERS" 15 16)
|
||||
("2 WAY RADIOS" 17 18))))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;;
|
||||
;;;; +-------------+----------------------+-----+-----+
|
||||
;;;; | category_id | name | lft | rgt |
|
||||
;;;; +-------------+----------------------+-----+-----+
|
||||
;;;; | 1 | ELECTRONICS | 1 | 20 |
|
||||
;;;; | 2 | TELEVISIONS | 2 | 9 |
|
||||
;;;; | 3 | TUBE | 3 | 4 |
|
||||
;;;; | 4 | LCD | 5 | 6 |
|
||||
;;;; | 5 | PLASMA | 7 | 8 |
|
||||
;;;; | 6 | PORTABLE ELECTRONICS | 10 | 19 |
|
||||
;;;; | 7 | MP3 PLAYERS | 11 | 14 |
|
||||
;;;; | 8 | FLASH | 12 | 13 |
|
||||
;;;; | 9 | CD PLAYERS | 15 | 16 |
|
||||
;;;; | 10 | 2 WAY RADIOS | 17 | 18 |
|
||||
;;;; +-------------+----------------------+-----+-----+
|
||||
;;;;
|
||||
;;;; * Retrieving a Full Tree
|
||||
;;;;
|
||||
;;;; We can retrieve the full tree through the use of a self-join that
|
||||
;;;; links parents with nodes on the basis that a node’s lft value will
|
||||
;;;; always appear between its parent’s lft and rgt values:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT node.name
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND parent.name = 'ELECTRONICS'
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-full-tree (fields name)
|
||||
(retrieve-by-sql
|
||||
(sxql:select fields
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(:= :parent.name name)))
|
||||
(sxql:order-by :node.left))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +----------------------+
|
||||
;;;; | name |
|
||||
;;;; +----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; +----------------------+
|
||||
;;;;
|
||||
;;;; * Finding all the Leaf Nodes
|
||||
;;;;
|
||||
;;;; Finding all leaf nodes in the nested set model even simpler than the
|
||||
;;;; LEFT JOIN method used in the adjacency list model. If you look at the
|
||||
;;;; nested_category table, you may notice that the lft and rgt values for
|
||||
;;;; leaf nodes are consecutive numbers. To find the leaf nodes, we look
|
||||
;;;; for nodes where rgt = lft + 1:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT name
|
||||
;;;; FROM nested_category
|
||||
;;;; WHERE rgt = lft + 1;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-leaf-nodes ()
|
||||
"Finding all the Leaf Nodes"
|
||||
(select-dao 'category
|
||||
(sxql:where (:= :right (sxql:make-op :+ :left 1)))))
|
||||
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +--------------+
|
||||
;;;; | name |
|
||||
;;;; +--------------+
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; +--------------+
|
||||
;;;;
|
||||
;;;; * Retrieving a Single Path
|
||||
;;;;
|
||||
;;;; With the nested set model, we can retrieve a single path without
|
||||
;;;; having multiple self-joins:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT parent.name
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.name = 'FLASH'
|
||||
;;;; ORDER BY parent.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-path-of (name)
|
||||
(retrieve-by-sql
|
||||
(sxql:select :parent.name
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(:= :node.name name)))
|
||||
(sxql:order-by :parent.left))))
|
||||
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +----------------------+
|
||||
;;;; | name |
|
||||
;;;; +----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; +----------------------+
|
||||
;;;;
|
||||
;;;; * Finding the Depth of the Nodes
|
||||
;;;;
|
||||
;;;; We have already looked at how to show the entire tree, but what if we
|
||||
;;;; want to also show the depth of each node in the tree, to better
|
||||
;;;; identify how each node fits in the hierarchy? This can be done by
|
||||
;;;; adding a COUNT function and a GROUP BY clause to our existing query
|
||||
;;;; for showing the entire tree:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-node-depth (name)
|
||||
"Find the depth of a specific CATEGORY node named NAME."
|
||||
(retrieve-by-sql
|
||||
(sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) 1) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(:= :node.name name)))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:order-by :node.left))))
|
||||
|
||||
(defun category-tree-depth ()
|
||||
"Show the depths of all nodes in the CATEGORY tree."
|
||||
(retrieve-by-sql
|
||||
(sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) 1) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (sxql:make-op :raw "node.left between parent.left and parent.right"))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:order-by :node.left))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | name | depth |
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | ELECTRONICS | 0 |
|
||||
;;;; | TELEVISIONS | 1 |
|
||||
;;;; | TUBE | 2 |
|
||||
;;;; | LCD | 2 |
|
||||
;;;; | PLASMA | 2 |
|
||||
;;;; | PORTABLE ELECTRONICS | 1 |
|
||||
;;;; | MP3 PLAYERS | 2 |
|
||||
;;;; | FLASH | 3 |
|
||||
;;;; | CD PLAYERS | 2 |
|
||||
;;;; | 2 WAY RADIOS | 2 |
|
||||
;;;; +----------------------+-------+
|
||||
;;;;
|
||||
;;;; We can use the depth value to indent our category names with the
|
||||
;;;; CONCAT and REPEAT string functions:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT CONCAT( REPEAT(' ', COUNT(parent.name) - 1), node.name) AS name
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-full-tree-format (&optional (depths (category-tree-depth)))
|
||||
"Output a formatted display of the CATEGORY tree.
|
||||
|
||||
DEPTHS is the depth tree provided by default by CATEGORY-TREE-DEPTH."
|
||||
(with-output-to-string (s)
|
||||
(mapcar (lambda (node)
|
||||
(format s (format nil "~~~d@a~~a~~%"
|
||||
(getf node :depth))
|
||||
"" (getf node :name)))
|
||||
depths)))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +-----------------------+
|
||||
;;;; | name |
|
||||
;;;; +-----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; +-----------------------+
|
||||
;;;;
|
||||
;;;; Of course, in a client-side application you will be more likely to use
|
||||
;;;; the depth value directly to display your hierarchy. Web developers
|
||||
;;;; could loop through the tree, adding <li></li> and <ul></ul> tags as
|
||||
;;;; the depth number increases and decreases.
|
||||
;;;;
|
||||
;;;; * Depth of a Sub-Tree
|
||||
;;;;
|
||||
;;;; When we need depth information for a sub-tree, we cannot limit either
|
||||
;;;; the node or parent tables in our self-join because it will corrupt our
|
||||
;;;; results. Instead, we add a third self-join, along with a sub-query to
|
||||
;;;; determine the depth that will be the new starting point for our
|
||||
;;;; sub-tree:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT node.name, (COUNT(parent.name) - (sub_tree.depth + 1)) AS depth
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent,
|
||||
;;;; nested_category AS sub_parent,
|
||||
;;;; (
|
||||
;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.name = 'PORTABLE ELECTRONICS'
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft
|
||||
;;;; ) AS sub_tree
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.lft BETWEEN sub_parent.lft AND sub_parent.rgt
|
||||
;;;; AND sub_parent.name = sub_tree.name
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
|
||||
(defun category-subtree-depth (name)
|
||||
(retrieve-by-sql
|
||||
(sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) (:+ :sub_tree.depth 1)) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent)
|
||||
(:as :category :sub_parent)
|
||||
(:as (sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) 1) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(:= :node.name name)))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:order-by :node.left))
|
||||
:sub_tree))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(sxql:make-op :raw "node.left between sub_parent.left and sub_parent.right")
|
||||
(:= :sub_parent.name :sub_tree.name)))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:order-by :node.left))))
|
||||
|
||||
;;;;
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | name | depth |
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | PORTABLE ELECTRONICS | 0 |
|
||||
;;;; | MP3 PLAYERS | 1 |
|
||||
;;;; | FLASH | 2 |
|
||||
;;;; | CD PLAYERS | 1 |
|
||||
;;;; | 2 WAY RADIOS | 1 |
|
||||
;;;; +----------------------+-------+
|
||||
;;;;
|
||||
;;;; This function can be used with any node name, including the root
|
||||
;;;; node. The depth values are always relative to the named node.
|
||||
;;;;
|
||||
;;;; * Find the Immediate Subordinates of a Node
|
||||
;;;;
|
||||
;;;; Imagine you are showing a category of electronics products on a
|
||||
;;;; retailer web site. When a user clicks on a category, you would want to
|
||||
;;;; show the products of that category, as well as list its immediate
|
||||
;;;; sub-categories, but not the entire tree of categories beneath it. For
|
||||
;;;; this, we need to show the node and its immediate sub-nodes, but no
|
||||
;;;; further down the tree. For example, when showing the PORTABLE
|
||||
;;;; ELECTRONICS category, we will want to show MP3 PLAYERS, CD PLAYERS,
|
||||
;;;; and 2 WAY RADIOS, but not FLASH.
|
||||
;;;;
|
||||
;;;; This can be easily accomplished by adding a HAVING clause to our previous query:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT node.name, (COUNT(parent.name) - (sub_tree.depth + 1)) AS depth
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent,
|
||||
;;;; nested_category AS sub_parent,
|
||||
;;;; (
|
||||
;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.name = 'PORTABLE ELECTRONICS'
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft
|
||||
;;;; ) AS sub_tree
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.lft BETWEEN sub_parent.lft AND sub_parent.rgt
|
||||
;;;; AND sub_parent.name = sub_tree.name
|
||||
;;;; GROUP BY node.name
|
||||
;;;; HAVING depth <= 1
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
|
||||
(defun category-subtree-max-depth (name &optional (max-depth 1))
|
||||
"TODO This doesn't seem to work. It returns FLASH with DEPTH = 2"
|
||||
(retrieve-by-sql
|
||||
(sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) (:+ :sub_tree.depth 1)) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent)
|
||||
(:as :category :sub_parent)
|
||||
(:as (sxql:select
|
||||
(:node.name (:as (:- (:count :parent.name) 1) :depth))
|
||||
(sxql:from (:as :category :node)
|
||||
(:as :category :parent))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(:= :node.name name)))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:order-by :node.left))
|
||||
:sub_tree))
|
||||
(sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
|
||||
(sxql:make-op :raw "node.left between sub_parent.left and sub_parent.right")
|
||||
(:= :sub_parent.name :sub_tree.name)))
|
||||
(sxql:group-by :node.name)
|
||||
(sxql:having (:<= :depth max-depth))
|
||||
(sxql:order-by :node.left))))
|
||||
|
||||
;;;;
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | name | depth |
|
||||
;;;; +----------------------+-------+
|
||||
;;;; | PORTABLE ELECTRONICS | 0 |
|
||||
;;;; | MP3 PLAYERS | 1 |
|
||||
;;;; | CD PLAYERS | 1 |
|
||||
;;;; | 2 WAY RADIOS | 1 |
|
||||
;;;; +----------------------+-------+
|
||||
;;;;
|
||||
;;;; If you do not wish to show the parent node, change the HAVING depth <= 1 line to HAVING depth = 1.
|
||||
;;;;
|
||||
;;;; * Aggregate Functions in a Nested Set
|
||||
;;;;
|
||||
;;;; Let’s add a table of products that we can use to demonstrate aggregate
|
||||
;;;; functions with:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; CREATE TABLE product
|
||||
;;;; (
|
||||
;;;; product_id INT AUTO_INCREMENT PRIMARY KEY,
|
||||
;;;; name VARCHAR(40),
|
||||
;;;; category_id INT NOT NULL
|
||||
;;;; );
|
||||
;;;;
|
||||
;;;; INSERT INTO product(name, category_id)
|
||||
;;;; VALUES
|
||||
;;;; ('20" TV',3),
|
||||
;;;; ('36" TV',3),
|
||||
;;;; ('Super-LCD 42"',4),
|
||||
;;;; ('Ultra-Plasma 62"',5),
|
||||
;;;; ('Value Plasma 38"',5),
|
||||
;;;; ('Power-MP3 5gb',7),
|
||||
;;;; ('Super-Player 1gb',8),
|
||||
;;;; ('Porta CD',9),
|
||||
;;;; ('CD To go!',9),
|
||||
;;;; ('Family Talk 360',10);
|
||||
;;;;
|
||||
;;;; SELECT * FROM product;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +------------+-------------------+-------------+
|
||||
;;;; | product_id | name | category_id |
|
||||
;;;; +------------+-------------------+-------------+
|
||||
;;;; | 1 | 20" TV | 3 |
|
||||
;;;; | 2 | 36" TV | 3 |
|
||||
;;;; | 3 | Super-LCD 42" | 4 |
|
||||
;;;; | 4 | Ultra-Plasma 62" | 5 |
|
||||
;;;; | 5 | Value Plasma 38" | 5 |
|
||||
;;;; | 6 | Power-MP3 128mb | 7 |
|
||||
;;;; | 7 | Super-Shuffle 1gb | 8 |
|
||||
;;;; | 8 | Porta CD | 9 |
|
||||
;;;; | 9 | CD To go! | 9 |
|
||||
;;;; | 10 | Family Talk 360 | 10 |
|
||||
;;;; +------------+-------------------+-------------+
|
||||
;;;;
|
||||
;;;; Now let’s produce a query that can retrieve our category tree, along
|
||||
;;;; with a product count for each category:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT parent.name, COUNT(product.name)
|
||||
;;;; FROM nested_category AS node ,
|
||||
;;;; nested_category AS parent,
|
||||
;;;; product
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; AND node.category_id = product.category_id
|
||||
;;;; GROUP BY parent.name
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +----------------------+---------------------+
|
||||
;;;; | name | COUNT(product.name) |
|
||||
;;;; +----------------------+---------------------+
|
||||
;;;; | ELECTRONICS | 10 |
|
||||
;;;; | TELEVISIONS | 5 |
|
||||
;;;; | TUBE | 2 |
|
||||
;;;; | LCD | 1 |
|
||||
;;;; | PLASMA | 2 |
|
||||
;;;; | PORTABLE ELECTRONICS | 5 |
|
||||
;;;; | MP3 PLAYERS | 2 |
|
||||
;;;; | FLASH | 1 |
|
||||
;;;; | CD PLAYERS | 2 |
|
||||
;;;; | 2 WAY RADIOS | 1 |
|
||||
;;;; +----------------------+---------------------+
|
||||
;;;;
|
||||
;;;; This is our typical whole tree query with a COUNT and GROUP BY added,
|
||||
;;;; along with a reference to the product table and a join between the
|
||||
;;;; node and product table in the WHERE clause. As you can see, there is a
|
||||
;;;; count for each category and the count of subcategories is reflected in
|
||||
;;;; the parent categories.
|
||||
;;;;
|
||||
;;;; * Adding New Nodes
|
||||
;;;;
|
||||
;;;; ** category-insert-right-of
|
||||
;;;;
|
||||
;;;; If we wanted to add a new node between the TELEVISIONS and PORTABLE
|
||||
;;;; ELECTRONICS nodes, the new node would have lft and rgt values of 10
|
||||
;;;; and 11, and all nodes to its right would have their lft and rgt values
|
||||
;;;; increased by two. We would then add the new node with the appropriate
|
||||
;;;; lft and rgt values. While this can be done with a stored procedure in
|
||||
;;;; MySQL 5, I will assume for the moment that most readers are using 4.1,
|
||||
;;;; as it is the latest stable version, and I will isolate my queries with
|
||||
;;;; a LOCK TABLES statement instead:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; LOCK TABLE nested_category WRITE;
|
||||
;;;;
|
||||
;;;; SELECT @myRight := rgt FROM nested_category
|
||||
;;;; WHERE name = 'TELEVISIONS';
|
||||
;;;;
|
||||
;;;; UPDATE nested_category SET rgt = rgt + 2 WHERE rgt > @myRight;
|
||||
;;;; UPDATE nested_category SET lft = lft + 2 WHERE lft > @myRight;
|
||||
;;;;
|
||||
;;;; INSERT INTO nested_category(name, lft, rgt) VALUES('GAME CONSOLES', @myRight + 1, @myRight + 2);
|
||||
;;;;
|
||||
;;;; UNLOCK TABLES;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-insert-right-of (name &optional left-of)
|
||||
"Create a new category tree. LEFT-OF is the NAME of the node to the
|
||||
left of this new node named NAME. If LEFT-OF is NIL, insert
|
||||
all-the-way at the right."
|
||||
(with-connection (db)
|
||||
(let* ((found (ignore-errors
|
||||
(mito:find-dao 'category :name left-of)))
|
||||
(my-right (if (and left-of found)
|
||||
(ignore-errors
|
||||
(category-right-of found))
|
||||
(max-dao 'category))))
|
||||
(with-transaction
|
||||
(mapcar #'mito:execute-sql
|
||||
(list
|
||||
(sxql:update :category
|
||||
(sxql:set= :right (:+ :right 2))
|
||||
(sxql:where (:> :right my-right)))
|
||||
(sxql:update :category
|
||||
(sxql:set= :left (:+ :left 2))
|
||||
(sxql:where (:> :left my-right)))))
|
||||
(mito:create-dao 'category :name name
|
||||
:left (+ my-right 1)
|
||||
:right (+ my-right 2))))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; We can then check our nesting with our indented tree query:
|
||||
;;;;
|
||||
;;;; +-----------------------+
|
||||
;;;; | name |
|
||||
;;;; +-----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | GAME CONSOLES |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; +-----------------------+
|
||||
;;;;
|
||||
;;;; ** category-insert-new-child
|
||||
;;;;
|
||||
;;;; If we instead want to add a node as a child of a node that has no
|
||||
;;;; existing children, we need to modify our procedure slightly. Let’s add
|
||||
;;;; a new FRS node below the 2 WAY RADIOS node:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; LOCK TABLE nested_category WRITE;
|
||||
;;;;
|
||||
;;;; SELECT @myLeft := lft FROM nested_category
|
||||
;;;;
|
||||
;;;; WHERE name = '2 WAY RADIOS';
|
||||
;;;;
|
||||
;;;; UPDATE nested_category SET rgt = rgt + 2 WHERE rgt > @myLeft;
|
||||
;;;; UPDATE nested_category SET lft = lft + 2 WHERE lft > @myLeft;
|
||||
;;;;
|
||||
;;;; INSERT INTO nested_category(name, lft, rgt) VALUES('FRS', @myLeft + 1, @myLeft + 2);
|
||||
;;;;
|
||||
;;;; UNLOCK TABLES;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-insert-new-child (name left-of)
|
||||
"Create a new category tree. LEFT-OF is the NAME of the node to the
|
||||
left of this new node named NAME."
|
||||
(with-connection (db)
|
||||
(let* ((my-left (category-left-of
|
||||
(mito:find-dao 'category :name left-of))))
|
||||
(with-transaction
|
||||
(mapcar #'mito:execute-sql
|
||||
(list
|
||||
(sxql:update :category
|
||||
(sxql:set= :right (:+ :right 2))
|
||||
(sxql:where (:> :right my-left)))
|
||||
(sxql:update :category
|
||||
(sxql:set= :left (:+ :left 2))
|
||||
(sxql:where (:> :left my-left)))))
|
||||
(mito:create-dao 'category :name name
|
||||
:left (+ my-left 1)
|
||||
:right (+ my-left 2))))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; In this example we expand everything to the right of the left-hand
|
||||
;;;; number of our proud new parent node, then place the node to the right
|
||||
;;;; of the left-hand value. As you can see, our new node is now properly
|
||||
;;;; nested:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; SELECT CONCAT( REPEAT( ' ', (COUNT(parent.name) - 1) ), node.name) AS name
|
||||
;;;; FROM nested_category AS node,
|
||||
;;;; nested_category AS parent
|
||||
;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
|
||||
;;;; GROUP BY node.name
|
||||
;;;; ORDER BY node.lft;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; +-----------------------+
|
||||
;;;; | name |
|
||||
;;;; +-----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | GAME CONSOLES |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; | FRS |
|
||||
;;;; +-----------------------+
|
||||
;;;;
|
||||
;;;; * Deleting Nodes
|
||||
;;;;
|
||||
;;;; ** DONE category-delete-tree
|
||||
;;;;
|
||||
;;;; The last basic task involved in working with nested sets is the
|
||||
;;;; removal of nodes. The course of action you take when deleting a node
|
||||
;;;; depends on the node’s position in the hierarchy; deleting leaf nodes
|
||||
;;;; is easier than deleting nodes with children because we have to handle
|
||||
;;;; the orphaned nodes.
|
||||
;;;;
|
||||
;;;; When deleting a leaf node, the process if just the opposite of adding
|
||||
;;;; a new node, we delete the node and its width from every node to its
|
||||
;;;; right:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; LOCK TABLE nested_category WRITE;
|
||||
;;;;
|
||||
;;;; SELECT @myLeft := lft, @myRight := rgt, @myWidth := rgt - lft + 1
|
||||
;;;; FROM nested_category
|
||||
;;;; WHERE name = 'GAME CONSOLES';
|
||||
;;;;
|
||||
;;;; DELETE FROM nested_category WHERE lft BETWEEN @myLeft AND @myRight;
|
||||
;;;;
|
||||
;;;; UPDATE nested_category SET rgt = rgt - @myWidth WHERE rgt > @myRight;
|
||||
;;;; UPDATE nested_category SET lft = lft - @myWidth WHERE lft > @myRight;
|
||||
;;;;
|
||||
;;;; UNLOCK TABLES;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-delete-tree (name)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(let ((found (mito:find-dao 'category :name name)))
|
||||
(if found
|
||||
(let* ((my-left (category-left-of found))
|
||||
(my-right (category-right-of found))
|
||||
(my-width (1+ (- my-right my-left))))
|
||||
(mapcar #'mito:execute-sql
|
||||
(list
|
||||
(sxql:delete-from :category
|
||||
(sxql:where (sxql:make-op :raw
|
||||
(format nil "left between ~d and ~d"
|
||||
my-left my-right))))
|
||||
(sxql:update :category
|
||||
(sxql:set= :right (:- :right my-width))
|
||||
(sxql:where (:> :right my-right)))
|
||||
(sxql:update :category
|
||||
(sxql:set= :left (:- :left my-width))
|
||||
(sxql:where (:> :left my-right)))))))))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; And once again, we execute our indented tree query to confirm that our
|
||||
;;;; node has been deleted without corrupting the hierarchy:
|
||||
;;;;
|
||||
;;;; +-----------------------+
|
||||
;;;; | name |
|
||||
;;;; +-----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | MP3 PLAYERS |
|
||||
;;;; | FLASH |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; | FRS |
|
||||
;;;; +-----------------------+
|
||||
;;;;
|
||||
;;;; This approach works equally well to delete a node and all its children:
|
||||
;;;;
|
||||
;;;; And once again, we query to see that we have successfully deleted an entire sub-tree:
|
||||
;;;;
|
||||
;;;; +-----------------------+
|
||||
;;;; | name |
|
||||
;;;; +-----------------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | PORTABLE ELECTRONICS |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; | FRS |
|
||||
;;;; +-----------------------+
|
||||
;;;;
|
||||
;;;; ** category-delete-and-reparent
|
||||
;;;;
|
||||
;;;; The other scenario we have to deal with is the deletion of a parent
|
||||
;;;; node but not the children. In some cases you may wish to just change
|
||||
;;;; the name to a placeholder until a replacement is presented, such as
|
||||
;;;; when a supervisor is fired. In other cases, the child nodes should all
|
||||
;;;; be moved up to the level of the deleted parent:
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC sql
|
||||
;;;; LOCK TABLE nested_category WRITE;
|
||||
;;;;
|
||||
;;;; SELECT @myLeft := lft, @myRight := rgt, @myWidth := rgt - lft + 1
|
||||
;;;; FROM nested_category
|
||||
;;;; WHERE name = 'PORTABLE ELECTRONICS';
|
||||
;;;;
|
||||
;;;; DELETE FROM nested_category WHERE lft = @myLeft;
|
||||
;;;;
|
||||
;;;; UPDATE nested_category SET rgt = rgt - 1, lft = lft - 1 WHERE lft BETWEEN @myLeft AND @myRight;
|
||||
;;;; UPDATE nested_category SET rgt = rgt - 2 WHERE rgt > @myRight;
|
||||
;;;; UPDATE nested_category SET lft = lft - 2 WHERE lft > @myRight;
|
||||
;;;;
|
||||
;;;; UNLOCK TABLES;
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; #+BEGIN_SRC lisp
|
||||
|
||||
(defun category-delete-and-reparent (name)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(let ((found (mito:find-dao 'category :name name)))
|
||||
(if found
|
||||
(let* ((my-left (category-left-of found))
|
||||
(my-right (category-right-of found)))
|
||||
(mapcar #'mito:execute-sql
|
||||
(list
|
||||
(sxql:delete-from :category
|
||||
(sxql:where (:= :left my-left)))
|
||||
(sxql:update :category
|
||||
(sxql:set= :right (:- :right 1)
|
||||
:left (:- :left 1))
|
||||
(sxql:where (sxql:make-op
|
||||
:raw (format nil "left between ~d and ~d"
|
||||
my-left my-right))))
|
||||
(sxql:update :category
|
||||
(sxql:set= :right (:- :right 2))
|
||||
(sxql:where (:> :right my-right)))
|
||||
(sxql:update :category
|
||||
(sxql:set= :left (:- :left 2))
|
||||
(sxql:where (:> :left my-right)))))))))))
|
||||
|
||||
;;;; #+END_SRC
|
||||
;;;;
|
||||
;;;; In this case we subtract two from all elements to the right of the
|
||||
;;;; node (since without children it would have a width of two), and one
|
||||
;;;; from the nodes that are its children (to close the gap created by the
|
||||
;;;; loss of the parent’s left value). Once again, we can confirm our
|
||||
;;;; elements have been promoted:
|
||||
;;;;
|
||||
;;;; +---------------+
|
||||
;;;; | name |
|
||||
;;;; +---------------+
|
||||
;;;; | ELECTRONICS |
|
||||
;;;; | TELEVISIONS |
|
||||
;;;; | TUBE |
|
||||
;;;; | LCD |
|
||||
;;;; | PLASMA |
|
||||
;;;; | CD PLAYERS |
|
||||
;;;; | 2 WAY RADIOS |
|
||||
;;;; | FRS |
|
||||
;;;; +---------------+
|
||||
;;;;
|
||||
;;;; ** category-delete-and-promote
|
||||
;;;;
|
||||
;;;; Other scenarios when deleting nodes would include promoting one of the
|
||||
;;;; children to the parent position and moving the child nodes under a
|
||||
;;;; sibling of the parent node, but for the sake of space these scenarios
|
||||
;;;; will not be covered in this article.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO SELECT-CATEGORY ?
|
||||
(defgeneric by-category (class maybe-category-id)
|
||||
(:method ((class t) (id category))
|
||||
(select-dao class (sxql:where (:= :category id))))
|
||||
(:method ((class t) (id integer))
|
||||
(select-dao class (sxql:where (:= :category-id id))))
|
||||
(:method ((class t) (id string))
|
||||
(by-category class (parse-integer id))))
|
||||
|
||||
335
src/models/constructed-decks.lisp
Normal file
335
src/models/constructed-decks.lisp
Normal file
@ -0,0 +1,335 @@
|
||||
#|
|
||||
|
||||
src/models/constructed-deck.lisp
|
||||
|
||||
Constructed deck model:
|
||||
|
||||
- CONSTRUCTED-DECK
|
||||
|
||||
A CONSTRUCTED-DECK is based on a YDK-DECK. The YDK-DECK is built on
|
||||
the YDK object, which keeps track of synchronizing the stuff in the
|
||||
Deck Builder App with the database through YDK-SYNC. Since we don't
|
||||
plan on modifying CONSTRUCTED-DECKs, there is nothing analogous to
|
||||
YDK-SYNC for CONSTRUCTED-DECKs. I think that's what I'm implementing
|
||||
right now, the pull logic.
|
||||
|
||||
- CONSTRUCTED-DECK-ITEM
|
||||
|
||||
Analogous to DECK-ITEM. Nothing fancy here. Extra columns: YGO-SET-ITEM, SELL-PRICE.
|
||||
|
||||
- SOLD-DECK
|
||||
|
||||
NODO Supposed to represent decks sold in the same way Deck Templates
|
||||
-> Pulled Decks, Pulled Decks -> Sold Decks.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.constructed-decks)
|
||||
|
||||
(defparameter +default-constructed-deck-sell-price+ "60.00"
|
||||
"Default sell price for constructed decks. We have the price for every card set to 0.50 cents. That works out to $35 for a 70 card deck. This is about twice that.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass constructed-deck ()
|
||||
((;; The name of this CONSTRUCTED-DECK
|
||||
name :accessor deck-name-of
|
||||
:col-type :text
|
||||
:initarg :name)
|
||||
|
||||
(category :accessor deck-category-of :col-type (or category :null))
|
||||
(created-by :accessor deck-created-by :col-type :text :initarg :created-by)
|
||||
|
||||
(;; If the CONSTRUCTED-DECK has a SELL-PRICE, we override the total price of the deck with this price.
|
||||
sell-price :accessor deck-sell-price-of
|
||||
:col-type :integer
|
||||
:initarg :sell-price
|
||||
:initform +default-constructed-deck-sell-price+
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
|
||||
;; The original ID of the deck, probably from YDK-DECK
|
||||
(ydk-deck :accessor ydk-deck-of
|
||||
:col-type ydk-deck
|
||||
:initarg :ydk-deck)
|
||||
(sold :accessor deck-sold
|
||||
:col-type :binary
|
||||
:initarg :deck-sold
|
||||
:initform 0))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A Constructed deck is just a deck that has been \"pulled.\" That is,
|
||||
somebody built a deck template, clicked the \"Pull\" button. From
|
||||
what has been explained to me, we'll only pull decks we have. So
|
||||
we'll only construct decks with cards we know or think we know we have
|
||||
or we plan on getting more of. Then the physical cards will need to
|
||||
be collected and assembled into the deck following the template. This
|
||||
physical, real, action is what is recorded by the \"Pull\" action.
|
||||
|
||||
It's important to note that it is impossible to constrain somebody
|
||||
from pulling arbitrary decks. A physical security device would need to
|
||||
be in place and a framework for authentication with it would be
|
||||
necessary (i.e. it is expected that one will use this tool with
|
||||
intention, respectfully, and will be trained on how to do so).
|
||||
|
||||
Anyway. You don't actually have to physically pull the cards yet. This
|
||||
is just a record, think an earmark on a page, that these cards from
|
||||
this deck template have been pulled. YDK-DECK-PULL-FROM-INVENTORY does
|
||||
all the heavy lifting, and will return a CONSTRUCTED-DECK object if
|
||||
it was successful.
|
||||
|
||||
Then, finally, during the deck construction phase, you will be
|
||||
prompted to select the variant of card, language, condition, etc.
|
||||
|
||||
Once you are happy with your selection the constructed deck will be
|
||||
marked as \"FOR-SALE\"."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass constructed-deck-item ()
|
||||
(;; The original ID of the CONSTRUCTED-DECK-ITEM, from DECK-ITEM
|
||||
;; (passcode :accessor deck-passcode-of :col-type :integer)
|
||||
;; (inventory-item :accessor deck-inventory-item-of :col-type inventory-item)
|
||||
(ygo-card :accessor ygo-card-of
|
||||
:col-type ygo-card
|
||||
:initarg :ygo-card)
|
||||
(deck-id :accessor deck-id-of
|
||||
:col-type :integer)
|
||||
(deck-item :accessor deck-item-of
|
||||
:col-type deck-item
|
||||
:initarg :deck-item)
|
||||
(ygo-set-item :accessor deck-set-item-of
|
||||
:col-type ygo-set-item
|
||||
:initarg :ygo-set-item))
|
||||
;; (variant :accessor deck-item-variant-of
|
||||
;; :col-type variant
|
||||
;; :initarg :variant)
|
||||
;;
|
||||
;; Shouldn't inventory items have Qty and not constructed deck items?
|
||||
;;
|
||||
;; (opt-qty :accessor opt-qty-of
|
||||
;; :col-type :integer
|
||||
;; :initarg :opt-qty
|
||||
;; :initform 0)
|
||||
;; (qty :accessor qty-of
|
||||
;; :col-type :integer
|
||||
;; :initarg :qty
|
||||
;; :initform 0)
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A CONSTRUCTED-DECK-ITEM is pretty much the same as a DECK-ITEM, except it's a \"constructed\" deck.
|
||||
|
||||
Same index idea and everything. The table is indexed into by CONSTRUCTED-DECK-ID.
|
||||
|
||||
We subclass YGO-SETS for all the card metadata."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Analogous to YDK-DECK -- Do we even need this? I just loop over the SET-ITEMS anyway.
|
||||
(defclass constructed-deck-intermediate ()
|
||||
((deck-item :accessor cdi-deck-item
|
||||
:initarg :deck-item)
|
||||
(deck-set :accessor cdi-deck-set
|
||||
:initarg :deck-set)
|
||||
(set-item :accessor cdi-deck-set-item
|
||||
:initarg :set-item)
|
||||
(condition :accessor cdi-deck-condition
|
||||
:initarg :condition)
|
||||
(card :accessor cdi-deck-card
|
||||
:initarg :card)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Just want the decks to be marked as sold. Easy.
|
||||
;;
|
||||
;; (defclass sold-deck (constructed-deck)
|
||||
;; (;; Has the deck been sold?
|
||||
;; (deck-sold :accessor constructed-deck-sold
|
||||
;; :col-type :integer
|
||||
;; :initarg :sold
|
||||
;; :initform 0)
|
||||
;; ;; 60 Doll Hairs
|
||||
;; (sell-price :accessor deck-sell-price-of
|
||||
;; :col-type :integer
|
||||
;; :initarg :sell-price
|
||||
;; :initform +default-constructed-deck-sell-price+
|
||||
;; :deflate #'currency-deflate
|
||||
;; :inflate #'currency-inflate))
|
||||
;; (:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; I think this got superseded by CDI-PULL-FROM-INVENTORY since we
|
||||
;; aren't pulling from YDKs any more but from
|
||||
;; CONSTRUCTED-DECK-INTERMEDIATE.
|
||||
(defmethod ydk-deck-pull-from-inventory ((deck ydk-deck))
|
||||
"Attempt to find inventory stock for every card in this deck, and if we are able to secure it, construct and insert a new PULLED-DECK into the database."
|
||||
(with-connection (db)
|
||||
(let ((;; Get the OLD-DECK-ID
|
||||
old-deck-id (mito:object-id deck))
|
||||
(;; Create a new DECK based on the old DECK
|
||||
new (mito:create-dao 'constructed-deck
|
||||
:name (ydk-name-of deck)
|
||||
:category (ydk-category-of deck)
|
||||
:created-by (ydk-created-by deck)
|
||||
:sell-price +default-constructed-deck-sell-price+
|
||||
:ydk-deck deck)))
|
||||
;; If the new deck was created successfully,
|
||||
(when new
|
||||
(let ((;; Get the NEW-DECK-ID
|
||||
new-deck-id (mito:object-id deck))
|
||||
(;; Get all the items from the old deck
|
||||
deck-items (mito:select-dao 'deck-item
|
||||
(sxql:where (:= :deck-id old-deck-id)))))
|
||||
(with-transaction
|
||||
(dolist (deck-item deck-items new)
|
||||
;; Create a bunch of CONSTRUCTED-DECK-ITEMs for the
|
||||
;; corresponding DECK-ITEMs. from the old DECK.
|
||||
(create-dao 'constructed-deck-item
|
||||
:deck-id new-deck-id
|
||||
:ygo-card-id (deck-passcode-of deck-item)))))))))
|
||||
|
||||
;; (defmethod mark-as-sold ((sold-deck sold-deck))
|
||||
;; "Mark a SOLD-DECK as having been sold."
|
||||
;; (setf (deck-sold sold-deck) 1)
|
||||
;; (update-dao sold-deck))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This expects a list of CONSTRUCTED-DECK-INTERMEDIATE which has no documented format.
|
||||
;;
|
||||
(defun deck-to-pull-set-items-qty-as-alist (cdi-items)
|
||||
"Construct an ALIST of PASSCODE . QTY from DECK listing. We use a list of CONSTRUCTED-DECK-INTERMEDIATE objects."
|
||||
(let ((alist '()))
|
||||
(dolist (row cdi-items alist)
|
||||
(push (cons (cdi-deck-set-item row)
|
||||
(qty-of (cdi-deck-set-item row)))
|
||||
alist))))
|
||||
|
||||
(defun deck-to-pull-desired-qty-as-alist (cdi-items)
|
||||
"Construct an ALIST of PASSCODE . (COUNT PASSCODE) from DECK listing. We use a list of CONSTRUCTED-DECK-INTERMEDIATE objects."
|
||||
(let ((alist '()))
|
||||
(dolist (row cdi-items alist)
|
||||
(if (assoc (cdi-deck-set-item row) alist :test #'mito:object=)
|
||||
(incf (cdr (assoc (cdi-deck-set-item row) alist :test #'mito:object=)))
|
||||
(push (cons (cdi-deck-set-item row) 1) alist)))))
|
||||
|
||||
(defun subtract-desired-from-set-item-qty-as-alist (set-items-qty desired-items-qty)
|
||||
"Perform a DECF on the CDR of the paired elements from (DECK-TO-PULL-SET-ITEMS-QTY-AS-ALIST) using (DECK-TO-PULL-DESIRED-QTY-AS-ALIST) as the source argument."
|
||||
(dolist (pair desired-items-qty set-items-qty)
|
||||
(if (assoc (car pair) set-items-qty :test #'mito:object=)
|
||||
(decf (cdr (assoc (car pair) set-items-qty :test #'mito:object=))
|
||||
(cdr pair))
|
||||
(v:info :construct "Invalid ID pair: ~a" (car pair)))))
|
||||
|
||||
(defun find-any-invalid-qtys (set-items-qty desired-items-qty)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(loop for pair in (subtract-desired-from-set-item-qty-as-alist set-items-qty desired-items-qty)
|
||||
do (when (minusp (cdr pair))
|
||||
(return (ygo-passcode-of (item-of (car pair)))))))))
|
||||
|
||||
(defun valid-pull-p (set-items-qty desired-items-qty)
|
||||
"Loop over the results of SUBTRACT-DESIRED-FROM-SET-ITEM-QTY-AS-ALIST, looking for any less-than-zero values. If any exist, we took too much out of inventory, and the pull is \"invalid,\" we return NIL. Otherwise, the pull will be successful (we have enough inventory), so return T."
|
||||
(not (find-any-invalid-qtys set-items-qty desired-items-qty)))
|
||||
|
||||
;; Actually subtract the amounts from the set item
|
||||
;; make the CONSTRUCTED-DECK with CONSTRUCTED-DECK-ITEM
|
||||
;; Make the view panel
|
||||
|
||||
(defun cdi-pull-from-inventory (cdi-list)
|
||||
"Attempt to find inventory stock for every card in this deck, and if we are able to secure it, construct and insert a new PULLED-DECK into the database."
|
||||
(with-connection (db)
|
||||
(let* ((;; Get the OLD-DECK-ID
|
||||
old-deck-id (deck-id-of (cdi-deck-item (car cdi-list))))
|
||||
(;; Get the OLD DECK
|
||||
old-deck (mito:find-dao 'ydk-deck :id old-deck-id))
|
||||
(;; Create a new DECK based on the old DECK
|
||||
new (mito:create-dao 'constructed-deck
|
||||
:name (ydk-name-of old-deck)
|
||||
:category (ydk-category-of old-deck)
|
||||
:created-by (ydk-created-by old-deck)
|
||||
:sell-price +default-constructed-deck-sell-price+
|
||||
:ydk-deck old-deck)))
|
||||
;; If the new deck was created successfully,
|
||||
(when new
|
||||
;; Get the NEW-DECK-ID
|
||||
(let ((new-deck-id (mito:object-id new)))
|
||||
;; iterate over all the items from the old deck
|
||||
(with-transaction
|
||||
(dolist (row cdi-list new)
|
||||
;; Create a bunch of CONSTRUCTED-DECK-ITEMs for the
|
||||
;; corresponding DECK-ITEMs. from the old DECK.
|
||||
(mito:create-dao 'constructed-deck-item
|
||||
:deck-id new-deck-id
|
||||
:deck-item-id (mito:object-id (cdi-deck-item row))
|
||||
:ygo-set-item-id (mito:object-id (cdi-deck-set-item row))
|
||||
:ygo-card-id (deck-passcode-of (cdi-deck-item row))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun return-to-inventory (cdi-items)
|
||||
"Attempt to find inventory stock for every card in this deck, and increment the count by however many we specify in the CDR."
|
||||
(let ((counts (deck-to-pull-desired-qty-as-alist cdi-items)))
|
||||
(dolist (row counts)
|
||||
(incf (qty-of (car row)) (cdr row))
|
||||
;; Update each one and save - wrapping this in a transaction causes issues with pulling multiple items.
|
||||
(save-dao (car row)))))
|
||||
|
||||
(defun constructed-deck-as-cdi-list (constructed-deck-id)
|
||||
(with-connection (db)
|
||||
(let ((deck
|
||||
(mito:select-dao 'constructed-deck-item
|
||||
(mito:includes 'ygo-card 'deck-item 'ygo-set-item)
|
||||
(sxql:order-by :asc :id)
|
||||
(sxql:where (:= :deck-id constructed-deck-id))))
|
||||
(lst '()))
|
||||
(dolist (row deck (reverse lst))
|
||||
(let ((deck-set-item (deck-set-item-of row)))
|
||||
(push (make-instance 'constructed-deck-intermediate
|
||||
:card (ygo-card-by-passcode (ygo-passcode-of (ygo-card-of row)))
|
||||
:condition (variant-of deck-set-item)
|
||||
:deck-item (deck-item-of row)
|
||||
:deck-set (ygo-set-by-id (mito:object-id (item-of deck-set-item)))
|
||||
:set-item deck-set-item)
|
||||
lst))))))
|
||||
|
||||
;; TODO Use STORE-CONSTRUCTED-DECK-AS-CURRENT to load a
|
||||
;; CONSTRUCTED-DECK out of the database into
|
||||
;; *CURRENT-CONSTRUCTED-DECK* so we can use RETURN-TO-INVENTORY on it.
|
||||
(defun cdi-return-to-inventory (cdi-list)
|
||||
(error "TODO"))
|
||||
|
||||
;; Where did this code from? I feel like it got easily superceded by CALCULATE-OPTIMUM-QTY.
|
||||
;; I think it was used in CARDS-IN-ALL-DECKS?
|
||||
(defun unique-constructed-deck-item-passcodes ()
|
||||
"Select the unique cards in all CONSTRUCTED-DECK-ITEMs"
|
||||
(let ((deck-items
|
||||
(with-connection (db)
|
||||
(mito:select-dao 'constructed-deck-item
|
||||
(sxql:group-by :passcode)
|
||||
(sxql:order-by :passcode :desc))))
|
||||
(ht (make-hash-table)))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (deck-item (reverse deck-items) ht)
|
||||
(pushnew (list :deck-id (deck-id-of deck-item)
|
||||
:constructed-deck (mito:find-dao 'constructed-deck :id (deck-id-of deck-item))
|
||||
:ygo-card (mito:find-dao 'ygo-card :id (deck-passcode-of deck-item)))
|
||||
(gethash (deck-passcode-of deck-item) ht)
|
||||
:key (lambda (plist) (getf plist :deck-id))))))))
|
||||
|
||||
(defun calculate-optimum-qty ()
|
||||
(with-connection (db)
|
||||
(let ((count-data
|
||||
(with-transaction
|
||||
(mito:retrieve-by-sql
|
||||
(sxql:select (:passcode (:as (:count :passcode) :count))
|
||||
(sxql:from :deck_item)
|
||||
(sxql:group-by :passcode)
|
||||
(sxql:order-by (:count :passcode) :asc)))))
|
||||
(lst '()))
|
||||
(with-transaction
|
||||
(mapcar #'mito:execute-sql
|
||||
(dolist (row count-data lst)
|
||||
(let ((passcode (getf row :passcode))
|
||||
(opt-qty (getf row :count)))
|
||||
(push
|
||||
(sxql:update :ygo_set_item
|
||||
(sxql:set= :opt_qty (* 5 opt-qty))
|
||||
(sxql:where (:in :item_id
|
||||
(sxql:select :id
|
||||
(sxql:from :ygo_set)
|
||||
(sxql:where (:= :passcode_id passcode))))))
|
||||
lst))))))))
|
||||
208
src/models/crystal-commerce-csv.lisp
Normal file
208
src/models/crystal-commerce-csv.lisp
Normal file
@ -0,0 +1,208 @@
|
||||
#|
|
||||
|
||||
src/models/crystal-commerce-csv.lisp
|
||||
|
||||
Crystal Commerce Search CSV Export / Import functionality.
|
||||
|
||||
This code is so old. It dates back to May. I mistakenly assumed we
|
||||
would get access to Crystal Commerce or TCGPlayer API data.
|
||||
|
||||
Instead, I based my initial database design off of the CSV export
|
||||
data. The CSV export data does not supply the following necessary
|
||||
fields: Passcode (Card Image), Variants (Condition).
|
||||
|
||||
I learned July 15 that this design was insufficient and set out to
|
||||
replace it with something more robust. Within 2 weeks by the beginning
|
||||
of August I had conceptualized a new design, and by the second week of
|
||||
August, had implemented that design. That is currenly YGOPRODECK-2.
|
||||
|
||||
There is some munging facility in here that I wrote while munging the
|
||||
YGOProDeck API data during the v2 rewrite.
|
||||
|
||||
TODO This needs to be rewritten to match the new YGOProDeck v3
|
||||
API. Currently we scan in the Product Name, it could be split out to
|
||||
match the corresponding db entry.
|
||||
|
||||
TODO Some time in October I became aware we have access to Crystal Commerce API now.
|
||||
|
||||
https://crystal-service.readme.io/docs/get-started-with-the-admin-api
|
||||
https://crystal-service.readme.io/reference/get_api-v1-activity-logs
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.crystal-commerce.csv
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.crystal-commerce)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:grouped)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:export #:*cc-csv-import-fields*
|
||||
#:*cc-csv-header-fields*
|
||||
#:csv-import-cc))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.crystal-commerce.csv)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; CSV Import
|
||||
(defvar *csv* nil
|
||||
"The currently loaded CSV data.")
|
||||
|
||||
(defvar *card-sets* nil
|
||||
"Data loaded from CARD-SET table. We use datafly for this one because
|
||||
mito conses a lot for CLOS. A PLIST is faster.")
|
||||
|
||||
(defvar *cc-csv-import-fields*
|
||||
'("Product Name"
|
||||
"Category"
|
||||
"Total Qty"
|
||||
"Wishlists"
|
||||
"Buy Price"
|
||||
"Sell Price"
|
||||
"URL"
|
||||
"Barcode"
|
||||
"Manufacturer SKU"
|
||||
"Amazon ASIN"
|
||||
"MSRP"
|
||||
"Brand"
|
||||
"Weight"
|
||||
"Description"
|
||||
"Max Qty"
|
||||
"Domestic Only"
|
||||
"Tax Exempt")
|
||||
"Crystal Commerce header fields via CSV import. We transform this into *CC-CSV-HEADER-FIELDS*.
|
||||
|
||||
SEE *CC-CSV-HEADER-FIELDS*.")
|
||||
|
||||
(defvar *cc-csv-header-fields*
|
||||
(mapcar (lambda (s)
|
||||
(alexandria:make-keyword
|
||||
(string-upcase
|
||||
(substitute #\- #\Space s))))
|
||||
*cc-csv-import-fields*)
|
||||
"Transformed list of Keyword-ified header fields. That is, we take *CC-CSV-IMPORT-FIELDS* and transform the strings into keywords:
|
||||
|
||||
\"Product Name\" => :PRODUCT-NAME.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun load-csv (maybe-pathname &optional (force nil))
|
||||
"Cache CSV data from MAYBE-PATHNAME which may be a PATHNAME or a STRING containing CSV data."
|
||||
(if (or force
|
||||
(null *csv*))
|
||||
(progn
|
||||
(v:info :cc-csv "Loading CSV from ~A~%"
|
||||
(typecase maybe-pathname
|
||||
(pathname maybe-pathname)
|
||||
(string 'STRING)))
|
||||
(setf *csv*
|
||||
;; Skip the first header line
|
||||
(rest
|
||||
(cl-csv:read-csv maybe-pathname))))
|
||||
(v:info :cc-csv "Using previously loaded CSV data of length ~d~%" (length *csv*))))
|
||||
|
||||
(defun load-card-sets ()
|
||||
"Cache CARD-SET info to match up from PRODUCT-NAME."
|
||||
(unless *card-sets*
|
||||
(with-datafly-connection (db)
|
||||
(with-datafly-transaction
|
||||
(setf *card-sets*
|
||||
(datafly:retrieve-all
|
||||
(sxql:select (:code :passcode)
|
||||
(sxql:from :ygo_set))))))))
|
||||
|
||||
;; TODO update this code with the new YGOProDeck stuff
|
||||
(defun normalize-product-name (name)
|
||||
"Given a PRODUCT-NAME, apply the extracted data from the string: Name,
|
||||
Set Code, Rarity, and Edition. Return a property list that can be
|
||||
passed to SXQL:SET=."
|
||||
(let ((normalized-name name))
|
||||
;; XXX EW
|
||||
;; Replace things like "Rare-" and "Common-" With "Rare" and "Common"
|
||||
(setf normalized-name (cl-ppcre:regex-replace "(\\w+)- " normalized-name "\\1"))
|
||||
;; A few single cards is borked
|
||||
(setf normalized-name (cl-ppcre:regex-replace "MRD-EN134 - Unlimited" normalized-name "MRD-EN134 - Common - Unlimited"))
|
||||
(setf normalized-name (cl-ppcre:regex-replace "SXG3-ENE05" normalized-name "SGX3-ENE05"))
|
||||
(setf normalized-name (cl-ppcre:regex-replace "wCPP-EN002" normalized-name "WCPP-EN002"))
|
||||
;; This set was borknd
|
||||
;; Maybe not, maybe it just doesn't have a Limited/Unlimited status?
|
||||
;; (setf normalized-name (cl-ppcre:regex-replace "TKN4-([^ ]+) - Super Rare" normalized-name "TKN4-\\1 - Super Rare - Unlimited"))
|
||||
;; Replace things like Rare 1st Edition with Rare - 1st Edition
|
||||
(setf normalized-name (cl-ppcre:regex-replace "(Common|Rare) (1st|Limited|Unlimited)" normalized-name "\\1 - \\2"))
|
||||
(let ((parts (reverse
|
||||
(cl-ppcre:split " \\s?[-–] \\s?" normalized-name))))
|
||||
(case (length parts)
|
||||
(1 `(:name ,(first parts)))
|
||||
(2 `(:name ,(format nil "~{~A~^ - ~}" parts)))
|
||||
(3 `(:name ,(first parts)
|
||||
:code ,(second parts)
|
||||
:rarity ,(third parts)))
|
||||
(4 `(:name ,(first parts)
|
||||
:code ,(second parts)
|
||||
:rarity ,(third parts)
|
||||
:edition ,(fourth parts)))
|
||||
(5 `(:name ,(format nil "~{~A~^ - ~}" (subseq parts 0 2))
|
||||
:code ,(third parts)
|
||||
:rarity ,(fourth parts)
|
||||
:edition ,(fifth parts)))
|
||||
(6 `(:name ,(format nil "~{~A~^ - ~}" (subseq parts 0 3))
|
||||
:code ,(fourth parts)
|
||||
:rarity ,(fifth parts)
|
||||
:edition ,(sixth parts)))
|
||||
(otherwise (format t "Skipping data: ~a~%" name))))))
|
||||
|
||||
;; (defparameter *db-variants*
|
||||
;; (let ((ht (make-hash-table)))
|
||||
;; (loop for variant in (select-dao 'variant) do
|
||||
;; (setf (gethash (variant-name-of variant) ht) variant))
|
||||
;; ht))
|
||||
|
||||
;; TODO clean up the field names to auto generate
|
||||
;;
|
||||
;; TODO I added some additional fields, opt-qty reserved-qty condition language
|
||||
;; I guess we will need one of each in the db...
|
||||
(defun csv-import-cc (csv)
|
||||
"Import the perfect data from Crystal Commerce. Do nothing with it but import it into the table."
|
||||
(load-csv csv)
|
||||
|
||||
(v:info :cc-csv "CSV Loaded")
|
||||
;; (load-card-sets)
|
||||
;; (format t "Card sets loaded from DB~&")
|
||||
|
||||
(let ((csv-items (seed-csv-items)))
|
||||
(pre-seed-db-items csv-items))
|
||||
|
||||
(v:info :cc-csv "done.~&"))
|
||||
|
||||
(defun seed-csv-items ()
|
||||
(let ((csv-items '()))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (row *csv*)
|
||||
(let ((row-plist (mapcan #'list *cc-csv-header-fields* row)))
|
||||
(push (or (mito:find-dao 'cc-item :product-name (getf row-plist :product-name))
|
||||
(apply #'make-instance 'cc-item row-plist))
|
||||
csv-items)))))
|
||||
(v:info :cc-csv "CSV Items: ~d" (length csv-items))
|
||||
|
||||
(unless (mito:dao-synced (car csv-items))
|
||||
(do-grouped-insert csv-items))))
|
||||
|
||||
(defun pre-seed-db-items (cc-items)
|
||||
(let ((db-items '()))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (cc-item cc-items)
|
||||
(dolist (variant (select-dao 'variant))
|
||||
(push (or (mito:find-dao 'ygo-cc-item :item-id (mito:object-id cc-item)
|
||||
:variant-id (mito:object-id variant))
|
||||
(make-instance 'ygo-cc-item
|
||||
:item cc-item
|
||||
:variant variant))
|
||||
db-items)))))
|
||||
(v:info :cc-csv "DB Items: ~d" (length db-items))
|
||||
|
||||
(unless (mito:dao-synced (car db-items))
|
||||
(do-grouped-insert db-items))))
|
||||
235
src/models/crystal-commerce.lisp
Normal file
235
src/models/crystal-commerce.lisp
Normal file
@ -0,0 +1,235 @@
|
||||
#|
|
||||
|
||||
src/models/crystal-commerce.lisp
|
||||
|
||||
Crystal Commerce-style Inventory Management Backend
|
||||
|
||||
TODO All of the old style database accessores (*-BY-ID, etc) need to go.
|
||||
|
||||
DONE It looks like the CSV listing is totally outdated after all:
|
||||
|
||||
CL-DECK-BUILDER2> (count-dao 'cc-item)
|
||||
48883 (16 bits, #xBEF3)
|
||||
CL-DECK-BUILDER2> (count-dao 'cl-deck-builder2.models.ygoprodeck.classes::ygo-set)
|
||||
49240 (16 bits, #xC058)
|
||||
|
||||
That's awfully close enough for me, taking into account the art cards,
|
||||
the duelist name tag, and prize cards! I wonder if there'd be a way to
|
||||
see the diff. Some cards are name "Dark Magician A" which is
|
||||
unfortunate!
|
||||
|
||||
TODO Because of the previous item being DONE, this code is now
|
||||
outdated and stale, and probably safe to delete, unless we intend on
|
||||
doing more with Crystal Commerce in the future.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.crystal-commerce
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.toolkit.money
|
||||
#:cl-deck-builder2.models.registered-table
|
||||
#:cl-deck-builder2.models.ygoprodeck)
|
||||
(:import-from #:cl-deck-builder2.models.ygoprodeck.fields
|
||||
#:variant-condition)
|
||||
(:export
|
||||
:cc-item
|
||||
:ygo-cc-item
|
||||
|
||||
:name-of
|
||||
:cc-category-of
|
||||
:cc-wishlists-of
|
||||
:cc-buy-price-of
|
||||
:cc-sell-price-of
|
||||
:cc-url-of
|
||||
:cc-barcode-of
|
||||
:cc-manufacturer-sku-of
|
||||
:cc-asin-of
|
||||
:cc-msrp-of
|
||||
:cc-brand-of
|
||||
:cc-weight-of
|
||||
:cc-description-of
|
||||
:cc-qty-of
|
||||
:cc-max-qty-of
|
||||
:cc-total-qty-of
|
||||
:cc-domestic-only-of
|
||||
:cc-tax-exempt-of
|
||||
:cc-name-of
|
||||
:cc-code-of
|
||||
:cc-rarity-of
|
||||
:cc-edition-of
|
||||
:cc-passcode-of
|
||||
|
||||
:cc-table-ensure-exists
|
||||
:cc-table-drop
|
||||
:cc-table-delete
|
||||
:cc-table-select
|
||||
:cc-table-select-count
|
||||
:cc-table-zero
|
||||
|
||||
:cc-select-by-id
|
||||
:cc-select-by-passcode
|
||||
|
||||
:cc-delete-by-id
|
||||
|
||||
:cc-create
|
||||
|
||||
:cc-variant-of))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.crystal-commerce)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Cards v2
|
||||
;;
|
||||
(defclass cc-item ()
|
||||
((name :accessor name-of
|
||||
:col-type :text)
|
||||
(category :accessor cc-category-of
|
||||
:col-type :text)
|
||||
(total-qty :accessor cc-total-qty-of
|
||||
:col-type :integer
|
||||
:initform 0)
|
||||
(wishlists :accessor cc-wishlists-of
|
||||
:col-type :integer
|
||||
:initform 0)
|
||||
(;; 10 cent buy price
|
||||
buy-price :accessor cc-buy-price-of
|
||||
:col-type :integer
|
||||
:initform 0.10
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate)
|
||||
(;; 50 cent sell price
|
||||
sell-price :accessor cc-sell-price-of
|
||||
:col-type :integer
|
||||
:initform 0.50
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate)
|
||||
(url :accessor cc-url-of
|
||||
:col-type (or :text :null))
|
||||
(barcode :accessor cc-barcode-of
|
||||
:col-type (or :text :null))
|
||||
(manufacturer-sku :accessor cc-manufacturer-sku-of
|
||||
:col-type (or :text :null))
|
||||
;; Some cards don't have an ASIN: Prize Cards, for example.
|
||||
;;
|
||||
;; ASIN is a built in LISP function so this seems to be causing
|
||||
;; issues with Djula. I renamed it to AMAZON-ASIN.
|
||||
(amazon-asin :accessor cc-asin-of
|
||||
:col-type (or :text :null))
|
||||
(msrp :accessor cc-msrp-of
|
||||
:col-type (or :integer :null)
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate)
|
||||
(brand :accessor cc-brand-of
|
||||
:col-type (or :text :null))
|
||||
;; Weight in pounds, lb, lbs.. silly
|
||||
(weight :accessor cc-weight-of
|
||||
:col-type :text
|
||||
:initform "0.0625")
|
||||
(description :accessor cc-description-of
|
||||
:col-type (or :text :null))
|
||||
(max-qty :accessor cc-max-qty-of
|
||||
:col-type (or :integer :null))
|
||||
(domestic-only :accessor cc-domestic-only-of
|
||||
:col-type :integer
|
||||
:initform 0)
|
||||
(tax-exempt :accessor cc-tax-exempt-of
|
||||
:col-type :integer
|
||||
:initform 0))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "The base data from CrystalCommerce. This is what's available in a CSV export.
|
||||
|
||||
These fields can be updated from CC CSV Export Search feature.
|
||||
|
||||
The product descriptors. Contains information about the actual content
|
||||
of the card. None of this is available via CC CSV Export Feature. This
|
||||
information has to be updated aftewards. The Mass Updater may have
|
||||
some hints as to how this works.
|
||||
|
||||
Other stuff that doesn't appear in any export or search feature, but on YGOProDeck, which we will probably take info from."))
|
||||
|
||||
;; Allow bogus keys so we can just apply #'make-instance 'cc-item _parsed in web view
|
||||
; (defmethod initialize-instance :after ((cc-item cc-item) &key &allow-other-keys))
|
||||
|
||||
(defclass ygo-cc-item ()
|
||||
((item :accessor cc-item-of
|
||||
:col-type cc-item)
|
||||
(variant :accessor cc-variant-of
|
||||
:col-type variant-condition)
|
||||
(qty :accessor cc-qty-of
|
||||
:col-type :integer
|
||||
:initform 0)
|
||||
(opt-qty :accessor cc-opt-qty-of
|
||||
:col-type :integer
|
||||
:initform 0)
|
||||
(;; 10 cent buy price
|
||||
buy-price :accessor cc-buy-price-of
|
||||
:col-type :integer
|
||||
:initform 0.10
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate)
|
||||
(;; 50 cent sell price
|
||||
sell-price :accessor cc-sell-price-of
|
||||
:col-type :integer
|
||||
:initform 0.50
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "CC-ITEM + VARIANT relationship table."))
|
||||
|
||||
|
||||
(defmacro cc-table-delete (&body clauses)
|
||||
`(delete-from 'cc-item ,@clauses))
|
||||
|
||||
(defmacro cc-table-select (&body body)
|
||||
`(select-dao 'cc-item ,@body))
|
||||
|
||||
(defun cc-table-select-count (&optional fields-and-values)
|
||||
(count-dao 'cc-item fields-and-values))
|
||||
|
||||
|
||||
;; TODO toolkit/db.lisp maybe?
|
||||
(defun zero-field (class field &optional clauses)
|
||||
"Set the specified FIELD of CLASS zero. You may additionally specify CLAUSES."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:execute-sql
|
||||
(sxql:update (sxql:make-sql-symbol
|
||||
(mito.dao::table-name (find-class class)))
|
||||
(sxql:set= (sxql:make-sql-symbol field) 0)
|
||||
clauses)))))
|
||||
|
||||
(defun set-buy-sell-price (&optional (buy-price 10) (sell-price 50))
|
||||
"This bypasses MITO:DEFLATE (the argument is in CENTS)."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:execute-sql
|
||||
(sxql:update :cc_item
|
||||
(sxql:set= (sxql:make-sql-symbol "buy_price") buy-price
|
||||
(sxql:make-sql-symbol "sell_price") sell-price))
|
||||
(sxql:update :ygo_cc_item
|
||||
(sxql:set= (sxql:make-sql-symbol "buy_price") buy-price
|
||||
(sxql:make-sql-symbol "sell_price") sell-price))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun cc-select-by-id (id &rest args)
|
||||
(apply #'find-dao 'cc-item :id id args))
|
||||
|
||||
(defun cc-select-by-passcode (passcode &rest args)
|
||||
(apply #'find-dao 'cc-item :passcode passcode args))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; INSERT
|
||||
|
||||
(defun cc-create (&rest args)
|
||||
(apply #'create-dao 'cc-item args))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; DELETE
|
||||
(defun cc-delete-by-id (id &rest args)
|
||||
(apply #'delete-by-values 'cc-item :id id args))
|
||||
27
src/models/feedback.lisp
Normal file
27
src/models/feedback.lisp
Normal file
@ -0,0 +1,27 @@
|
||||
#|
|
||||
|
||||
User Feedback Module
|
||||
|
||||
TODO User Messaging Module
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.feedback)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass feedback ()
|
||||
((user :accessor feedback-user-of
|
||||
:col-type user
|
||||
:initarg :user)
|
||||
(body :accessor feedback-body-of
|
||||
:col-type :text
|
||||
:initarg :body))
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defgeneric create-feedback (user body)
|
||||
(:documentation "Use CREATE-DAO to construct a new FEEDBACK instance. Return the instance, if successful, NIL otherwise.")
|
||||
(:method ((user user) (body string))
|
||||
(create-dao 'feedback
|
||||
:user user
|
||||
:body body)))
|
||||
40
src/models/generics.lisp
Normal file
40
src/models/generics.lisp
Normal file
@ -0,0 +1,40 @@
|
||||
#|
|
||||
|
||||
When I started this file I was going to generalize EVERY method then I
|
||||
realized that's too time consuming. So I am going to generalize
|
||||
methods as they conflict. Hybrid Power!
|
||||
|
||||
There were some issues with merging symbols, I was using
|
||||
:SHADOWING-IMPORT-FROM which is probably not correct. So instead, what
|
||||
we do, is, every package that gets :USE-REEXPORTed, we :USE
|
||||
#:CL-DECK-BUILDER2.MODELS.GENERICS.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.generics)
|
||||
|
||||
;; Get the NAME slot of an object
|
||||
(defgeneric name-of (obj))
|
||||
|
||||
;; Get the PASSCODE slot of an object
|
||||
(defgeneric ygo-passcode-of (obj))
|
||||
|
||||
;; Get the Containing Deck ID of the DECK-ITEM, CONSTRUCTED-DECK-ITEM
|
||||
(defgeneric deck-id-of (obj))
|
||||
|
||||
;; Get the PRICE slot of an object
|
||||
(defgeneric ygo-price-of (obj))
|
||||
|
||||
(defgeneric ygo-archetype-of (obj))
|
||||
(defgeneric ygo-atk-of (obj))
|
||||
(defgeneric ygo-attribute-of (obj))
|
||||
(defgeneric ygo-def-of (obj))
|
||||
(defgeneric ygo-description-of (obj))
|
||||
(defgeneric ygo-frame-type-of (obj))
|
||||
(defgeneric ygo-level-of (obj))
|
||||
(defgeneric ygo-linkmarkers-of (obj))
|
||||
(defgeneric ygo-linkval-of (obj))
|
||||
(defgeneric ygo-passcode-of (obj))
|
||||
(defgeneric ygo-race-of (obj))
|
||||
(defgeneric ygo-scale-of (obj))
|
||||
(defgeneric ygo-type-of (obj))
|
||||
136
src/models/label-maker.lisp
Normal file
136
src/models/label-maker.lisp
Normal file
@ -0,0 +1,136 @@
|
||||
#|
|
||||
|
||||
Conceptually, The Label Maker is very similar to the DRAW component of The Deck Builder.
|
||||
|
||||
We currently support Avery 5160 and ULINE S-20246 labels.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This package doesn't touch the DB ... yet
|
||||
(defpackage #:cl-deck-builder2.models.label-maker
|
||||
(:use :cl)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:latex-escape)
|
||||
(:export #:latex-label
|
||||
#:latex-label-page
|
||||
#:latex-label-uline-s-20247
|
||||
#:latex-label-avery-5160
|
||||
#:render-page))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.label-maker)
|
||||
|
||||
(defclass latex-label ()
|
||||
((barcode :accessor latex-label-barcode
|
||||
:initform nil
|
||||
:initarg :barcode)
|
||||
(description :accessor latex-label-description
|
||||
:initform nil
|
||||
:initarg :description)
|
||||
(price :accessor latex-label-price
|
||||
:initform nil
|
||||
:initarg :price))
|
||||
(:documentation "An individual LaTeX label. Encapsulate metadata for a particular label."))
|
||||
|
||||
(defclass latex-label-page ()
|
||||
((;; List of LATEX-LABEL content
|
||||
labels :accessor latex-label-page-labels
|
||||
:initarg :page-labels
|
||||
:initform '())
|
||||
(;; Number of Labels this page thinks it has
|
||||
labels-length :accessor latex-label-page-labels-length
|
||||
:initarg :labels-length
|
||||
:initform 0)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Templates
|
||||
(;; Template for this page
|
||||
label-template :accessor latex-label-label-template
|
||||
:initform nil
|
||||
:initarg :label-template)
|
||||
(;; Header template for this page
|
||||
header-template :accessor latex-label-header-template
|
||||
:initform #P"latex/header.tex"
|
||||
:initarg :header-template))
|
||||
(:documentation "Class for a LaTeX Label Page, which encapsulates label information and additional output templating information."))
|
||||
|
||||
(defclass latex-label-uline-s-20247 (latex-label-page)
|
||||
((labels-length :initform 32)
|
||||
(label-template :initform #P"latex/ULINE-S-20247.tpl.tex")))
|
||||
|
||||
(defclass latex-label-avery-5160 (latex-label-page)
|
||||
((labels-length :initform 30)
|
||||
(label-template :initform #P"latex/Avery-5160.tpl.tex")))
|
||||
|
||||
(defmethod initialize-instance :after ((page latex-label-page) &rest initargs &key csv &allow-other-keys)
|
||||
(declare (ignore initargs))
|
||||
(when csv
|
||||
(initialize-with-csv page csv)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod add-label ((page latex-label-page) (label latex-label))
|
||||
"Add a LABEL to PAGE."
|
||||
(push label (latex-label-page-labels page)))
|
||||
|
||||
(defmethod initialize-with-csv ((page latex-label-page) pathspec)
|
||||
"Create LATEX-LABEL information for this LATEX-LABEL-PAGE by reading CSV information from PATHSPEC."
|
||||
(let ((csv (cl-csv:read-csv pathspec)))
|
||||
(loop for i from 1 upto (latex-label-page-labels-length page) do
|
||||
(destructuring-bind (label-no description price barcode)
|
||||
(elt csv i)
|
||||
(declare (ignore label-no))
|
||||
(when (> (length description) 0)
|
||||
(barcode-png barcode)
|
||||
(let ((label (ignore-errors
|
||||
(make-instance 'latex-label
|
||||
:barcode barcode
|
||||
:description (latex-escape description)
|
||||
:price (cl-ppcre:regex-replace "\\$" price "\\\\$")))))
|
||||
(add-label page label)))))))
|
||||
|
||||
(defmethod render-page ((page latex-label-page))
|
||||
"Use Djula to render the LATEX-LABEL-LABEL-TEMPLATE."
|
||||
(cl-deck-builder2.view:render (latex-label-label-template page)
|
||||
(list :labels (latex-label-page-labels page))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun label-info (&optional t-or-nil)
|
||||
(let ((arg (if t-or-nil "true" "false")))
|
||||
(format nil "\LabelGrid~a\LabelInfo~a%%~%" arg arg)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO (defclass barcode () ())
|
||||
(defun barcode-png (barcode &optional (directory #P"/tmp/labels/") (size "1x30"))
|
||||
(ensure-directories-exist directory)
|
||||
(let* ((barcode (etypecase barcode
|
||||
(string barcode)
|
||||
(integer (princ-to-string barcode))))
|
||||
(output (merge-pathnames
|
||||
(make-pathname :name barcode :type "png")
|
||||
(probe-file directory))))
|
||||
(unless (probe-file output)
|
||||
(and
|
||||
(> (length barcode) 0)
|
||||
(multiple-value-bind (stdout stderr rc)
|
||||
(inferior-shell:run
|
||||
`("ZXingWriter" -size ,size
|
||||
,(case (length barcode)
|
||||
;; 12 and 11 digit barcodes for products in store on the shelves usually - UPC-A
|
||||
((12 11) 'UPC-A)
|
||||
;; 10 digit barcodes for "fake" Amazon ASIN "X0037THWV7"
|
||||
(10 'Code128)
|
||||
;; Not sure why we have UPC-E in here
|
||||
;; but presumbly we have encountered
|
||||
;; products with a 6 digit barcode...
|
||||
(6 'UPC-E)
|
||||
;; Treat everything else as 13 digit
|
||||
;; international EAN-13 barcodes like
|
||||
;; stuff from Pokemon Stores:
|
||||
;; 8206508090648
|
||||
(t 'EAN-13))
|
||||
,barcode
|
||||
,output))
|
||||
(declare (ignore stdout stderr))
|
||||
(eq rc 0))
|
||||
(probe-file output)))))
|
||||
65
src/models/mtg.lisp
Normal file
65
src/models/mtg.lisp
Normal file
@ -0,0 +1,65 @@
|
||||
#|
|
||||
|
||||
scryfall API parser
|
||||
|
||||
WIP
|
||||
|
||||
This downloads the API data. We haven't even parsed that data
|
||||
yet. It's hundreds of GB.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.mtg
|
||||
(:use :cl))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.mtg)
|
||||
|
||||
(defparameter *base-scryfall-api-uri* "https://api.scryfall.com/")
|
||||
|
||||
(defun scryfall-api-uri (path)
|
||||
(format nil "~a~a" *base-scryfall-api-uri* path))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar *scryfall-api-data* nil
|
||||
"A list of SCRYFALL-API-DATA objects.")
|
||||
|
||||
(defclass scryfall-api-data ()
|
||||
((|content_encoding| :accessor scryfall-content-encoding :initarg :|content_encoding|)
|
||||
(|content_type| :accessor scryfall-content-type :initarg :|content_type|)
|
||||
(|description| :accessor scryfall-description :initarg :|description|)
|
||||
(|download_uri| :accessor scryfall-download-uri :initarg :|download_uri|)
|
||||
(|id| :accessor scryfall-id :initarg :|id|)
|
||||
(|name| :accessor scryfall-name :initarg :|name|)
|
||||
(|object| :accessor scryfall-object :initarg :|object|)
|
||||
(|size| :accessor scryfall-size :initarg :|size|)
|
||||
(|type| :accessor scryfall-type :initarg :|type|)
|
||||
(|updated_at| :accessor scryfall-updated-at :initarg :|updated_at|)
|
||||
(|uri| :accessor scryfall-uri :initarg :|uri|)))
|
||||
|
||||
(defun get-scryfall-data ()
|
||||
(let ((json (getf
|
||||
(jonathan:parse
|
||||
(flex:octets-to-string
|
||||
(drakma:http-request (scryfall-api-uri "bulk-data"))))
|
||||
:|data|)))
|
||||
(mapcar (lambda (row)
|
||||
(apply #'make-instance 'scryfall-api-data row))
|
||||
json)))
|
||||
|
||||
(defun load-scryfall-data ()
|
||||
(setf *scryfall-api-data*
|
||||
(get-scryfall-data)))
|
||||
|
||||
(defun size-in-gb (size)
|
||||
(float (/ size (* 1024 1024 1024))))
|
||||
|
||||
(defun get-bulk-data-uris (path)
|
||||
(with-open-file (out path
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format out "~{~A~%~}"
|
||||
(mapcar #'scryfall-download-uri *scryfall-api-data*))))
|
||||
502
src/models/packages.lisp
Normal file
502
src/models/packages.lisp
Normal file
@ -0,0 +1,502 @@
|
||||
#|
|
||||
|
||||
src/models/packages.lisp
|
||||
|
||||
Models Main Package List
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.generics
|
||||
(:use #:cl)
|
||||
(:export #:deck-id-of
|
||||
#:name-of
|
||||
#:ygo-archetype-of
|
||||
#:ygo-atk-of
|
||||
#:ygo-attribute-of
|
||||
#:ygo-def-of
|
||||
#:ygo-description-of
|
||||
#:ygo-frame-type-of
|
||||
#:ygo-level-of
|
||||
#:ygo-linkmarkers-of
|
||||
#:ygo-linkval-of
|
||||
#:ygo-passcode-of
|
||||
#:ygo-price-of
|
||||
#:ygo-race-of
|
||||
#:ygo-scale-of
|
||||
#:ygo-type-of))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.registered-table
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:relative-pathname)
|
||||
(:export #:registry
|
||||
#:registered-classes
|
||||
#:registered-table-class
|
||||
#:ensure-tables-exist
|
||||
#:migration-expressions
|
||||
#:migrate-table
|
||||
#:export-registered-classes
|
||||
#:export-registered-classe-to-file))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.attachment
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.models.generics)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:import-from #:cl-deck-builder2.db
|
||||
#:create-dao)
|
||||
(:export #:attachment
|
||||
#:create-attachment
|
||||
#:attachment-valid-p))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.category
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.models.generics)
|
||||
(:import-from #:cl-deck-builder2.db
|
||||
#:create-dao
|
||||
#:select-dao)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:export #:category
|
||||
#:category-name-of
|
||||
#:category-left-of
|
||||
#:category-right-of
|
||||
|
||||
#:category-rename
|
||||
|
||||
#:category-insert-right-of
|
||||
#:category-insert-new-child
|
||||
#:category-insert-fake-data
|
||||
#:category-full-tree
|
||||
#:category-leaf-nodes
|
||||
#:category-full-tree-format
|
||||
#:category-delete-tree
|
||||
#:category-delete-and-reparent
|
||||
#:category-tree-depth
|
||||
#:category-node-depth
|
||||
#:category-subtree-depth
|
||||
#:category-subtree-max-depth
|
||||
|
||||
#:by-category))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.fields
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:export #:variant
|
||||
#:name-of
|
||||
#:define-variant-list
|
||||
#:variant-condition
|
||||
#:variant-language
|
||||
#:ygo-banlist-name
|
||||
#:ygo-format-name
|
||||
#:ygo-linkmarker-name
|
||||
#:ygo-set-rarity-code))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.registered-table)
|
||||
(:export :ygo-info
|
||||
#:ygo-description-of
|
||||
#:ygo-frame-type-of
|
||||
#:ygo-type-of
|
||||
#:ygo-passcode-of
|
||||
#:name-of
|
||||
#:ygo-race-of
|
||||
#:ygo-archetype-of
|
||||
#:ygo-attribute-of
|
||||
#:ygo-linkmarkers-of
|
||||
#:ygo-atk-of
|
||||
#:ygo-def-of
|
||||
#:ygo-level-of
|
||||
#:ygo-linkval-of
|
||||
#:ygo-scale-of))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.classes
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.ygoprodeck.fields)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:import-from #:cl-deck-builder2.models.ygoprodeck.fields
|
||||
#:variant-condition
|
||||
#:ygo-banlist-name
|
||||
#:ygo-format-name
|
||||
#:ygo-linkmarker-name
|
||||
#:ygo-set-rarity-code)
|
||||
(:import-from :cl-deck-builder2.toolkit
|
||||
:currency-deflate
|
||||
:currency-inflate)
|
||||
(:export #:ygo-card-name
|
||||
#:ygo-card-type
|
||||
#:ygo-card-frame-type
|
||||
#:ygo-card-race
|
||||
#:ygo-card-archetype
|
||||
#:ygo-card-attribute
|
||||
#:ygo-card
|
||||
#:ygo-card-misc-info
|
||||
#:ygo-set-name
|
||||
#:ygo-set-code
|
||||
#:ygo-set-rarity-code
|
||||
#:ygo-set-rarity
|
||||
#:ygo-set-edition
|
||||
#:ygo-set
|
||||
#:ygo-set-item
|
||||
#:ygo-linkmarker
|
||||
#:ygo-format
|
||||
;; #:ygo-banlist-name
|
||||
;; #:ygo-format-name
|
||||
;; #:ygo-linkmarker-name
|
||||
#:ygo-banlist
|
||||
#:ygo-alternative-artwork
|
||||
#:ygo-price
|
||||
|
||||
;; Accessor Methods
|
||||
#:ygo-alternate-id-of
|
||||
#:ygo-archetype-of
|
||||
#:ygo-atk-of
|
||||
#:ygo-attribute-of
|
||||
#:ygo-ban-goat
|
||||
#:ygo-ban-ocg
|
||||
#:ygo-ban-tcg
|
||||
#:ygo-beta-id-of
|
||||
#:ygo-beta-name-of
|
||||
#:ygo-card-type-of
|
||||
#:ygo-code-of
|
||||
#:ygo-common-charity-format
|
||||
#:ygo-def-of
|
||||
#:ygo-desc-of
|
||||
#:ygo-downvotes-of
|
||||
#:ygo-duel-links-format
|
||||
#:ygo-edison-format
|
||||
#:ygo-edition-of
|
||||
#:ygo-frame-type-of
|
||||
#:ygo-goat-format
|
||||
#:ygo-has-effect
|
||||
#:ygo-is-staple
|
||||
#:ygo-konami-id-of
|
||||
#:ygo-level-of
|
||||
#:ygo-linkmarker-bottom
|
||||
#:ygo-linkmarker-bottom-left
|
||||
#:ygo-linkmarker-bottom-right
|
||||
#:ygo-linkmarker-left
|
||||
#:ygo-linkmarker-right
|
||||
#:ygo-linkmarker-top
|
||||
#:ygo-linkmarker-top-left
|
||||
#:ygo-linkmarker-top-right
|
||||
#:ygo-name-of
|
||||
#:ygo-ocg-date-of
|
||||
#:ygo-ocg-format
|
||||
#:ygo-ocg-goat-format
|
||||
#:ygo-passcode-of
|
||||
#:ygo-question-atk
|
||||
#:ygo-question-def
|
||||
#:ygo-race-of
|
||||
#:ygo-rarity-of
|
||||
#:ygo-scale-of
|
||||
#:ygo-set-code-of
|
||||
#:ygo-set-rarity-code-of
|
||||
#:ygo-speed-duel-format
|
||||
#:ygo-tcg-date-of
|
||||
#:ygo-tcg-format
|
||||
#:ygo-treated-as
|
||||
#:ygo-upvotes-of
|
||||
#:ygo-url-of
|
||||
#:ygo-views-of
|
||||
#:ygo-viewsweek-of
|
||||
#:ygo-amazon-price-of
|
||||
#:ygo-cardmarket-price-of
|
||||
#:ygo-coolstuffinc-price-of
|
||||
#:ygo-ebay-price-of
|
||||
#:ygo-tcgplayer-price-of
|
||||
#:ygo-price-of
|
||||
|
||||
#:qty-of
|
||||
#:item-of
|
||||
#:variant-of
|
||||
#:sell-price-of
|
||||
#:opt-qty-of
|
||||
#:buy-price-of)
|
||||
(:documentation "New YGOProDeck database schema - classes."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.methods
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.ygoprodeck.classes
|
||||
#:cl-deck-builder2.models.ygoprodeck.fields)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-classes
|
||||
#:registry)
|
||||
(:export #:print-object
|
||||
#:split-code
|
||||
#:ygo-card
|
||||
#:ygo-card-by-name
|
||||
#:ygo-card-by-passcode
|
||||
#:ygo-card-names-by-deck-id
|
||||
#:ygo-card-names-from-list
|
||||
#:ygo-card-sets
|
||||
#:ygo-set
|
||||
#:ygo-set-by-id
|
||||
#:ygo-set-by-code
|
||||
#:ygo-set-by-name
|
||||
#:ygo-set-by-passcode
|
||||
#:ygo-select-set-item)
|
||||
(:documentation "New YGOProDeck database schema - methods."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.cardinfo
|
||||
(:use #:cl)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:export #:cardinfo
|
||||
#:cardinfo-input
|
||||
#:cardinfo-output
|
||||
#:cardinfo-input-exists-p
|
||||
#:cardinfo-output-exists-p
|
||||
#:cardinfo-json
|
||||
#:cardinfo-list
|
||||
#:cardinfo-download
|
||||
#:cardinfo-cleanup
|
||||
#:cardinfo-convert
|
||||
#:cardinfo-update-and-cleanup))
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.ygoprodeck.json
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.toolkit
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.ygoprodeck.fields
|
||||
#:cl-deck-builder2.models.ygoprodeck.cardinfo
|
||||
#:cl-deck-builder2.models.ygoprodeck.classes)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:export #:cardinfo-import))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.user
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.db)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:import-from :mito-auth
|
||||
:has-secure-password)
|
||||
(:export #:user
|
||||
#:name-of
|
||||
#:user-email-of
|
||||
#:user-roles-of
|
||||
|
||||
#:role
|
||||
|
||||
#:user-role
|
||||
#:user-role-user
|
||||
#:user-role-role
|
||||
|
||||
#:user-admin-p
|
||||
#:user-verified-p
|
||||
|
||||
#:create-user
|
||||
#:find-user
|
||||
#:create-role
|
||||
#:add-role))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.feedback
|
||||
(:use #:cl)
|
||||
(:import-from #:cl-deck-builder2.db
|
||||
#:create-dao)
|
||||
(:import-from #:cl-deck-builder2.models.registered-table
|
||||
#:registered-table-class)
|
||||
(:import-from #:cl-deck-builder2.models.user
|
||||
#:user)
|
||||
(:export #:feedback
|
||||
#:feedback-body-of
|
||||
#:feedback-user-of
|
||||
#:create-feedback))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This package doesn't touch the DB ... yet
|
||||
(defpackage #:cl-deck-builder2.models.qr-code
|
||||
(:use :cl
|
||||
:cl-deck-builder2.db)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:import-from :cl-deck-builder2.toolkit
|
||||
:query-param)
|
||||
(:export :qr-settings
|
||||
:qr-string
|
||||
:qr-min-version
|
||||
:qr-ec-level
|
||||
:qr-encoding-mode
|
||||
:qr-mask-number
|
||||
:qr-to-plist
|
||||
:qr-generate))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.ydk
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.registered-table
|
||||
#:cl-deck-builder2.toolkit)
|
||||
(:import-from #:cl-deck-builder2.models.category
|
||||
#:category)
|
||||
(:import-from #:cl-deck-builder2.models.ygoprodeck
|
||||
#:ygo-info)
|
||||
(:export #:ydk
|
||||
#:deck-item
|
||||
#:ydk-deck
|
||||
|
||||
#:deck-id-of
|
||||
#:deck-kind-of
|
||||
#:deck-passcode-of
|
||||
#:ydk-created-by
|
||||
#:ydk-name-of
|
||||
#:ydk-id-of
|
||||
#:ydk-deck-delete-from
|
||||
#:ydk-deck-item-delete-from
|
||||
#:ydk-deck-delete-by-id
|
||||
#:ydk-deck-delete-by-name
|
||||
#:ydk-deck-by-id
|
||||
#:ydk-deck-by-name
|
||||
#:ydk-deck-info-by-id
|
||||
#:ydk-rename-deck
|
||||
#:ydk-add
|
||||
#:ydk-clear
|
||||
#:ydk-sync
|
||||
|
||||
#:ydk-main-deck-of
|
||||
#:ydk-extra-deck-of
|
||||
#:ydk-side-deck-of
|
||||
#:ydk-category-of
|
||||
|
||||
#:ydk-all
|
||||
#:ydk-concatenate
|
||||
#:ydk-unique
|
||||
#:ydk-query
|
||||
#:ydk-sorted
|
||||
|
||||
#:ydk-delete
|
||||
#:ydk-delete-index
|
||||
|
||||
#:ydk-table-ensure-exists
|
||||
#:ydk-table-drop
|
||||
#:ydk-table-delete
|
||||
#:ydk-table-select
|
||||
#:ydk-table-select-count
|
||||
|
||||
#:ydk-to-kde)
|
||||
(:documentation "This model is just a thin wrapper around YDK format.
|
||||
|
||||
The YDK Format is like this:
|
||||
|
||||
created by...
|
||||
#main
|
||||
<a series of passcodes>
|
||||
#extra
|
||||
<a series of passcodes>
|
||||
!side
|
||||
<a series of passcodes>
|
||||
|
||||
TODO CL-YDK + YDK-STORAGE-MIXIN?"))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Psuedo class for working with the SQLite database.
|
||||
;; This will probably go away once we switch over to MariaDB.
|
||||
(defpackage #:cl-deck-builder2.models.sqlite-schema
|
||||
(:use :cl
|
||||
:cl-deck-builder2.db)
|
||||
(:export #:sqlite-schema
|
||||
#:kind-of
|
||||
#:sql-of
|
||||
#:rootpage-of
|
||||
#:table-names))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.models.constructed-decks
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.toolkit
|
||||
#:cl-deck-builder2.models.generics
|
||||
#:cl-deck-builder2.models.registered-table
|
||||
#:cl-deck-builder2.models.ygoprodeck.classes
|
||||
#:cl-deck-builder2.models.ygoprodeck.methods)
|
||||
(:import-from #:cl-deck-builder2.models.category
|
||||
#:category)
|
||||
(:import-from #:cl-deck-builder2.models.ydk
|
||||
#:deck-item
|
||||
#:deck-id-of
|
||||
#:deck-passcode-of
|
||||
#:ydk-category-of
|
||||
#:ydk-created-by
|
||||
#:ydk-name-of
|
||||
#:ydk-deck)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:export #:constructed-deck
|
||||
#:constructed-deck-item
|
||||
#:constructed-deck-intermediate
|
||||
|
||||
#:cdi-deck-item
|
||||
#:cdi-deck-set
|
||||
#:cdi-deck-set-item
|
||||
#:cdi-deck-condition
|
||||
#:cdi-deck-card
|
||||
|
||||
#:constructed-deck-as-cdi-list
|
||||
|
||||
;; :deck-category-of
|
||||
;; :deck-created-by
|
||||
;; :deck-id-of
|
||||
:deck-name-of
|
||||
;; :deck-sell-price
|
||||
:deck-sell-price-of
|
||||
:deck-sold
|
||||
;; :ydk-deck-of
|
||||
;; :ygo-card-of
|
||||
|
||||
;; #:sold-deck
|
||||
|
||||
#:ydk-deck-pull-from-inventory
|
||||
#:find-any-invalid-qtys
|
||||
#:deck-to-pull-set-items-qty-as-alist
|
||||
#:deck-to-pull-desired-qty-as-alist
|
||||
#:subtract-desired-from-set-item-qty-as-alist
|
||||
#:valid-pull-p
|
||||
|
||||
#:cdi-pull-from-inventory))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(uiop:define-package #:cl-deck-builder2.models
|
||||
(:use #:cl)
|
||||
(:use-reexport #:cl-deck-builder2.models.attachment
|
||||
#:cl-deck-builder2.models.category
|
||||
#:cl-deck-builder2.models.constructed-decks
|
||||
#:cl-deck-builder2.models.feedback
|
||||
#:cl-deck-builder2.models.qr-code
|
||||
#:cl-deck-builder2.models.registered-table
|
||||
#:cl-deck-builder2.models.sqlite-schema
|
||||
#:cl-deck-builder2.models.user
|
||||
#:cl-deck-builder2.models.ydk
|
||||
#:cl-deck-builder2.models.ygoprodeck
|
||||
#:cl-deck-builder2.models.ygoprodeck.fields
|
||||
#:cl-deck-builder2.models.ygoprodeck.cardinfo
|
||||
#:cl-deck-builder2.models.ygoprodeck.json
|
||||
;; TODO replace ygoprodeck with ygoprodeck2
|
||||
#:cl-deck-builder2.models.ygoprodeck.classes
|
||||
#:cl-deck-builder2.models.ygoprodeck.methods))
|
||||
100
src/models/qr-code.lisp
Normal file
100
src/models/qr-code.lisp
Normal file
@ -0,0 +1,100 @@
|
||||
#|
|
||||
|
||||
QR Code Model
|
||||
|
||||
Constantly fixing their user input was getting janky. DEFCLASS to the rescue!
|
||||
|
||||
TODO This is still pretty clumbsy. I'm generating HTML in here??
|
||||
|
||||
Originally I was using INITIALIZE-INSTANCE but that would clobber the
|
||||
object with the DEFAULT-INITARGS. Now we're overriding
|
||||
REINITIALIZE-INSTANCE, which seems to work exactly as you'd expect.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.qr-code)
|
||||
|
||||
;; XXX
|
||||
(defparameter *qr-public-file* #P"~/public/qr.png")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass qr-settings ()
|
||||
((string :accessor qr-string
|
||||
:initarg :string)
|
||||
(min-version :accessor qr-min-version
|
||||
:initarg :min-version)
|
||||
(ec-level :accessor qr-ec-level
|
||||
:initarg :ec-level)
|
||||
(encoding-mode :accessor qr-encoding-mode
|
||||
:initarg :encoding-mode)
|
||||
(mask-number :accessor qr-mask-number
|
||||
:initarg :mask-number)
|
||||
(output-path :accessor qr-output-path
|
||||
:initarg :output))
|
||||
(:default-initargs
|
||||
:ec-level :L
|
||||
:encoding-mode :8-BIT-BYTE
|
||||
:mask-number -1
|
||||
:min-version 1
|
||||
:output #P"/tmp/qr.png"
|
||||
:string "Hello World"))
|
||||
|
||||
(defmethod reinitialize-instance :after ((qr-settings qr-settings) &rest initargs &key content &allow-other-keys)
|
||||
(declare (ignore initargs))
|
||||
(when content
|
||||
(reinitialize-with-content qr-settings content)))
|
||||
|
||||
;; Overwrite existing slots even if they're SLOT-BOUNDP with SLOT-VALUE
|
||||
(defmethod reinitialize-with-content ((qr-settings qr-settings) content)
|
||||
;; TODO ALIST-PARAMS-to-class? The idea is there...
|
||||
(alexandria:if-let ((string (query-param "string" content)))
|
||||
(setf (qr-string qr-settings) string))
|
||||
|
||||
(alexandria:if-let ((min-version (query-param "min-version" content)))
|
||||
(setf (qr-min-version qr-settings) (parse-integer min-version)))
|
||||
|
||||
(alexandria:if-let ((ec-level (query-param "ec-level" content)))
|
||||
(setf (qr-ec-level qr-settings) (alexandria:make-keyword ec-level)))
|
||||
|
||||
(alexandria:if-let ((encoding-mode (query-param "encoding-mode" content)))
|
||||
(setf (qr-encoding-mode qr-settings) (alexandria:make-keyword encoding-mode)))
|
||||
|
||||
(alexandria:if-let ((mask-number (query-param "mask-number" content)))
|
||||
(setf (qr-mask-number qr-settings) (parse-integer mask-number)))
|
||||
qr-settings)
|
||||
|
||||
;; TODO %from-plist
|
||||
;; TODO %from-alist?
|
||||
(defmethod qr-to-plist ((qr-settings qr-settings) &optional html)
|
||||
(let ((params
|
||||
(list :ec-level (qr-ec-level qr-settings)
|
||||
:encoding-mode (qr-encoding-mode qr-settings)
|
||||
:mask-number (qr-mask-number qr-settings)
|
||||
:min-version (qr-min-version qr-settings))))
|
||||
(when html
|
||||
(setf (getf params :string) (qr-string qr-settings)
|
||||
(getf params :ec-level) (princ-to-string (getf params :ec-level))
|
||||
(getf params :encoding-mode) (princ-to-string (getf params :encoding-mode))))
|
||||
params))
|
||||
|
||||
(defmethod qr-generate ((qr qr-settings))
|
||||
(v:info :qr "QR-STRING: ~a" (qr-string qr))
|
||||
|
||||
(v:info :qr "UIOP:DELETE-FILE-IF-EXISTS: ~a"
|
||||
(ignore-errors
|
||||
(mapcar #'uiop:delete-file-if-exists '(#P"/tmp/qr.png" #P"~/public/qr.png"))))
|
||||
|
||||
(v:info :qr "LISPQR:ENCODE->IMAGE: ~a"
|
||||
(ignore-errors
|
||||
(apply #'lispqr:encode->image (qr-string qr) (qr-output-path qr)
|
||||
(qr-to-plist qr))))
|
||||
|
||||
(v:info :qr "UIOP:COPY-FILE: ~a"
|
||||
(ignore-errors
|
||||
(uiop:copy-file (qr-output-path qr) *qr-public-file*)))
|
||||
|
||||
(if (probe-file *qr-public-file*)
|
||||
(qr-format-html (get-universal-time))))
|
||||
|
||||
(defun qr-format-html (when)
|
||||
(format nil "<img class=\"card image\" src=\"/public/qr.png?~d\" alt=\"QR Code\">" when))
|
||||
99
src/models/registered-table-mixin.lisp
Normal file
99
src/models/registered-table-mixin.lisp
Normal file
@ -0,0 +1,99 @@
|
||||
#|
|
||||
|
||||
src/models/registered-table-mixin.lisp
|
||||
|
||||
Model Object Class. Instead of writing new code every time for every
|
||||
new Model (Model, View, Component), encapsulate the behavior here.
|
||||
|
||||
Now using mixins!
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.registered-table)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Thanks mariari! https://lispcookbook.github.io/cl-cookbook/clos.html#metaclasses
|
||||
(defclass model-registry ()
|
||||
((registry :allocation :class
|
||||
:accessor model-registry
|
||||
:initform (make-hash-table))))
|
||||
|
||||
(defmethod registered-classes ((registry model-registry) &optional package)
|
||||
(if package
|
||||
(gethash (find-package package) (model-registry registry))
|
||||
;; If no package was provided return a LIST of all packages tracked by the MODEL-REGISTRY.
|
||||
(apply #'concatenate 'list
|
||||
(alexandria:hash-table-values (model-registry registry)))))
|
||||
|
||||
(defparameter *registry* (make-instance 'model-registry)
|
||||
"Global model registry instance.")
|
||||
|
||||
(defun registry (&optional (registry *registry*))
|
||||
"Get the MODEL-REGISTRY associated with REGISTRY. Default is *REGISTRY*."
|
||||
registry)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Inherit from MITO:DAO-TABLE-CLASS because MITO:DAO-TABLE-MIXIN
|
||||
;; doesn't have the additional PRIMARY-KEY or TIMESTAMP mechanisms or
|
||||
;; anything.
|
||||
(defclass registered-table-class (mito:dao-table-class) ())
|
||||
|
||||
(defmethod closer-mop:validate-superclass ((class registered-table-class)
|
||||
(superclass mito:dao-table-class))
|
||||
t)
|
||||
|
||||
(defmethod initialize-instance :after ((class registered-table-class) &rest initargs &key &allow-other-keys)
|
||||
(declare (ignore initargs))
|
||||
(pushnew (class-name class)
|
||||
(gethash (symbol-package (class-name class))
|
||||
(model-registry (registry)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tables
|
||||
(defmethod create-tables ((registry model-registry) &optional package)
|
||||
"Create tables for CLASS-LIST by wrapping DBD:CREATE-TABLE."
|
||||
(apply #'create-table
|
||||
(registered-classes registry package)))
|
||||
|
||||
(defmethod drop-tables ((registry model-registry) &optional package)
|
||||
"Drop tables for CLASS-LIST by wrapping DB:DROP-TABLE."
|
||||
(apply #'drop-table
|
||||
(registered-classes registry package)))
|
||||
|
||||
(defmethod recreate-tables ((registry model-registry) &optional package)
|
||||
(drop-tables registry package)
|
||||
(create-tables registry package))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod migration-expressions ((registry model-registry) &optional package)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar #'mito:migration-expressions
|
||||
(registered-classes registry package)))))
|
||||
|
||||
(defmethod migrate-table ((registry model-registry) &optional package)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar #'mito:migrate-table
|
||||
(registered-classes registry package)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun ensure-tables-exist (&optional package)
|
||||
(create-tables (registry) package))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod export-registered-classes ((registry model-registry) &key package (stream *standard-output*))
|
||||
"Export REGISTERED-CLASSES for REGISTRY to STREAM, which by default, is *STANDARD-OUTPUT*."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(format stream "~{~a~^;~%~};"
|
||||
(mapcar (lambda (class) (sxql:yield (car (mito:table-definition class))))
|
||||
(registered-classes registry package))))))
|
||||
|
||||
(defun export-registered-classes-to-file (&key (output (relative-pathname "db/schema.sql")) package)
|
||||
(with-open-file (stream output
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(export-registered-classes (registry) :package package :stream stream)
|
||||
(probe-file output)))
|
||||
76
src/models/search.lisp
Normal file
76
src/models/search.lisp
Normal file
@ -0,0 +1,76 @@
|
||||
#|
|
||||
|
||||
Search Session Object
|
||||
|
||||
TODO
|
||||
|
||||
The idea was I basically just wanted to copy the code from web/search.lisp
|
||||
|
||||
Maybe each database object could have their own search sessions? Like
|
||||
the web deck builder could subclass SEARCH-SESSION with the correct
|
||||
DEFAULT-INITARGS and relevant CLASS info
|
||||
|
||||
|#
|
||||
|
||||
(defpackage #:cl-deck-builder2.models.search
|
||||
(:use #:cl))
|
||||
|
||||
(in-package #:cl-deck-builder2.models.search)
|
||||
|
||||
;; TODO Where does this go?
|
||||
(defparameter +search-param-whitelist+
|
||||
'("amazon-asin" "barcode" "brand" "buy-price" "category" "code" "created-by"
|
||||
"deck-id" "desc" "description" "domestic-only" "edition" "email" "id" "kind"
|
||||
"linkmarkers" "linkval" "manufacturer-sku" "max-qty" "msrp" "parent" "price"
|
||||
"product-name" "rarity" "rarity-code" "sell-price" "tax-exempt" "total-qty"
|
||||
"url" "weight" "wishlists" "atk" "def" "level" "scale" "passcode" "type"
|
||||
"frame-type" "race" "attribute" "archetype" "name" "opt-qty" "qty" "condition")
|
||||
"A whitelist of keywords allowed by user input on the database side.")
|
||||
|
||||
(defclass search-session-base () ())
|
||||
|
||||
;; TODO SLOTs or MAKE-HASH-TABLE? Or an ALIST?
|
||||
(defclass search-session (search-session-base)
|
||||
((direction)
|
||||
(limit)
|
||||
(offset)
|
||||
(sort-by)
|
||||
(variant))
|
||||
(:default-initargs
|
||||
:direction "asc"
|
||||
:limit 10
|
||||
:offset 0
|
||||
:sort-by "id"))
|
||||
|
||||
(defmethod initialize-instance :after ((obj search-session) &rest initargs &key &allow-other-keys)
|
||||
(declare (ignore initargs)))
|
||||
|
||||
;; FILTER-ALIST
|
||||
(defgeneric search-query-filter (obj))
|
||||
|
||||
;; MAKE-SEARCH-QUERY
|
||||
(defgeneric search-query-exec (obj))
|
||||
|
||||
;; MAKE-COUNT-QUERY
|
||||
(defgeneric search-query-count (obj))
|
||||
|
||||
;; MAKE-ORDER-BY
|
||||
(defgeneric search-query-order-by (obj direction sort-by))
|
||||
|
||||
;; MAKE-WHERE-CLAUSE
|
||||
(defgeneric search-where-and (obj direction sort-by))
|
||||
|
||||
(defun make-sql-clause (op field value)
|
||||
(let ((op (typecase op
|
||||
(symbol op)
|
||||
(string (alexandria:make-keyword (string-upcase
|
||||
(substitute #\_ #\- op))))))
|
||||
(field (typecase field
|
||||
(symbol field)
|
||||
(string (alexandria:make-keyword (string-upcase
|
||||
(substitute #\_ #\- field)))))))
|
||||
(list op field (if (eq op :like)
|
||||
(format nil "%~a%" value)
|
||||
value))))
|
||||
|
||||
;; (defun make-kind (kind alist))
|
||||
40
src/models/sqlite-schema.lisp
Normal file
40
src/models/sqlite-schema.lisp
Normal file
@ -0,0 +1,40 @@
|
||||
#|
|
||||
|
||||
SQLite has a built-in schema table where you can do a level of
|
||||
introspection on the database. I've used this functionality a few
|
||||
times now so this encapsulates that behavior.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.sqlite-schema)
|
||||
|
||||
;; https://www.sqlite.org/schematab.html
|
||||
(defclass sqlite-schema ()
|
||||
((type :col-type :text)
|
||||
(name :col-type :text)
|
||||
(tbl-name :col-type :text)
|
||||
(rootpage :col-type :integer)
|
||||
(sql :col-type :text))
|
||||
(:auto-pk nil)
|
||||
(:record-timestamps nil)
|
||||
(:metaclass mito:dao-table-mixin))
|
||||
|
||||
(defgeneric kind-of (obj)
|
||||
(:method ((sqlite-schema sqlite-schema))
|
||||
(slot-value sqlite-schema 'type)))
|
||||
|
||||
(defmethod name-of ((sqlite-schema sqlite-schema))
|
||||
(slot-value sqlite-schema 'name))
|
||||
|
||||
(defgeneric rootpage-of (obj)
|
||||
(:method ((sqlite-schema sqlite-schema))
|
||||
(slot-value sqlite-schema 'rootpage)))
|
||||
|
||||
(defgeneric sql-of (obj)
|
||||
(:method ((sqlite-schema sqlite-schema))
|
||||
(slot-value sqlite-schema 'sql)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun table-names ()
|
||||
(mapcar #'name-of
|
||||
(select-dao 'sqlite-schema)))
|
||||
127
src/models/user.lisp
Normal file
127
src/models/user.lisp
Normal file
@ -0,0 +1,127 @@
|
||||
#|
|
||||
|
||||
src/models/user.lisp
|
||||
|
||||
# User Interaction Backend
|
||||
|
||||
## Create a superuser
|
||||
|
||||
(create-superuser name email password)
|
||||
|
||||
## Create a normal user
|
||||
|
||||
(bookshops.models::create-user "Joe Blogg" "JoeBlogg@example.com" "i<3books")
|
||||
|
||||
## Give him rights
|
||||
|
||||
(add-role user :admin)
|
||||
|
||||
Bootstrap roles: see database.lisp bootstrap-base-roles.
|
||||
|
||||
# More Information
|
||||
|
||||
- <https://github.com/fukamachi/can>
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.user)
|
||||
|
||||
(defclass user (has-secure-password)
|
||||
((name :accessor name-of
|
||||
:col-type :text
|
||||
:initarg :name)
|
||||
(email :accessor user-email-of
|
||||
:col-type :text
|
||||
:initarg :email))
|
||||
(:unique-keys email)
|
||||
;; (:primary-key email)
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "The USER class encapsulates information about the users of The Deck Builder: name, email, password, password salt, user roles."))
|
||||
|
||||
(defclass role ()
|
||||
((name ;;:col-type :text
|
||||
:col-type (:varchar 64)
|
||||
:initarg :role
|
||||
:inflate (alexandria:compose #'alexandria:make-keyword #'string-upcase)
|
||||
:deflate #'string-downcase
|
||||
:accessor name-of))
|
||||
(:documentation "The ROLE class encapsulates information about the roles of actions a user may perform, e.g. :ADMIN, :USER, :BANNED.")
|
||||
(:metaclass registered-table-class)
|
||||
(:primary-key name)
|
||||
(:auto-pk nil)
|
||||
(:record-timestamps nil))
|
||||
|
||||
(defclass user-role ()
|
||||
((user :col-type user
|
||||
:initarg :user
|
||||
:accessor user-role-user)
|
||||
(role :col-type role
|
||||
:initarg :role
|
||||
:accessor user-role-role))
|
||||
(:metaclass registered-table-class)
|
||||
(:primary-key user role)
|
||||
(:auto-pk nil)
|
||||
(:record-timestamps nil))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun create-user (name email password)
|
||||
"Create a USER object with NAME, EMAIL, and PASSWORD fields. Will automatically be synced to db via CREATE-DAO. Password hashing provided by MITO-AUTH."
|
||||
(create-dao 'user :name name
|
||||
:email email
|
||||
:password password))
|
||||
|
||||
(defun find-user (email)
|
||||
"Find a user by EMAIL."
|
||||
(find-dao 'user :email email))
|
||||
|
||||
;; (defun create-superuser (name email password)
|
||||
;; "Create a USER with the ADMIN role."
|
||||
;; (let ((user (create-user name email password)))
|
||||
;; (add-role user :admin)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO Role Viewer / Editor
|
||||
(defun create-role (name)
|
||||
"Create a ROLE called NAME. If the ROLE exists, return that, instead."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(or (mito:find-dao 'role :name name)
|
||||
(mito:create-dao 'role :name name)))))
|
||||
|
||||
(defun %find-role-from-keyword (role-name)
|
||||
"Return a role object from a keyword and throw an error if an associated role cannot be found"
|
||||
(let ((role (find-dao 'role :name role-name)))
|
||||
(assert role (role) "There is no role named ~a" role-name)
|
||||
role))
|
||||
|
||||
(defgeneric add-role (user role)
|
||||
(:documentation "Add the given role to this user. ROLE is either a role object or a symbol. An example role is ':admin`.")
|
||||
(:method ((user user) (role role))
|
||||
(or (find-dao 'user-role :user user :role role)
|
||||
(create-dao 'user-role :user user :role role)))
|
||||
(:method ((user user) (role-name symbol))
|
||||
(let ((role (%find-role-from-keyword role-name)))
|
||||
(add-role user role))))
|
||||
|
||||
;; Retrieving roles from "user-role" table
|
||||
(defmethod user-roles-of ((user user))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar #'user-role-role
|
||||
(mito:retrieve-dao 'user-role :user user)))))
|
||||
|
||||
(defgeneric user-has-role (user role)
|
||||
(:documentation "Given a USER and a ROLE, return T if ROLE is a MEMBER of USER-ROLES for USER, NIL otherwise.")
|
||||
(:method ((user user) (role role))
|
||||
(member (name-of role) (user-roles-of user) :key #'name-of))
|
||||
(:method ((user user) (role-name symbol))
|
||||
(let ((role (%find-role-from-keyword role-name)))
|
||||
(user-has-role user role))))
|
||||
|
||||
(defmethod user-admin-p ((user user))
|
||||
"Is USER an admin? Return T if so. NIL otherwise."
|
||||
(user-has-role user :admin))
|
||||
|
||||
(defmethod user-verified-p ((user user))
|
||||
"Is USER in the VERIFIED role? Return T if so. NIL otherwise."
|
||||
(user-has-role user :verified))
|
||||
591
src/models/ydk.lisp
Normal file
591
src/models/ydk.lisp
Normal file
@ -0,0 +1,591 @@
|
||||
#|
|
||||
|
||||
src/models/ydk/classes.lisp
|
||||
|
||||
# YDK
|
||||
|
||||
Yu-Gi-Oh! Pro Deck YDK Importer And Models
|
||||
|
||||
TODO This can be a stand-alone package CL-YDK + the CL-YDK+MITO mixin probably.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ydk)
|
||||
|
||||
(defclass deck-item ()
|
||||
(;; 0 => Main Deck
|
||||
;; 1 => Extra Deck
|
||||
;; 2 => Side Deck
|
||||
(deck-id :accessor deck-id-of :col-type :integer)
|
||||
(kind :accessor deck-kind-of :col-type :integer)
|
||||
(passcode :accessor deck-passcode-of :col-type :integer))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "DECK-LIST is a representation of a single card in a YDK deck in
|
||||
SQL. Since SQL doesn't have a LIST type, we use a bunch of
|
||||
these (60-90 rows generally make up a deck). The ID field supplied by
|
||||
MITO:DAO-TABLE-CLASS is the \"Deck ID\" in the builder system."))
|
||||
|
||||
(defclass ydk-deck ()
|
||||
(;; (id :accessor ydk-id-of :col-type :integer :primary-key t)
|
||||
(category :accessor ydk-category-of :col-type (or category :null))
|
||||
(created-by :accessor ydk-created-by :col-type :text :initarg :created-by)
|
||||
(name :accessor ydk-name-of :col-type :text :initarg :name))
|
||||
(:unique-keys name)
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A YDK-DECK is an in-database representation of a deck. It's really actually just an index to keep track of metadata, with the ID field used to key into DECK-ITEM.
|
||||
|
||||
SQL doesn't allow us to store anything as a list. We take advantage
|
||||
of Mito's INSERT-DAO, SELECT-DAO, etc. being methods which we can
|
||||
define :BEFORE :AFTER and :AROUND methods for. The YDK-DECK class is
|
||||
an intermediate representation of a deck. Bookeeping for the \"Deck
|
||||
ID\", CREATED-BY, and NAME."))
|
||||
|
||||
(defclass ydk ()
|
||||
((;; I think this is supposed to be the MITO:OBJECT-ID to keep tabs
|
||||
;; on the SYNC status... Looks like I never wrote it down, but I'm
|
||||
;; pretty sure that was my intention with this SLOT. It's been a
|
||||
;; pain point previously (PPP).
|
||||
deck-id :accessor ydk-id-of :initarg :deck-id)
|
||||
(created-by :accessor ydk-created-by :initarg :created-by :initform nil)
|
||||
(name :accessor ydk-name-of :initarg :name :initform nil)
|
||||
(main-deck :accessor ydk-main-deck-of :initarg :main-deck :initform '())
|
||||
(extra-deck :accessor ydk-extra-deck-of :initarg :extra-deck :initform '())
|
||||
(side-deck :accessor ydk-side-deck-of :initarg :side-deck :initform '()))
|
||||
(:documentation "Intermediate YDK representation.
|
||||
|
||||
This is what's stored in-memory during program operation, and then gets synced to the database.
|
||||
|
||||
Notice this class does not draw from MITO:DAO-TABLE-CLASS."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helper functions
|
||||
;;
|
||||
;; TODO maybe I don't have to duplicate this data?
|
||||
;;
|
||||
;; I tried using defparameter but defmacro complained when I tried to
|
||||
;; load it.
|
||||
;;
|
||||
;; Aha, The Original Variant.
|
||||
;; This code needs to be incorporated into the VARIANT code.
|
||||
|
||||
(defmacro %sql-to-keyword (type)
|
||||
`(ecase ,type
|
||||
(0 :main-deck)
|
||||
(1 :extra-deck)
|
||||
(2 :side-deck)))
|
||||
|
||||
(defmacro %keyword-to-sql (type)
|
||||
`(ecase ,type
|
||||
(:main-deck 0)
|
||||
(:extra-deck 1)
|
||||
(:side-deck 2)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO I think I'm going to erase all these DEFUNs since they're kinda
|
||||
;; outdated now with the changes I made in db.lisp
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Delete
|
||||
(defun ydk-deck-delete-from (&rest clauses)
|
||||
(apply #'delete-from 'ydk-deck clauses))
|
||||
|
||||
(defun ydk-deck-item-delete-from (&rest clauses)
|
||||
(apply #'delete-from 'deck-item clauses))
|
||||
|
||||
(defun ydk-deck-delete-by-id (id)
|
||||
"Remove all matching ID from YDK-DECK and DECK-ITEM, effectively erasing the deck from the database."
|
||||
(ydk-deck-delete-from
|
||||
(sxql:where (:= :id id)))
|
||||
(ydk-deck-item-delete-from
|
||||
(sxql:where (:= :deck_id id))))
|
||||
|
||||
(defun ydk-deck-delete-by-name (name)
|
||||
(let ((found (ydk-deck-by-name name)))
|
||||
(when found
|
||||
;; Delete from both the DECK-ITEM and the YDK-DECK reference
|
||||
;; table. The :deck_item table doesn't have a :NAME field, it
|
||||
;; only has the :DECK_ID field. So we need to use
|
||||
;; SELECT-DECK-BY-NAME anyway.
|
||||
(ydk-deck-delete-by-id (mito:object-id found)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Select
|
||||
(defmacro ydk-table-select (&body body)
|
||||
`(select-dao 'ydk-deck ,@body))
|
||||
|
||||
(defun ydk-table-select-count (&optional fields-and-values)
|
||||
(apply #'count-dao 'ydk-deck fields-and-values))
|
||||
|
||||
(defun ydk-deck-by-id (id &rest args)
|
||||
(apply #'find-dao 'ydk-deck :id id args))
|
||||
|
||||
(defun ydk-deck-by-name (name &rest args)
|
||||
(apply #'find-dao 'ydk-deck :name name args))
|
||||
|
||||
;; Very cool to have figured this out. To get info on a deck, select
|
||||
;; the deck_item where the deck_id is the deck you want. Then INNER
|
||||
;; JOIN on :card_info. It just works. One db trip. Aweseome!
|
||||
;;
|
||||
;; TODO how can we do this with SELECT-DAO?
|
||||
;;
|
||||
;; For now since this is only getting used in one place, RENDER-YDK,
|
||||
;; which is albeit, a pretty core component, ... I'll use
|
||||
;; datafly. Until I figure out how to relate these columns.
|
||||
;;
|
||||
;; I think this is a duplicate of YDK-QUERY... Okay it occured to
|
||||
;; me. I used to use YDK-QUERY before I figured this one out and I
|
||||
;; think I know what's going on.
|
||||
;;
|
||||
;; So YDK-DECK-INFO-BY-ID uses SQL to do an INNER JOIN to get the data
|
||||
;; from the deck. YDK-QUERY works on decks that aren't in the database
|
||||
;; and only returns partial information. I have to use that info to
|
||||
;; re-construct the data. The original purpose of YDK-QUERY was to use
|
||||
;; it like a look-up table, based on that sorting dev.to article.
|
||||
;;
|
||||
;; But then I realized, it's a lot more efficient to do it at the
|
||||
;; database level. so that's where YDK-DECK-INFO-BY-ID was born
|
||||
;; from. It works on existing decks in the database.
|
||||
(defgeneric ydk-query (id))
|
||||
|
||||
(defmethod ydk-query ((id integer))
|
||||
"Query the database for information from YGO_INFO about the DECK ID."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:retrieve-by-sql
|
||||
(sxql:select :*
|
||||
(sxql:from :ygo_info)
|
||||
(sxql:inner-join :deck_item
|
||||
:on (:= :deck_item.passcode :ygo_info.passcode))
|
||||
(sxql:order-by :asc :deck_item.id)
|
||||
(sxql:where (:= :deck_id id)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod ydk-query ((ydk-deck ydk-deck))
|
||||
"Query the YDK-DECK by its MITO:OBJECT-ID"
|
||||
(ydk-query (mito:object-id ydk-deck)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod ydk-query ((ydk ydk))
|
||||
"Select entries from :YGOPRODECK-DATA corresponding to the unique list
|
||||
of cards in DECK. This can be used as a look up table to construct a
|
||||
deck description.
|
||||
|
||||
It looks like I updated YDK-QUERY to work with the new YDK-ALL output. Neat!"
|
||||
(let* ((all (ydk-all ydk))
|
||||
(cards (ydk-concatenate ydk))
|
||||
(info (with-datafly-connection (db)
|
||||
(with-datafly-transaction (db)
|
||||
(datafly:retrieve-all
|
||||
(sxql:select :*
|
||||
(sxql:from :ygo_info)
|
||||
(sxql:where (:in :passcode cards))))))))
|
||||
(labels ((query-deck (kind)
|
||||
(loop for passcode in (getf all kind)
|
||||
collect
|
||||
(find passcode info
|
||||
:key (lambda (plist) (getf plist :passcode))))))
|
||||
(list
|
||||
:main-deck (query-deck :main-deck)
|
||||
:extra-deck (query-deck :extra-deck)
|
||||
:side-deck (query-deck :side-deck)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Update
|
||||
(defmethod ydk-rename-deck ((ydk-deck ydk-deck) new-name)
|
||||
(setf (ydk-name-of ydk-deck) new-name)
|
||||
(save-dao ydk-deck))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun normalize-content (content)
|
||||
"Strip UTF-8 BOM, \"\r\n\" sequences, then split on #\Newline into a list."
|
||||
(etypecase content
|
||||
;; It's a LIST - pass it on
|
||||
(list content)
|
||||
;; It's a PATHNAME - UIOP:READ-FILE-STRING and then treat it like
|
||||
;; a STRING.
|
||||
(pathname
|
||||
(split-sequence:split-sequence
|
||||
#\Newline
|
||||
(normalize-newlines
|
||||
(strip-bom (uiop:read-file-string content)))))
|
||||
;; It's a STRING: strip BOM and normalize newlines.
|
||||
(string
|
||||
(split-sequence:split-sequence
|
||||
#\Newline
|
||||
(normalize-newlines
|
||||
(strip-bom content))))))
|
||||
|
||||
(defmethod initialize-with-content ((ydk ydk) content)
|
||||
(let ((created-by nil)
|
||||
(main-deck '())
|
||||
(extra-deck '())
|
||||
(side-deck '())
|
||||
(state :in-created-by))
|
||||
|
||||
(dolist (itm (normalize-content content))
|
||||
;; A bunch of :END2 checks to prevent overrun.
|
||||
(unless
|
||||
;; Detect state change
|
||||
(cond ((string-equal "#main" itm :end2 (min (length itm) 5))
|
||||
(setf state :in-main)
|
||||
t)
|
||||
((string-equal "#extra" itm :end2 (min (length itm) 6))
|
||||
(setf state :in-extra)
|
||||
t)
|
||||
((string-equal "!side" itm :end2 (min (length itm) 5))
|
||||
(setf state :in-side)
|
||||
t)
|
||||
((equal "" itm)
|
||||
t)) ; Skip blank lines!
|
||||
;; Otherwise, we assume it's a valid PASSCODE.
|
||||
(ccase state
|
||||
(:in-created-by (setf created-by itm))
|
||||
(:in-main (push (parse-integer itm) main-deck))
|
||||
(:in-side (push (parse-integer itm) side-deck))
|
||||
(:in-extra (push (parse-integer itm) extra-deck)))))
|
||||
|
||||
(unless (and (slot-boundp ydk 'created-by)
|
||||
(slot-value ydk 'created-by))
|
||||
(setf (ydk-created-by ydk) created-by))
|
||||
;; Currently we don't read the NAME of the YDK from anywhere
|
||||
;; *inside* the file contents, it is provided externally,
|
||||
;; e.g. file name.
|
||||
;;
|
||||
;; (unless (and (slot-boundp ydk 'name)
|
||||
;; (slot-value ydk 'name))
|
||||
;; (setf (ydk-name-of ydk) name))
|
||||
(unless (and (slot-boundp ydk 'main-deck)
|
||||
(slot-value ydk 'main-deck))
|
||||
(setf (ydk-main-deck-of ydk)
|
||||
(reverse main-deck)))
|
||||
(unless (and (slot-boundp ydk 'extra-deck)
|
||||
(slot-value ydk 'extra-deck))
|
||||
(setf (ydk-extra-deck-of ydk)
|
||||
(reverse extra-deck)))
|
||||
(unless (and (slot-boundp ydk 'side-deck)
|
||||
(slot-value ydk 'side-deck))
|
||||
(setf (ydk-side-deck-of ydk)
|
||||
(reverse side-deck)))))
|
||||
|
||||
(defmethod initialize-instance :after ((ydk ydk) &rest initargs
|
||||
&key content &allow-other-keys)
|
||||
(declare (ignore initargs))
|
||||
(when content
|
||||
(initialize-with-content ydk content)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defmethod ydk-add ((ydk ydk) target-deck passcode)
|
||||
(let ((deck
|
||||
(ecase target-deck
|
||||
(:main (ydk-main-deck-of ydk))
|
||||
(:extra (ydk-extra-deck-of ydk))
|
||||
(:side (ydk-side-deck-of ydk)))))
|
||||
(ccase target-deck
|
||||
(:main
|
||||
(setf (ydk-main-deck-of ydk) (append deck (list passcode))))
|
||||
(:extra
|
||||
(setf (ydk-extra-deck-of ydk) (append deck (list passcode))))
|
||||
(:side
|
||||
(setf (ydk-side-deck-of ydk) (append deck (list passcode)))))))
|
||||
|
||||
;; TODO Deprecated. Remove this code. YDK-DELETE-INDEX is
|
||||
;; superior. How are we going to tackle moving cards?
|
||||
(defmethod ydk-delete ((ydk ydk) kind passcode &optional (count 1))
|
||||
"Sloppily remove PASSCODE from YDK KIND deck. KIND is one of :MAIN
|
||||
:EXTRA or :SIDE. Optionally specify how many to remove with COUNT,
|
||||
default of 1."
|
||||
(labels ((remove-fn (array)
|
||||
(remove-if (lambda (lst) (eq lst passcode)) array :count count)))
|
||||
(with-slots (main-deck extra-deck side-deck) ydk
|
||||
(ccase kind
|
||||
(:main (setf main-deck (remove-fn main-deck)))
|
||||
(:side (setf side-deck (remove-fn side-deck)))
|
||||
(:extra (setf extra-deck (remove-fn extra-deck)))))))
|
||||
|
||||
(defmethod ydk-delete-index ((ydk ydk) kind index &optional (count 1))
|
||||
"Delete COUNT sequential cards at INDEX from the KIND of deck. KIND
|
||||
is one of :MAIN :EXTRA or :SIDE."
|
||||
(with-slots (main-deck extra-deck side-deck) ydk
|
||||
(ccase kind
|
||||
(:main (setf main-deck
|
||||
(append
|
||||
(subseq main-deck 0 index)
|
||||
(subseq main-deck (+ count index)))))
|
||||
(:extra (setf extra-deck
|
||||
(append
|
||||
(subseq extra-deck 0 index)
|
||||
(subseq extra-deck (+ count index)))))
|
||||
(:side (setf side-deck
|
||||
(append
|
||||
(subseq side-deck 0 index)
|
||||
(subseq side-deck (+ count index))))))))
|
||||
|
||||
(defmethod ydk-clear ((ydk ydk) &optional target-deck)
|
||||
"Clear out the YDK."
|
||||
(case target-deck
|
||||
(:main (setf (ydk-main-deck-of ydk) nil))
|
||||
(:side (setf (ydk-side-deck-of ydk) nil))
|
||||
(:extra (setf (ydk-extra-deck-of ydk) nil))
|
||||
(t (progn
|
||||
(ydk-clear ydk :main)
|
||||
(ydk-clear ydk :extra)
|
||||
(ydk-clear ydk :side)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod ydk-sync ((ydk ydk))
|
||||
"Synchronize this YDK intermediate deck to the database. If there's
|
||||
already a deck by this name, we \"update\" it by erasing all the
|
||||
entries matching that DECK ID using YDK-DECK-ITEM-DELETE-FROM. That is, YDK => SQL."
|
||||
(let ((deck-list '())
|
||||
(deck (ydk-deck-by-name (ydk-name-of ydk))))
|
||||
|
||||
;; Create the new deck if it does not exist.
|
||||
(unless deck
|
||||
(setf deck
|
||||
(create-dao 'ydk-deck
|
||||
:name (ydk-name-of ydk)
|
||||
:created-by (ydk-created-by ydk))))
|
||||
|
||||
;; If A deck with this name already exists: clear out the old
|
||||
;; list. This no longer erases the YDK-DECK entry, so DECK-ID
|
||||
;; should stay consistent now.
|
||||
(ydk-deck-item-delete-from
|
||||
(sxql:where
|
||||
(:= :deck_item.deck_id (mito:object-id deck))))
|
||||
|
||||
;; Insert new deck_items into the database. How do we do
|
||||
;; that? We create a bunch of objects then MITO:INSERT-DAO them.
|
||||
(loop for (kind lst) on (ydk-all ydk) by #'cddr do
|
||||
(dolist (passcode lst)
|
||||
(push (make-instance 'deck-item
|
||||
:deck-id (mito:object-id deck)
|
||||
:kind (%keyword-to-sql kind)
|
||||
:passcode passcode)
|
||||
deck-list)))
|
||||
|
||||
(if (do-grouped-insert deck-list)
|
||||
deck)))
|
||||
|
||||
(defmethod ydk-sync ((ydk-deck ydk-deck))
|
||||
"Query the database deck with this YDK-DECK. That is, SQL => YDK.
|
||||
|
||||
TODO Why not WITH-SLOTS?"
|
||||
(with-connection (db)
|
||||
(let* ((id (mito:object-id ydk-deck))
|
||||
(created-by (ydk-created-by ydk-deck))
|
||||
(name (ydk-name-of ydk-deck))
|
||||
(deck-list (mito:retrieve-dao 'deck-item :deck-id id))
|
||||
(main-deck '())
|
||||
(extra-deck '())
|
||||
(side-deck '()))
|
||||
|
||||
(dolist (deck-item deck-list)
|
||||
(let ((passcode (deck-passcode-of deck-item)))
|
||||
;; TODO There could be a macro (with-main-side-extra-decks)
|
||||
;; or something to suplliment %keyword-to-sql and
|
||||
;; %sql-to-keyword.
|
||||
(ccase (deck-kind-of deck-item)
|
||||
(0 (push passcode main-deck))
|
||||
(1 (push passcode extra-deck))
|
||||
(2 (push passcode side-deck)))))
|
||||
|
||||
(make-instance 'ydk
|
||||
:deck-id id
|
||||
:name name
|
||||
:created-by created-by
|
||||
:main-deck main-deck
|
||||
:extra-deck extra-deck
|
||||
:side-deck side-deck))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod ydk-all ((ydk ydk))
|
||||
"Get the list of cards from a deck, duplicates included. Generally this order is retained from e.g. file upload or deck creation.
|
||||
|
||||
SEE YDK-SORTED."
|
||||
(with-slots (main-deck extra-deck side-deck) ydk
|
||||
(list :main-deck main-deck
|
||||
:side-deck side-deck
|
||||
:extra-deck extra-deck)))
|
||||
|
||||
(defmethod ydk-concatenate ((ydk ydk))
|
||||
"Get the list of cards from a deck, duplicates included. Generally this order is retained from e.g. file upload or deck creation.
|
||||
|
||||
SEE YDK-SORTED."
|
||||
(with-slots (main-deck extra-deck side-deck) ydk
|
||||
(concatenate 'list main-deck extra-deck side-deck)))
|
||||
|
||||
(defmethod ydk-unique ((ydk ydk))
|
||||
"Get the unique list of cards from a deck."
|
||||
(remove-duplicates (ydk-concatenate ydk)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; (with-datafly-connection (db)
|
||||
;; (with-datafly-transaction
|
||||
;; (datafly:retrieve-all
|
||||
;; (select (:frame_type) (from :ygo_info) (group-by :frame_type)))))
|
||||
;; ((:FRAME-TYPE "effect") (:FRAME-TYPE "effect_pendulum") (:FRAME-TYPE "fusion")
|
||||
;; (:FRAME-TYPE "fusion_pendulum") (:FRAME-TYPE "link") (:FRAME-TYPE "normal")
|
||||
;; (:FRAME-TYPE "normal_pendulum") (:FRAME-TYPE "ritual")
|
||||
;; (:FRAME-TYPE "ritual_pendulum") (:FRAME-TYPE "skill") (:FRAME-TYPE "spell")
|
||||
;; (:FRAME-TYPE "synchro") (:FRAME-TYPE "synchro_pendulum") (:FRAME-TYPE "token")
|
||||
;; (:FRAME-TYPE "trap") (:FRAME-TYPE "xyz") (:FRAME-TYPE "xyz_pendulum"))
|
||||
(defmethod ydk-sorted ((ydk ydk))
|
||||
"Sort the YDK according to FRAME-TYPE-PRIO."
|
||||
(let ((deck-info (copy-list (ydk-query ydk))))
|
||||
(labels ((frame-type-prio (plist)
|
||||
(let ((kind (getf plist :frame-type)))
|
||||
(cond ((string= kind "normal") 0)
|
||||
((string= kind "effect") 1)
|
||||
((string= kind "ritual") 2)
|
||||
((string= kind "fusion") 3)
|
||||
((string= kind "link") 4)
|
||||
((string= kind "skill") 5)
|
||||
((string= kind "synchro") 6)
|
||||
((string= kind "token") 7)
|
||||
((string= kind "xyz") 8)
|
||||
((string= kind "spell") 9)
|
||||
((string= kind "trap") 10)
|
||||
((string= kind "effect_pendulum") 11)
|
||||
((string= kind "fusion_pendulum") 12)
|
||||
((string= kind "normal_pendulum") 13)
|
||||
((string= kind "ritual_pendulum") 14)
|
||||
((string= kind "synchro_pendulum") 15)
|
||||
((string= kind "xyz_pendulum") 16)
|
||||
(t 17))))
|
||||
(sort-and-extract (kind)
|
||||
(mapcar (lambda (plist) (getf plist :passcode))
|
||||
(sort
|
||||
(sort (copy-list (getf deck-info kind))
|
||||
#'string< :key (lambda (plist) (princ-to-string
|
||||
(getf plist :name))))
|
||||
#'< :key #'frame-type-prio))))
|
||||
(make-instance 'ydk
|
||||
:created-by (ydk-created-by ydk)
|
||||
;; Sometimes unbound - on unsaved decks.
|
||||
:deck-id (ignore-errors (ydk-id-of ydk))
|
||||
:name (ydk-name-of ydk)
|
||||
:main-deck (sort-and-extract :main-deck)
|
||||
:extra-deck (sort-and-extract :extra-deck)
|
||||
:side-deck (sort-and-extract :side-deck)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Now where on earth does this belong? Probably with the YDK stuff maybe?
|
||||
;;
|
||||
;; Maybe this will go back to the toolkit This code might be useful for parsing CSVs or similar.
|
||||
;;
|
||||
#+nil
|
||||
(defun parse-decklist (string)
|
||||
(let ((split-query
|
||||
(mapcar #'(lambda (s)
|
||||
(string-trim '(#\Newline #\Return #\Tab #\Space) s))
|
||||
(remove ""
|
||||
(split-sequence:split-sequence
|
||||
#\Newline
|
||||
(normalize-newlines string))
|
||||
:test #'equal)))
|
||||
(new-list '()))
|
||||
(dolist (line split-query)
|
||||
(multiple-value-bind (string substrings)
|
||||
(cl-ppcre:scan-to-strings "^(\\d+)x (.*)" line)
|
||||
(declare (ignore string))
|
||||
(cond (substrings
|
||||
(let ((card-name (svref substrings 1))
|
||||
(as-number (read-from-string (svref substrings 0))))
|
||||
;; 10x => dotimes 10
|
||||
(dotimes (_ as-number)
|
||||
(push card-name new-list))))
|
||||
(t (push line new-list)))))
|
||||
(reverse new-list)))
|
||||
|
||||
(defmethod ydk-filter-frame-type ((ydk ydk) kind)
|
||||
(let ((monster '("normal" "effect" "ritual" "fusion" "link" "synchro"
|
||||
"xyz" "effect_pendulum" "fusion_pendulum" "normal_pendulum"
|
||||
"ritual_pendulum" "synchro_pendulum" "xyz_pendulum"))
|
||||
(spell '("spell"))
|
||||
(trap '("trap"))
|
||||
(deck-info (ydk-query ydk)))
|
||||
(labels ((filter (plist)
|
||||
(remove-if (lambda (itm)
|
||||
(if (member (getf itm :frame-type)
|
||||
(case kind
|
||||
(:monster monster)
|
||||
(:spell spell)
|
||||
(:trap trap))
|
||||
:test #'equal)
|
||||
nil
|
||||
t))
|
||||
plist)))
|
||||
(filter (getf deck-info :main-deck)))))
|
||||
|
||||
(defmethod ydk-monster-cards ((ydk ydk))
|
||||
(ydk-filter-frame-type ydk :monster))
|
||||
(defmethod ydk-spell-cards ((ydk ydk))
|
||||
(ydk-filter-frame-type ydk :spell))
|
||||
(defmethod ydk-trap-cards ((ydk ydk))
|
||||
(ydk-filter-frame-type ydk :trap))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod ydk-length ((ydk ydk))
|
||||
(reduce #'+ (list (length (ydk-main-deck-of ydk))
|
||||
(length (ydk-extra-deck-of ydk))
|
||||
(length (ydk-side-deck-of ydk)))))
|
||||
|
||||
(defmethod ydk-to-kde ((ydk ydk))
|
||||
"Transform the YDK according to KDE Team List."
|
||||
(let ((created-by (ydk-created-by ydk))
|
||||
(deck-info (ydk-query ydk))
|
||||
(monster-cards (ydk-monster-cards ydk))
|
||||
(spell-cards (ydk-spell-cards ydk))
|
||||
(trap-cards (ydk-trap-cards ydk)))
|
||||
(let ((main-deck (getf deck-info :main-deck))
|
||||
(extra-deck (getf deck-info :extra-deck))
|
||||
(side-deck (getf deck-info :side-deck)))
|
||||
(let ((main-deck-rle (rle-encode-plist main-deck))
|
||||
(extra-deck-rle (rle-encode-plist extra-deck))
|
||||
(side-deck-rle (rle-encode-plist side-deck))
|
||||
(monster-cards-rle (rle-encode-plist monster-cards))
|
||||
(spell-cards-rle (rle-encode-plist spell-cards))
|
||||
(trap-cards-rle (rle-encode-plist trap-cards)))
|
||||
(labels ((pad (lst)
|
||||
(let ((max 17))
|
||||
(append lst
|
||||
(loop for i from (length lst) upto max collect
|
||||
'("" :name ""))))))
|
||||
(list
|
||||
:name (ydk-name-of ydk)
|
||||
:set nil
|
||||
:length (ydk-length ydk)
|
||||
:created-by created-by
|
||||
:first-date nil
|
||||
:final-date nil
|
||||
:monster-cards monster-cards
|
||||
:spell-cards spell-cards
|
||||
:trap-cards trap-cards
|
||||
:main-deck main-deck
|
||||
:side-deck side-deck
|
||||
:extra-deck extra-deck
|
||||
:monster-cards-rle (pad monster-cards-rle)
|
||||
:spell-cards-rle (pad spell-cards-rle)
|
||||
:trap-cards-rle (pad trap-cards-rle)
|
||||
:main-deck-rle (pad main-deck-rle)
|
||||
:side-deck-rle (pad side-deck-rle)
|
||||
:extra-deck-rle (pad extra-deck-rle)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod %to-string ((ydk ydk))
|
||||
(with-slots (created-by main-deck extra-deck side-deck) ydk
|
||||
(with-output-to-string (s)
|
||||
(format s "~A~%"
|
||||
(if created-by
|
||||
created-by
|
||||
"created by..."))
|
||||
(format s "#main~%")
|
||||
(dolist (card-name (coerce main-deck 'list))
|
||||
(format s "~A~%" card-name))
|
||||
(format s "#extra~%")
|
||||
(dolist (card-name (coerce extra-deck 'list))
|
||||
(format s "~A~%" card-name))
|
||||
(format s "!side~%")
|
||||
(dolist (card-name (coerce side-deck 'list))
|
||||
(format s "~A~%" card-name))
|
||||
s)))
|
||||
158
src/models/ygoprodeck-cardinfo.lisp
Normal file
158
src/models/ygoprodeck-cardinfo.lisp
Normal file
@ -0,0 +1,158 @@
|
||||
#|
|
||||
|
||||
src/models/ygoprodeck-cardinfo.lisp
|
||||
|
||||
Version 2 JSON Downloader
|
||||
|
||||
The idea behind this code is you'll be able to one click button download and update the db:
|
||||
|
||||
(cardinfo-update-and-cleanup t)
|
||||
|
||||
TODO Use INFERIOR-SHELL
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.cardinfo)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Constants
|
||||
(defparameter +ygoprodeck-api-uri+ "https://db.ygoprodeck.com/api/v7/cardinfo.php")
|
||||
(defparameter +ygoprodeck-api-uri-misc+ :|misc|)
|
||||
(defparameter +ygoprodeck-api-uri-tcgplayer-data+ :|tcgplayer_data|)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Specials
|
||||
(defparameter *cardinfo* nil
|
||||
"The current CARDINFO object.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Class Definitions
|
||||
(defclass cardinfo ()
|
||||
((input :initarg :input)
|
||||
(output :initarg :output)))
|
||||
|
||||
(defclass cardinfo-php (cardinfo)
|
||||
()
|
||||
(:default-initargs
|
||||
:input +ygoprodeck-api-uri+
|
||||
:output #P"/tmp/cardinfo.php"
|
||||
:tcgplayer-data "yes"
|
||||
:misc "yes"))
|
||||
|
||||
(defclass cardinfo-json (cardinfo)
|
||||
()
|
||||
(:default-initargs
|
||||
:input #P"/tmp/cardinfo.php"
|
||||
:output #P"/tmp/cardinfo.json"))
|
||||
|
||||
;; Extract the card_images image_url from the cardinfo.json
|
||||
;;
|
||||
;; jq '.[].card_images[].image_url' < /tmp/cardinfo.json
|
||||
(defclass cardinfo-list (cardinfo)
|
||||
()
|
||||
(:default-initargs
|
||||
:input #P"/tmp/cardinfo.json"
|
||||
:output #P"/tmp/cardinfo.list"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Generics
|
||||
(defgeneric cardinfo-cleanup (obj))
|
||||
|
||||
(defgeneric cardinfo-convert (from to &optional force))
|
||||
|
||||
(defgeneric cardinfo-download (obj &optional force))
|
||||
|
||||
(defgeneric cardinfo-input (obj)
|
||||
(:method ((obj cardinfo))
|
||||
(let ((slot-value (slot-value obj 'input)))
|
||||
(typecase slot-value
|
||||
(pathname (namestring slot-value))
|
||||
(t slot-value)))))
|
||||
|
||||
(defgeneric cardinfo-output (obj)
|
||||
(:method ((obj cardinfo))
|
||||
(let ((slot-value (slot-value obj 'output)))
|
||||
(typecase slot-value
|
||||
(pathname (namestring slot-value))
|
||||
(t slot-value)))))
|
||||
|
||||
(defgeneric (setf cardinfo-input) (new-value obj)
|
||||
(:method (new-value (obj cardinfo))
|
||||
(setf (slot-value obj 'input) new-value)))
|
||||
|
||||
(defgeneric (setf cardinfo-output) (new-value obj)
|
||||
(:method (new-value (obj cardinfo))
|
||||
(setf (slot-value obj 'output) new-value)))
|
||||
|
||||
(defgeneric cardinfo-input-exists-p (obj)
|
||||
(:method ((obj cardinfo))
|
||||
(probe-file (cardinfo-output obj))))
|
||||
|
||||
(defgeneric cardinfo-output-exists-p (obj)
|
||||
(:method ((obj cardinfo))
|
||||
(probe-file (cardinfo-output obj))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Methods
|
||||
(defmethod initialize-instance :after ((obj cardinfo-php) &rest initargs &key misc tcgplayer-data &allow-other-keys)
|
||||
(declare (ignore initargs))
|
||||
(let ((params '()))
|
||||
(when misc (setf (getf params +ygoprodeck-api-uri-misc+) misc))
|
||||
(when tcgplayer-data (setf (getf params +ygoprodeck-api-uri-tcgplayer-data+) tcgplayer-data))
|
||||
(when params
|
||||
(setf (cardinfo-input obj)
|
||||
(caveman2.helper::add-query-parameters
|
||||
(cardinfo-input obj) params))))
|
||||
obj)
|
||||
|
||||
(defmethod cardinfo-cleanup ((obj cardinfo))
|
||||
(v:info :ygoprodeck.json "CARDINFO-CLEANUP: ~a" obj)
|
||||
(uiop:delete-file-if-exists (cardinfo-output obj)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO This could probably be replaced with CL-JSON processor.
|
||||
(defun cardinfo-run-program (command from to &optional force)
|
||||
(let* ((from-output (cardinfo-output from))
|
||||
(from-output-exists-p (probe-file from-output))
|
||||
;; TO-INPUT is the same as FROM-OUTPUT
|
||||
(to-input (cardinfo-input to))
|
||||
(to-output (cardinfo-output to))
|
||||
(to-output-exists-p (probe-file to-output)))
|
||||
(if (and (string= from-output to-input)
|
||||
from-output-exists-p
|
||||
(or force
|
||||
(not to-output-exists-p)))
|
||||
(let ((command (format nil command from-output to-output)))
|
||||
(v:info :ygoprodeck.cardinfo "Running command: \"~a\"" command)
|
||||
(if (uiop:run-program command :output '(:string :stripped t))
|
||||
(cardinfo-output-exists-p to)))
|
||||
(v:info :ygoprodeck.cardinfo "Detected existing file: \"~a\"" to-output))))
|
||||
|
||||
(defmethod cardinfo-convert ((from cardinfo-php) (to cardinfo-json) &optional force)
|
||||
(cardinfo-run-program "jq '.data' < \"~a\" > \"~a\"" from to force))
|
||||
|
||||
(defmethod cardinfo-convert ((from cardinfo-json) (to cardinfo-list) &optional force)
|
||||
(cardinfo-run-program "jq '.[].card_images[].image_url' < \"~a\" > \"~a\"" from to force))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod cardinfo-download ((obj cardinfo) &optional force)
|
||||
(v:info :ygoprodeck.json "CARDINFO-DOWNLOAD: ~a"
|
||||
(cardinfo-input obj))
|
||||
(let* ((input (cardinfo-input obj))
|
||||
(output (cardinfo-output obj))
|
||||
(output-exists-p (probe-file output)))
|
||||
(if (or force
|
||||
(not output-exists-p))
|
||||
(trivial-download:download input output)
|
||||
(cardinfo-output-exists-p obj))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun cardinfo-update-and-cleanup (&optional cleanup)
|
||||
(let ((cardinfo-php (make-instance 'cardinfo-php))
|
||||
(cardinfo-json (make-instance 'cardinfo-json))
|
||||
(cardinfo-list (make-instance 'cardinfo-list)))
|
||||
(cardinfo-download cardinfo-php)
|
||||
(cardinfo-convert cardinfo-php cardinfo-json)
|
||||
(cardinfo-convert cardinfo-json cardinfo-list)
|
||||
(when cleanup
|
||||
(mapcar #'cardinfo-cleanup (list cardinfo-php cardinfo-json cardinfo-list)))))
|
||||
472
src/models/ygoprodeck-classes.lisp
Normal file
472
src/models/ygoprodeck-classes.lisp
Normal file
@ -0,0 +1,472 @@
|
||||
#|
|
||||
|
||||
src/models/ygoprodeck-classes.lisp
|
||||
|
||||
Yu-Gi-Oh! Pro Deck Database Interface v2
|
||||
|
||||
TODO Documentation; The diagram from schemacrawler would be nice.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.classes)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This is part of cardsv3 now.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defclass ygo-name-mixin ()
|
||||
((name :accessor name-of
|
||||
:col-type :text
|
||||
:initarg :name))
|
||||
(:unique-keys name)
|
||||
(:documentation "A table for the names of all Yu-Gi-Oh! card properties.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-name (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the names of all Yu-Gi-Oh! card names. Dark Magician, Red-Eyes Black Dragon, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-type (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the types of Yu-Gi-Oh! cards. Spell, Flip Effect Monster, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-frame-type (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the frame types of Yu-Gi-Oh! cards. spell, effect_pendulum, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-race (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the races of Yu-Gi-Oh! cards. Insect, Beast, and so on.
|
||||
|
||||
YGOProDeck stores the kind of spell card here too, like Equip or Continuous.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-archetype (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the archetypes of Yu-Gi-Oh! cards. Archfiend, Elemental HERO, A.I, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-card-attribute (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the attributes of Yu-Gi-Oh! cards. FIRE, WIND, EARTH, DARK, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; YGO-CARD uses the PASSCODE as its UNIQUE ID, so you don't see it in
|
||||
;; here, because it's added implicitly by MITO as ID slot.
|
||||
(defclass ygo-card ()
|
||||
((id :accessor ygo-passcode-of
|
||||
:col-type :integer
|
||||
:primary-key t
|
||||
:initarg :id)
|
||||
(;; Cards *always* have a UNIQUE Name, and a description. Description isn't necessarily unique.
|
||||
name :accessor name-of
|
||||
:col-type :text
|
||||
:initarg :name)
|
||||
(desc :accessor ygo-desc-of
|
||||
:col-type :text
|
||||
:initarg :desc)
|
||||
|
||||
;; Some cards pre-date Archetype (e.g. Normal Monsters)
|
||||
(archetype :accessor ygo-archetype-of
|
||||
:col-type (or ygo-card-archetype :null)
|
||||
:initarg :archetype)
|
||||
;; Some cards don't have Attribute/ATK/DEF/Level/Scale:
|
||||
;; - Skill
|
||||
;; - Spell
|
||||
;; - Trap
|
||||
(attribute :accessor ygo-attribute-of
|
||||
:col-type (or ygo-card-attribute :null)
|
||||
:initarg :attribute)
|
||||
(atk :accessor ygo-atk-of
|
||||
:col-type (or :integer :null)
|
||||
:initarg :atk)
|
||||
(def :accessor ygo-def-of
|
||||
:col-type (or :integer :null)
|
||||
:initarg :def)
|
||||
(scale :accessor ygo-scale-of
|
||||
:col-type (or :integer :null)
|
||||
:initarg :scale)
|
||||
(level :accessor ygo-level-of
|
||||
:col-type (or :integer :null)
|
||||
:initarg :level)
|
||||
|
||||
;; Every card has a Frame-Type and a Race; Even Spell and Trap cards have a Race.
|
||||
;; YGOProDeck uses this field to keep "Continuous", or "Field" ... yuck.
|
||||
(frame-type :accessor ygo-frame-type-of
|
||||
:col-type ygo-card-frame-type
|
||||
:initarg :frame-type)
|
||||
(race :accessor ygo-race-of
|
||||
:col-type ygo-card-race
|
||||
:initarg :race)
|
||||
|
||||
;; There's a conflict with the existing lisp builtin TYPE-OF. Call
|
||||
;; it CARD-TYPE and access with CARD-TYPE-OF.
|
||||
(card-type :accessor ygo-card-type-of
|
||||
:col-type ygo-card-type
|
||||
:initarg :type))
|
||||
(:primary-key id)
|
||||
(:auto-pk nil)
|
||||
(:documentation "A table for most info of Yu-Gi-Oh! cards.
|
||||
|
||||
This corresponds to the top level data for each card in the YGOProDeck API export.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; From here onward, the code depends on YGO-CARD.
|
||||
(defclass ygo-card-misc-info ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode)
|
||||
(views :accessor ygo-views-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :views)
|
||||
(viewsweek :accessor ygo-viewsweek-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :viewsweek)
|
||||
(upvotes :accessor ygo-upvotes-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :upvotes)
|
||||
(downvotes :accessor ygo-downvotes-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :downvotes)
|
||||
(beta-id :accessor ygo-beta-id-of
|
||||
:col-type (or :integer :null)
|
||||
:initarg :beta--id)
|
||||
(beta-name :accessor ygo-beta-name-of
|
||||
:col-type (or ygo-name-mixin :null)
|
||||
:initarg :beta--name)
|
||||
(staple :accessor ygo-is-staple
|
||||
:col-type (or :integer :null)
|
||||
:initarg :staple)
|
||||
(konami-id :accessor ygo-konami-id-of
|
||||
:col-type :integer
|
||||
:initarg :konami--id)
|
||||
;; This :INTEGER is just an index into this table, YGO-CARDS.
|
||||
(treated-as :accessor ygo-treated-as
|
||||
:col-type (or :null ygo-name-mixin)
|
||||
:initarg :treated--as)
|
||||
(has-effect :accessor ygo-has-effect
|
||||
:col-type (or :integer :null)
|
||||
:initarg :has--effect)
|
||||
(question-atk :accessor ygo-question-atk
|
||||
:col-type (or :integer :null)
|
||||
:initarg :question--atk)
|
||||
(question-def :accessor ygo-question-def
|
||||
:col-type (or :integer :null)
|
||||
:initarg :question--def)
|
||||
|
||||
;; When the TCG-DATE or OCG-DATE is NULL, that means it hasn't been released in TCG/OCG...
|
||||
(tcg-date :accessor ygo-tcg-date-of
|
||||
:col-type (or :timestamp :null)
|
||||
:initarg :tcg--date)
|
||||
(ocg-date :accessor ygo-ocg-date-of
|
||||
:col-type (or :timestamp :null)
|
||||
:initarg :ocg--date))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "This corresponds to the \"misc_info\" data for each card in the YGOProDeck API export."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Now Card Set Stuff
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-set-name (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the sets of Yu-Gi-Oh! cards. Lightning Overdrive, 2021 Tin of Ancient Battles, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-set-code (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the set codes of Yu-Gi-Oh! cards. LOB-001, LOB-002, and so on.
|
||||
|
||||
SET-CODE is the full code, e.g. \"LOB-001\".
|
||||
|
||||
CODE is just \"001\" part, SET is just \"LOB\" part, both of which can be accessed by SPLIT-CODE.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;; Rarity => "Common", "Ghost Rare", "Ultra Rare", "Secret Rare"
|
||||
(defclass ygo-set-rarity (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the rarities of Yu-Gi-Oh! cards. Common, Secret Rare, Ghost Rare, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;; jq '.[]?.card_sets[]?.set_rarity_code' < /tmp/cardinfo.json | sort -h | uniq
|
||||
(defclass ygo-set-rarity-code (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the rarity codes of Yu-Gi-Oh! cards. (C), (SR), (GUR), etc.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-set-edition (ygo-name-mixin)
|
||||
()
|
||||
(:documentation "A table for the editions of Yu-Gi-Oh! cards. 1st Edition, Unlimited, and so on.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defclass ygo-set ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode)
|
||||
(name :accessor name-of
|
||||
:col-type ygo-set-name
|
||||
:initarg :name)
|
||||
(code :accessor ygo-code-of
|
||||
:col-type ygo-set-code
|
||||
:initarg :code)
|
||||
(rarity :accessor ygo-rarity-of
|
||||
:col-type ygo-set-rarity
|
||||
:initarg :rarity)
|
||||
(rarity-code :accessor ygo-rarity-code--of
|
||||
:col-type ygo-set-rarity-code
|
||||
:initarg :rarity-code)
|
||||
(edition :accessor ygo-edition-of
|
||||
:col-type ygo-set-edition
|
||||
:initarg :edition)
|
||||
|
||||
(url :accessor ygo-url-of
|
||||
:col-type :text
|
||||
:initarg :url)
|
||||
|
||||
;; PRICE is $X,XX * 100 => XXX,00 That way we don't have to store floats at all.
|
||||
;;
|
||||
;; Default set price is Half a Doll Hair (0.50$) if none supplied
|
||||
(price :accessor ygo-price-of
|
||||
:col-type :integer
|
||||
:initarg :price
|
||||
:initform 0.50
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate))
|
||||
(:documentation "A table for the sets of Yu-Gi-Oh! cards.
|
||||
|
||||
This corresponds to the \"card_sets\" field in the YGOProDeck API export.")
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-linkmarker ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode)
|
||||
(bottom :accessor ygo-linkmarker-bottom
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :bottom)
|
||||
(bottom-left :accessor ygo-linkmarker-bottom-left
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :bottom-left)
|
||||
(bottom-right :accessor ygo-linkmarker-bottom-right
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :bottom-right)
|
||||
(left :accessor ygo-linkmarker-left
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :left)
|
||||
(right :accessor ygo-linkmarker-right
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :right)
|
||||
(top :accessor ygo-linkmarker-top
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :top)
|
||||
(top-left :accessor ygo-linkmarker-top-left
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :top-left)
|
||||
(top-right :accessor ygo-linkmarker-top-right
|
||||
:col-type (or :null ygo-linkmarker-name)
|
||||
:initarg :top-right))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A table for Yu-Gi-Oh! Link Monster Link markers.
|
||||
|
||||
This corresponds to the \"linkmarkers\" field in each card."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-format ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :passcode)
|
||||
(common-charity :accessor ygo-common-charity-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :common-charity)
|
||||
(duel-links :accessor ygo-duel-links-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :duel-links)
|
||||
(edison :accessor ygo-edison-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :edison)
|
||||
(goat :accessor ygo-goat-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :goat)
|
||||
(ocg :accessor ygo-ocg-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :ocg)
|
||||
(ocg-goat :accessor ygo-ocg-goat-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :ocg-goat)
|
||||
(speed-duel :accessor ygo-speed-duel-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :speed-duel)
|
||||
(tcg :accessor ygo-tcg-format
|
||||
:col-type (or :null ygo-format-name)
|
||||
:initarg :tcg))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A table for Yu-Gi-Oh! rule formats.
|
||||
|
||||
This corresponds to the \"formats\" field in the \"misc_info\" for each card.
|
||||
|
||||
If the card is available in this format, e.g. listed under misc_info.formats \"TCG\", that means the card is allowed in TCG games. The YGO-TCG-FORMAT slot for this object would have a non-NIL YGO-FORMAT-NAME value."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-banlist ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode)
|
||||
(ban-goat :accessor ygo-ban-goat
|
||||
:col-type (or :null ygo-banlist-name)
|
||||
:initarg :ban--goat)
|
||||
(ban-ocg :accessor ygo-ban-ocg
|
||||
:col-type (or :null ygo-banlist-name)
|
||||
:initarg :ban--ocg)
|
||||
(ban-tcg :accessor ygo-ban-tcg
|
||||
:col-type (or :null ygo-banlist-name)
|
||||
:initarg :ban--tcg))
|
||||
(:unique-keys passcode)
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A table for Yu-Gi-Oh! rule banlist.
|
||||
|
||||
This corresponds to the \"banlist_info\" field for each card."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-alternative-artwork ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode)
|
||||
(alternate :accessor ygo-alternate-id-of
|
||||
:col-type ygo-card
|
||||
:initarg :alternate))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A table for Yu-Gi-Oh! alternative artwork.
|
||||
|
||||
This corresponds to the \"card_images\" array for each card."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defclass ygo-price ()
|
||||
((passcode :accessor ygo-passcode-of
|
||||
:col-type ygo-card
|
||||
:initarg :passcode
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
(cardmarket-price :accessor ygo-cardmarket-price-of
|
||||
:col-type :integer
|
||||
:initarg :cardmarket--price
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
(tcgplayer-price :accessor ygo-tcgplayer-price-of
|
||||
:col-type :integer
|
||||
:initarg :tcgplayer--price
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
(ebay-price :accessor ygo-ebay-price-of
|
||||
:col-type :integer
|
||||
:initarg :ebay--price
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
(amazon-price :accessor ygo-amazon-price-of
|
||||
:col-type :integer
|
||||
:initarg :amazon--price
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate)
|
||||
(coolstuffinc-price :accessor ygo-coolstuffinc-price-of
|
||||
:col-type :integer
|
||||
:initarg :coolstuffinc--price
|
||||
:deflate #'currency-deflate
|
||||
:inflate #'currency-inflate))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "A table for Yu-Gi-Oh! pricing information. Represents the API information about Card Pricing. Encapsulates the following fields:
|
||||
- Passcode
|
||||
- CardMarket
|
||||
- TCGPlayer
|
||||
- eBay
|
||||
- Amazon
|
||||
- CoolStuffInc
|
||||
|
||||
This corresponds to the \"card_prices\" array for each card."))
|
||||
|
||||
;; YGO-FORMAT-NAME, YGO-LINKMARKER-NAME, YGO-BANLIST-NAME,
|
||||
;; YGO-SET-RARITY-CODE, and the like have moved to YGOPRODECK.FIELDS.
|
||||
|
||||
(defclass ygo-set-item ()
|
||||
((item :accessor item-of
|
||||
:initarg :item
|
||||
:col-type ygo-set)
|
||||
(variant :accessor variant-of
|
||||
:initarg :variant
|
||||
:col-type variant-condition)
|
||||
(qty :accessor qty-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :qty)
|
||||
(opt-qty :accessor opt-qty-of
|
||||
:col-type :integer
|
||||
:initform 0
|
||||
:initarg :opt-qty)
|
||||
(;; 10 cent buy price
|
||||
buy-price :accessor buy-price-of
|
||||
:col-type :integer
|
||||
:initform 0.10
|
||||
:initarg :buy-price
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate)
|
||||
(;; 50 cent sell price
|
||||
sell-price :accessor sell-price-of
|
||||
:col-type :integer
|
||||
:initform 0.50
|
||||
:initarg :sell-price
|
||||
:inflate #'currency-inflate
|
||||
:deflate #'currency-deflate))
|
||||
(:metaclass registered-table-class)
|
||||
(:documentation "YGO-SET + VARIANT-CONDITION relationship table."))
|
||||
|
||||
|
||||
#|
|
||||
;;;; models/ygoprodeck.lisp
|
||||
(defstruct ygoprodeck-item
|
||||
(:documentation "Represents the top level API information queried from YGOProDeck. Encapsulates the following fields: ~Passcode~,~Name~,~Type~, ~Frame Type~, ~Documentation~,~Race~,~ATK~, ~DEF~,~Level~,~Attribute~, and ~Archetype~."))
|
||||
(defstruct ygoprodeck-card-set
|
||||
(:documentation "Represents the API information about Card Sets. Encapsulates the following fields: ~Passcode~,~Name~,~Code~, ~Rarity~, ~Rarity-code~, and ~Price~."))
|
||||
(defstruct ygoprodeck-card-image
|
||||
(:documentation "Card images. We don't use this much."))
|
||||
(defstruct ygoprodeck-card-price
|
||||
(defun drop-table-ygoprodeck-data
|
||||
(:documentation "Destroy the table for this data."))
|
||||
(defun create-table-ygoprodeck-data
|
||||
(:documentation "Create the corresponding database structure for the YGOProDeck API data import."))
|
||||
(defun json-import-ygoprodeck-data
|
||||
(:arguments
|
||||
((data "The data to be imported."))
|
||||
:documentation "Import the base API data (ATK, DEF,Level, ...) information from the Card Info API data."))
|
||||
(defun json-import-ygoprodeck-card-images
|
||||
(:arguments
|
||||
((data "The data to be imported."))
|
||||
:documentation "Import the images information from the Card Info API data."))
|
||||
(defun json-import-ygoprodeck-card-prices
|
||||
(:arguments
|
||||
((data "The data to be imported."))
|
||||
:documentation "Import the pricing information from the Card Info API data."))
|
||||
(defun json-import-ygoprodeck-card-sets
|
||||
(:arguments
|
||||
((data "The data to be imported."))
|
||||
:documentation "Import the card set information from the Card Info API data."))
|
||||
(defun json-import-ygoprodeck-banlist-info
|
||||
(:arguments
|
||||
((data "The data to be imported."))
|
||||
:documentation "Import the banlist information from the Card Info API data."))
|
||||
(defun json-import-ygoprodeck
|
||||
(:arguments
|
||||
((json "The JSON query to iterate over. Response from YGOProDeck API."))
|
||||
:documentation "Import YGOProDeck data. Wraps the ~JSON-IMPORT-*~ functions."))
|
||||
(defun card-rarity-list
|
||||
(:documentation "List all card rarities."))
|
||||
(defun card-code-list
|
||||
(:documentation "List all card set codes."))
|
||||
|
||||
|#
|
||||
62
src/models/ygoprodeck-fields.lisp
Normal file
62
src/models/ygoprodeck-fields.lisp
Normal file
@ -0,0 +1,62 @@
|
||||
#|
|
||||
|
||||
If you wanted to add an item, you would add to the end of the list
|
||||
or the matching position in the list to the matching DEFPARAMETER
|
||||
and DEFCLASS.
|
||||
|
||||
These are all extracted from cardinfo.php
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.fields)
|
||||
|
||||
;; TODO Merge this with YGO-CARD-NAME? What is even going on
|
||||
;; here. This could be mixed with any DAO/table with a NAME
|
||||
;; column. That *feels* like it's a lot more general than I
|
||||
;; realize....
|
||||
(defclass variant ()
|
||||
((name :col-type :text
|
||||
:initarg :name))
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
(defmethod name-of ((obj variant))
|
||||
(slot-value obj 'name))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun create-variant (class variant)
|
||||
(or (mito:find-dao class :name variant)
|
||||
(mito:create-dao class :name variant)))
|
||||
|
||||
(defun create-variants (class &rest variants)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (v variants)
|
||||
(create-variant class v)))))
|
||||
|
||||
(defmacro define-variant-list (name &rest lst)
|
||||
`(progn
|
||||
(defclass ,name (variant)
|
||||
()
|
||||
(:metaclass registered-table-class))
|
||||
(create-table ',name)
|
||||
(create-variants (find-class ',name) ,@lst)))
|
||||
|
||||
;; Card Conditions
|
||||
(define-variant-list variant-condition
|
||||
"Near Mint" "Lightly Played" "Moderately Played" "Heavily Played" "Damaged")
|
||||
|
||||
;; Languages
|
||||
(define-variant-list variant-language
|
||||
"English" "French" "Italian" "Spanish" "German" "Portuguese")
|
||||
|
||||
;; Ban List Info
|
||||
(define-variant-list ygo-banlist-name
|
||||
"Unlimited" "Semi-Limited" "Limited" "Banned")
|
||||
|
||||
;; Formats
|
||||
(define-variant-list ygo-format-name
|
||||
"Common Charity" "Duel Links" "Edison" "GOAT" "OCG" "OCG GOAT" "Speed Duel" "TCG")
|
||||
|
||||
;; Link Markers
|
||||
(define-variant-list ygo-linkmarker-name
|
||||
"Top" "Top-Right" "Right" "Bottom-Right" "Bottom" "Bottom-Left" "Left" "Top-Left")
|
||||
477
src/models/ygoprodeck-json.lisp
Normal file
477
src/models/ygoprodeck-json.lisp
Normal file
@ -0,0 +1,477 @@
|
||||
#|
|
||||
|
||||
src/models/ygoprodeck.json.lisp
|
||||
|
||||
Version 3 JSON Importer
|
||||
|
||||
TODO Write a test suite - it should be easier now that it's in FNF
|
||||
|
||||
The idea behind this code is you'll be able to one click button download and update the db.
|
||||
|
||||
(cl-deck-builder2.models.ygoprodeck.json2::json-import-cardinfo #P"/tmp/cardinfo.json")
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.json)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defvar *json* nil
|
||||
"The currently loaded CARDINFO data pulled from YGOProDeck API.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod cardinfo-import ((obj cardinfo) &optional force)
|
||||
"Set *JSON* to the decoded JSON data from CARDINFO, by processing it into CARDINFO-JSON using CARDINFO-CONVERT.
|
||||
|
||||
Optionally, FORCE the data to be loaded anyway.
|
||||
|
||||
If the (CARDINFO-OUTPUT OBJ) does not exist, try to (CARDINFO-INPUT *CARDINFO*)."
|
||||
(cardinfo-load obj force)
|
||||
(process-all-nodes))
|
||||
|
||||
(defmethod cardinfo-load ((obj cardinfo) &optional force)
|
||||
(let ((output (cardinfo-output obj)))
|
||||
(v:info :ygoprodeck.json "CARDINFO-LOAD ~a (exists:~a) (force:~a)" output (cardinfo-output-exists-p obj) force)
|
||||
(if (cardinfo-output-exists-p obj)
|
||||
(progn
|
||||
(setf *json* (with-open-file (f output)
|
||||
(cl-json:decode-json f)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun json-cardinfo-base-fields (plist)
|
||||
"Filter only the base fields for this CARD-INFO PLIST."
|
||||
(set-difference plist
|
||||
'((:banlist--info)
|
||||
(:card--images)
|
||||
(:card--prices)
|
||||
(:card--sets)
|
||||
(:linkmarkers)
|
||||
(:misc--info))
|
||||
:key #'car))
|
||||
|
||||
;; (defparameter +ygo-card-ids+ (make-hash-table :test #'equal))
|
||||
;; (defparameter +ygo-card-descs+ (make-hash-table :test #'equal))
|
||||
|
||||
;; TODO put all of these hash tables inside another hash table, then
|
||||
;; make an API around it. I've seen that done before with CLOS, maybe
|
||||
;; in cl-opengl defvao stuff. Remember?
|
||||
(defparameter +ygo-card-names+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-card-types+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-card-races+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-card-frame-types+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-card-archetypes+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-card-attributes+ (make-hash-table :test #'equal))
|
||||
|
||||
(defparameter +ygo-set-names+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-set-codes+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-set-rarity+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-set-editions+ (make-hash-table :test #'equal))
|
||||
|
||||
;; Here we use the ID/PASSCODE so EQ is Okay
|
||||
(defparameter +ygo-card-prices+ (make-hash-table)) ;; One to one: setf place
|
||||
(defparameter +ygo-alternative-artwork+ (make-hash-table)) ;; Many to many: push place
|
||||
|
||||
(defparameter +ygo-cards+ (make-hash-table)) ;; One to one: setf place
|
||||
(defparameter +ygo-sets+ (make-hash-table)) ;; Many to many: push place
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Field Names
|
||||
(defparameter +ygo-banlist-info+ (make-hash-table))
|
||||
(defparameter +ygo-format-info+ (make-hash-table))
|
||||
(defparameter +ygo-linkmarker-info+ (make-hash-table))
|
||||
|
||||
(defparameter +ygo-banlist-names+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-format-names+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-linkmarker-names+ (make-hash-table :test #'equal))
|
||||
(defparameter +ygo-set-rarity-codes+ (make-hash-table :test #'equal))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; The bulk of the operation ... FIND-OR-MAKE-INSTANCE + SYNC-HASH-TABLE
|
||||
(defun sync-hash-table (ht)
|
||||
(let ((values (alexandria:hash-table-values ht)))
|
||||
(cond ((null values) nil)
|
||||
(;; The ht is a bunch of lists (card sets, prices, images)
|
||||
(listp (car values))
|
||||
(dolist (lst values)
|
||||
(unless (mito:dao-synced (car lst))
|
||||
(do-grouped-insert lst))))
|
||||
(t
|
||||
(unless (mito:dao-synced (car values))
|
||||
(do-grouped-insert values))))))
|
||||
|
||||
;; TODO Where should this go? I'm seeing bits of code like this all over.
|
||||
(defun %keywordify (s)
|
||||
(alexandria:make-keyword
|
||||
(string-upcase
|
||||
(substitute #\- #\Space s))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Importer v3
|
||||
(defun extract-json-tag (json tag)
|
||||
"Get all the tags from JSON matching TAG."
|
||||
(mapcar (lambda (alist) (assoc-utils:aget alist tag)) json))
|
||||
|
||||
(defun extract-concat (json tag)
|
||||
"Concatenate the results of EXTRACT-JSON-TAG into a single list for MAPCAR'ing."
|
||||
(apply #'concatenate 'list (extract-json-tag json tag)))
|
||||
|
||||
(defun extract-card-sets (json)
|
||||
"Just extract :CARD--SETS. No Processing"
|
||||
(extract-concat json :card--sets))
|
||||
|
||||
(defun extract-card-set-map (json)
|
||||
"Extract PASSCODE => SETS mapping."
|
||||
(let ((lst '()))
|
||||
(dolist (node json (copy-alist
|
||||
(apply #'concatenate 'list (reverse lst))))
|
||||
(let* ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-card-sets
|
||||
(mapcar (lambda (alist)
|
||||
(acons :passcode-id node-id alist))
|
||||
(assoc-utils:aget node :card--sets))))
|
||||
(when maybe-card-sets
|
||||
(push maybe-card-sets lst))))))
|
||||
|
||||
(defun extract-card-images (json)
|
||||
"Just extract :CARD--IMAGES. No Processing"
|
||||
(extract-concat json :card--images))
|
||||
|
||||
(defun extract-card-alternative-images-map (json)
|
||||
"Mapping of ID to alternative art IDs."
|
||||
(let ((lst '()))
|
||||
(dolist (node json (reverse lst))
|
||||
(let* ((alternate-id (assoc-utils:aget node :id))
|
||||
(maybe-alternative-images
|
||||
(remove alternate-id
|
||||
(mapcar (lambda (alist)
|
||||
(assoc-utils:aget alist :id))
|
||||
(assoc-utils:aget node :card--images)))))
|
||||
(when maybe-alternative-images
|
||||
(mapcar (lambda (node-id)
|
||||
(push (list :passcode-id node-id
|
||||
:alternate-id alternate-id)
|
||||
lst))
|
||||
maybe-alternative-images))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Working with the base fields
|
||||
(defun extract-card-tag (json tag)
|
||||
"Extract TAG from JSON using EXTRACT-JSON-TAG. Also, SORT, and SUBSTITUTE NIL for \"\"."
|
||||
(sort
|
||||
(substitute "" NIL
|
||||
(remove-duplicates
|
||||
(extract-json-tag json tag)
|
||||
:test #'string=))
|
||||
#'string<))
|
||||
|
||||
(defun extract-card-name (json)
|
||||
(extract-card-tag json :name))
|
||||
|
||||
(defun extract-card-type (json)
|
||||
(extract-card-tag json :type))
|
||||
|
||||
(defun extract-card-race (json)
|
||||
(extract-card-tag json :race))
|
||||
|
||||
(defun extract-card-frame-type (json)
|
||||
(extract-card-tag json :frame-type))
|
||||
|
||||
(defun extract-card-archetype (json)
|
||||
(extract-card-tag json :archetype))
|
||||
|
||||
(defun extract-card-attribute (json)
|
||||
(extract-card-tag json :attribute))
|
||||
|
||||
(defun extract-cards (json)
|
||||
"Just extract the base field for every card."
|
||||
(mapcar #'json-cardinfo-base-fields json))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun extract-card-banlist-info (json)
|
||||
"Lots of cards don't have banlist info records."
|
||||
(let ((lst '()))
|
||||
(dolist (node json (copy-list lst))
|
||||
(let ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-banlist-info
|
||||
(assoc-utils:alist-plist
|
||||
(assoc-utils:aget node :banlist--info))))
|
||||
(when maybe-banlist-info
|
||||
(push (append (list :passcode-id node-id)
|
||||
maybe-banlist-info)
|
||||
lst))))))
|
||||
|
||||
(defun extract-card-banlist-names (json)
|
||||
"Just extract the names of the ban status. \"Banned\" etc."
|
||||
(let ((lst '()))
|
||||
(dolist (node json (copy-list lst))
|
||||
(let ((maybe-banlist-names
|
||||
(assoc-utils:alist-values
|
||||
(assoc-utils:aget node :banlist--info))))
|
||||
(when maybe-banlist-names
|
||||
(loop for name in maybe-banlist-names do
|
||||
(pushnew name lst :test #'string=)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun extract-card-prices (json)
|
||||
(extract-json-tag json :card--prices))
|
||||
|
||||
(defun extract-card-price-map (json)
|
||||
"Extract :CARD--PRICE and process into ID => PRICES mapping"
|
||||
(let ((lst '()))
|
||||
(dolist (node json lst)
|
||||
(let ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-price-data
|
||||
(assoc-utils:alist-plist
|
||||
(apply #'concatenate 'list
|
||||
(assoc-utils:aget node :card--prices)))))
|
||||
(when maybe-price-data
|
||||
(push (append (list :passcode-id node-id)
|
||||
maybe-price-data)
|
||||
lst))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun extract-card-misc-info (json)
|
||||
(extract-json-tag json :misc--info))
|
||||
|
||||
(defun extract-card-misc-info-map (json)
|
||||
"Extract :MISC--INFO and process into ID => FORMATS mapping"
|
||||
(let ((lst '()))
|
||||
(dolist (node json lst)
|
||||
(let* ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-misc-info
|
||||
(assoc-utils:alist-plist
|
||||
(remove :formats
|
||||
(apply #'concatenate 'list
|
||||
(assoc-utils:aget node :misc--info))
|
||||
:key #'car))))
|
||||
(when maybe-misc-info
|
||||
(push (append (list :passcode-id node-id)
|
||||
maybe-misc-info)
|
||||
lst))))))
|
||||
|
||||
;; TODO
|
||||
(defun extract-card-format-info (json)
|
||||
"Extract :MISC--INFO and process into ID => FORMATS mapping"
|
||||
(let ((lst '()))
|
||||
(dolist (node json lst)
|
||||
(let* ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-misc-info
|
||||
(assoc-utils:aget
|
||||
(apply #'concatenate 'list
|
||||
(assoc-utils:aget node :misc--info))
|
||||
:formats)))
|
||||
(when maybe-misc-info
|
||||
(push (list node-id maybe-misc-info) lst))))))
|
||||
|
||||
;; TODO - The card formats need to be processed like the card-sets and cards
|
||||
(defun process-card-format-info-map (json)
|
||||
(let ((info (extract-card-format-info json)))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcar (lambda (row)
|
||||
(list :passcode-id (car row)
|
||||
(apply #'concatenate 'list
|
||||
(mapcar (lambda (tag)
|
||||
(let ((db-tag (or (find-or-create-instance 'ygo-format-name :name tag))))
|
||||
(list (%keywordify tag) db-tag)))
|
||||
(cadr row)))))
|
||||
info)))))
|
||||
|
||||
(defun extract-card-format-names (json)
|
||||
(sort
|
||||
(remove-duplicates
|
||||
(apply #'concatenate 'list
|
||||
(mapcar (lambda (alist) (assoc-utils:aget alist :formats))
|
||||
(apply #'concatenate 'list
|
||||
(extract-card-misc-info json))))
|
||||
:test #'string=)
|
||||
#'string<))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun extract-card-linkmarker-names (json)
|
||||
(sort (remove-duplicates
|
||||
(extract-concat json :linkmarkers)
|
||||
:test #'string=)
|
||||
#'string<))
|
||||
|
||||
;; TODO
|
||||
(defun extract-card-linkmarker-info (json)
|
||||
"Just extract :CARD--IMAGES. No Processing"
|
||||
(let ((lst '()))
|
||||
(dolist (node json lst)
|
||||
(let ((node-id (assoc-utils:aget node :id))
|
||||
(maybe-linkmarkers
|
||||
(assoc-utils:aget node :linkmarkers)))
|
||||
(when maybe-linkmarkers
|
||||
(push (list node-id maybe-linkmarkers) lst))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Working with CARD--SETS
|
||||
|
||||
;; Here, JSON shuld be: (extract-card-sets json)
|
||||
(defun extract-set-tag (json tag)
|
||||
(sort (remove-duplicates
|
||||
(extract-json-tag json tag)
|
||||
:test #'string=)
|
||||
#'string<))
|
||||
|
||||
(defun extract-set-name (json)
|
||||
(extract-set-tag json :set--name))
|
||||
|
||||
(defun extract-set-code (json)
|
||||
(extract-set-tag json :set--code))
|
||||
|
||||
(defun extract-set-rarity (json)
|
||||
(extract-set-tag json :set--rarity))
|
||||
|
||||
(defun extract-set-rarity-code (json)
|
||||
(extract-set-tag json :set--rarity--code))
|
||||
|
||||
(defun extract-set-edition (json)
|
||||
(extract-set-tag json :set--edition))
|
||||
|
||||
(defun extract-set-price (json)
|
||||
(extract-set-tag json :set--price))
|
||||
|
||||
(defun extract-set-url (json)
|
||||
(extract-set-tag json :set--url))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Card Images
|
||||
(defun extract-card-main-image (json)
|
||||
"From :CARD--IMAGES, extract the first IMAGE--URL. The other two are small and cropped images."
|
||||
(sort
|
||||
(mapcar (lambda (alist) (assoc-utils:aget alist :image--url))
|
||||
(extract-concat json :card--images))
|
||||
#'string<))
|
||||
|
||||
(defun gen-hash-table (ht class tags)
|
||||
"Just a list mapping like \"Normal\" => 1, \"Tested\" => 2, and so on. Could be used for anything that has a NAME column."
|
||||
(v:info :ygoprodeck.json "GEN-HASH-TABLE: ~a" class)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (tag tags ht)
|
||||
(unless (gethash tag ht)
|
||||
(setf (gethash tag ht)
|
||||
(or (mito:find-dao class :name tag)
|
||||
(mito:create-dao class :name tag))))))))
|
||||
|
||||
(defun gen-hash-mapping-table (class tags &key (test 'equal))
|
||||
"A more complex mapping of PASSCODE -> DATA"
|
||||
(let ((ht (make-hash-table :test test)))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (node tags ht)
|
||||
(let ((passcode-id (getf node :passcode-id)))
|
||||
(setf (gethash passcode-id ht)
|
||||
(or (mito:find-dao class :passcode-id passcode-id)
|
||||
(apply #'mito:create-dao class node)))))))))
|
||||
|
||||
(defun gen-hash-map-list-table (class tags &key (test 'equal))
|
||||
"A more complex mapping of PASSCODE -> (DATA, DATA, DATA)"
|
||||
(let ((ht (make-hash-table :test test)))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (node tags ht)
|
||||
(let ((passcode-id (getf node :passcode-id)))
|
||||
(push (or (apply #'mito:find-dao class node)
|
||||
(apply #'mito:create-dao class node))
|
||||
(gethash passcode-id ht))))))))
|
||||
|
||||
(defun process-card-nodes (json)
|
||||
"Mostly preserved from V2."
|
||||
(let* ((base-fields (json-cardinfo-base-fields json))
|
||||
(id (assoc-utils:aget base-fields :id))
|
||||
(args (list
|
||||
:name (assoc-utils:aget base-fields :name)
|
||||
:desc (assoc-utils:aget base-fields :desc)
|
||||
:archetype (gethash (assoc-utils:aget base-fields :archetype) +ygo-card-archetypes+)
|
||||
:attribute (gethash (assoc-utils:aget base-fields :attribute) +ygo-card-attributes+)
|
||||
:frame-type (gethash (assoc-utils:aget base-fields :frame-type) +ygo-card-frame-types+)
|
||||
:race (gethash (assoc-utils:aget base-fields :race) +ygo-card-races+)
|
||||
:card-type (gethash (assoc-utils:aget base-fields :type) +ygo-card-types+)
|
||||
:atk (assoc-utils:aget base-fields :atk)
|
||||
:def (assoc-utils:aget base-fields :def)
|
||||
:scale (assoc-utils:aget base-fields :scale)
|
||||
:level (assoc-utils:aget base-fields :level)))
|
||||
(found (or (mito:find-dao 'ygo-card :id id)
|
||||
(apply #'create-dao 'ygo-card :id id args))))
|
||||
(unless (gethash id +ygo-cards+)
|
||||
(setf (gethash id +ygo-cards+) found))))
|
||||
|
||||
(defun process-card-sets (&rest sets)
|
||||
"Mostly preserved from V2."
|
||||
(dolist (node sets +ygo-sets+)
|
||||
(let* ((args
|
||||
(list :passcode-id (assoc-utils:aget node :passcode-id)
|
||||
:code (gethash (assoc-utils:aget node :set--code) +ygo-set-codes+)
|
||||
:name (gethash (assoc-utils:aget node :set--name) +ygo-set-names+)
|
||||
:edition (gethash (assoc-utils:aget node :set--edition) +ygo-set-editions+)
|
||||
:rarity (gethash (assoc-utils:aget node :set--rarity) +ygo-set-rarity+)
|
||||
:rarity-code (gethash (assoc-utils:aget node :set--rarity--code) +ygo-set-rarity-codes+)))
|
||||
(rest-args
|
||||
(list :price (assoc-utils:aget node :set--price)
|
||||
:url (assoc-utils:aget node :set--url)))
|
||||
(found (or (apply #'mito:find-dao 'ygo-set args)
|
||||
(apply #'mito:create-dao 'ygo-set (append args rest-args)))))
|
||||
(pushnew found
|
||||
(gethash (assoc-utils:aget node :passcode-id) +ygo-sets+)
|
||||
:test #'mito:object=))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO for Import-v4 - It might be useful to have PASSCODE as the ID,
|
||||
;; that way, there is a uniform interface for querying card info...
|
||||
;;
|
||||
;; TODO Split this up?
|
||||
(defun pre-process-nodes (json)
|
||||
(let ((card-names (extract-card-name json))
|
||||
(card-types (extract-card-type json))
|
||||
(card-races (extract-card-race json))
|
||||
(card-frame-types (extract-card-frame-type json))
|
||||
(card-archetypes (extract-card-archetype json))
|
||||
(card-attributes (extract-card-attribute json))
|
||||
(card-sets (extract-card-sets json)))
|
||||
|
||||
(gen-hash-table +ygo-card-names+ 'ygo-card-name card-names)
|
||||
(gen-hash-table +ygo-card-archetypes+ 'ygo-card-archetype card-archetypes)
|
||||
(gen-hash-table +ygo-card-attributes+ 'ygo-card-attribute card-attributes)
|
||||
(gen-hash-table +ygo-card-frame-types+ 'ygo-card-frame-type card-frame-types)
|
||||
(gen-hash-table +ygo-card-races+ 'ygo-card-race card-races)
|
||||
(gen-hash-table +ygo-card-types+ 'ygo-card-type card-types)
|
||||
|
||||
(gen-hash-table +ygo-set-names+ 'ygo-set-name (extract-set-name card-sets))
|
||||
(gen-hash-table +ygo-set-codes+ 'ygo-set-code (extract-set-code card-sets))
|
||||
(gen-hash-table +ygo-set-rarity+ 'ygo-set-rarity (extract-set-rarity card-sets))
|
||||
(gen-hash-table +ygo-set-editions+ 'ygo-set-edition (extract-set-edition card-sets))
|
||||
(gen-hash-table +ygo-set-rarity-codes+ 'ygo-set-rarity-code (extract-set-rarity-code card-sets))
|
||||
|
||||
(gen-hash-table +ygo-banlist-names+ 'ygo-banlist-name (extract-card-banlist-info card-sets))
|
||||
(gen-hash-table +ygo-linkmarker-names+ 'ygo-linkmarker-name (extract-card-linkmarker-names card-sets))
|
||||
(gen-hash-table +ygo-format-names+ 'ygo-format-name (extract-card-format-names json))))
|
||||
|
||||
(defun pre-process-card-prices (json)
|
||||
(setf +ygo-card-prices+ (gen-hash-mapping-table 'ygo-price (extract-card-price-map json) :test 'eq)))
|
||||
|
||||
(defun pre-process-card-alternative-artwork (json)
|
||||
(setf +ygo-alternative-artwork+ (gen-hash-map-list-table 'ygo-alternative-artwork (extract-card-alternative-images-map json) :test 'eq)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun process-all-nodes (&optional (json *json*))
|
||||
"Process all nodes from JSON."
|
||||
(v:info :ygoprodeck.json "PROCESS-ALL-NODES: PRE-PROCESS-NODES")
|
||||
(pre-process-nodes json)
|
||||
(pre-process-card-prices json)
|
||||
(pre-process-card-alternative-artwork json)
|
||||
|
||||
;; +ygo-cards+
|
||||
(v:info :ygoprodeck.json "PROCESS-ALL-NODES: PROCESS-CARD-NODES")
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mapcan #'process-card-nodes json)))
|
||||
|
||||
;; +ygo-sets+
|
||||
(v:info :ygoprodeck.json "PROCESS-ALL-NODES: PROCESS-CARD-SETS")
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(apply #'process-card-sets (extract-card-set-map json)))))
|
||||
258
src/models/ygoprodeck-methods.lisp
Normal file
258
src/models/ygoprodeck-methods.lisp
Normal file
@ -0,0 +1,258 @@
|
||||
#|
|
||||
|
||||
src/models/ygoprodeck-2.lisp
|
||||
|
||||
Yu-Gi-Oh! Pro Deck Database Interface v2
|
||||
|
||||
TODO Documentation
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck.methods)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmacro ygo-card (&body body)
|
||||
`(with-includes
|
||||
'ygo-card
|
||||
(mito:includes
|
||||
'ygo-card-archetype
|
||||
'ygo-card-attribute
|
||||
'ygo-card-frame-type
|
||||
'ygo-card-race
|
||||
'ygo-card-type)
|
||||
,@body))
|
||||
|
||||
(defmacro ygo-set (&body body)
|
||||
`(with-includes 'ygo-set
|
||||
(mito:includes
|
||||
'ygo-card
|
||||
'ygo-set-code
|
||||
'ygo-set-edition
|
||||
'ygo-set-name
|
||||
'ygo-set-rarity
|
||||
'ygo-set-rarity-code)
|
||||
;; (mito:includes
|
||||
;; 'ygo-card-name)
|
||||
,@body))
|
||||
|
||||
(defun ygo-set-by-id (id)
|
||||
(first (ygo-set (sxql:where (:= :id id)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defmethod split-code ((set-code ygo-set-code))
|
||||
(cl-ppcre:split "-" (name-of set-code)))
|
||||
|
||||
(defmethod ygo-card-sets ((obj ygo-card))
|
||||
(ygo-card-sets (ygo-passcode-of obj)))
|
||||
|
||||
(defmethod ygo-card-sets ((passcode integer))
|
||||
;; If alternate IDs exist, just mush them in
|
||||
(let ((alt-id (has-alternative-artwork passcode)))
|
||||
(when alt-id
|
||||
;; XXX Why the long accessor name here? How can we get this accessor? Maybe I have to specify it manually.
|
||||
(with-slots ((alternate-id cl-deck-builder2.models.ygoprodeck.classes::alternate-id)) alt-id
|
||||
(setf passcode alternate-id)))
|
||||
(let ((sets
|
||||
(ygo-set
|
||||
;; (sxql:left-join :ygo_card_name :on (:= :ygo-card.name-id :ygo-card-name.id))
|
||||
(sxql:where (:= :passcode-id passcode))
|
||||
(sxql:order-by :price :desc))))
|
||||
sets)))
|
||||
|
||||
;; Only showing cards with inventory
|
||||
|
||||
;; (with-connection (db)
|
||||
;; (mito:select-dao 'cl-deck-builder2.models.ygoprodeck.classes::ygo-set-item
|
||||
;; (sxql:where (:and (:in :item_id
|
||||
;; (sxql:select :id
|
||||
;; (sxql:from :ygo_set)
|
||||
;; (sxql:where (:= :passcode-id 89631139))))
|
||||
;; (:> :qty 0)))))
|
||||
|
||||
;; (mapcar (alexandria:compose #'cl-deck-builder2.models.ygoprodeck2::ygo-card-sets #'deck-passcode-of)
|
||||
;; (retrieve-dao 'deck-item :deck-id 5))
|
||||
|
||||
;; (reduce #'+ (mapcar (alexandria:compose #'read-from-string #'cl-deck-builder2.models.ygoprodeck2::ygo-price-of)
|
||||
;; (cl-deck-builder2.models.ygoprodeck2::ygo-card-sets (deck-passcode-of (find-dao 'deck-item)))))
|
||||
|
||||
;; price of a deck by id using #'first of the ygo-card-sets
|
||||
;;
|
||||
;; (reduce '+ (mapcar (alexandria:compose #'read-from-string #'cl-deck-builder2.models.ygoprodeck.classes::ygo-price-of)
|
||||
;; (mapcar #'first
|
||||
;; (mapcar (alexandria:compose #'cl-deck-builder2.models.ygoprodeck.methods::ygo-card-sets #'deck-passcode-of)
|
||||
;; (retrieve-dao 'deck-item :deck-id 308)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun ygo-card-by-name (name &optional (test :=))
|
||||
(let ((clauses (case test
|
||||
(:= (sxql:where (:= :name name)))
|
||||
(:like (sxql:where (:like :name (format nil "%~a%" name)))))))
|
||||
(ygo-card clauses)))
|
||||
|
||||
(defun ygo-card-by-passcode (passcode)
|
||||
(first (ygo-card (sxql:where (:= :id passcode)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun ygo-set-by-code (name &optional (test :=))
|
||||
(let ((clauses (case test
|
||||
(:= (sxql:where (:= :name name)))
|
||||
(:like (sxql:where (:like :name (format nil "%~a%" name)))))))
|
||||
(ygo-set
|
||||
(sxql:where (:in :code-id
|
||||
(sxql:select :id
|
||||
(sxql:from (sxql:make-sql-symbol
|
||||
(mito.class.table:table-name
|
||||
(find-class 'ygo-set-code))))
|
||||
clauses))))))
|
||||
|
||||
(defun ygo-set-by-name (name &optional (test :=))
|
||||
(let ((clauses (case test
|
||||
(:= (sxql:where (:= :set_name name)))
|
||||
(:like (sxql:where (:like :set_name (format nil "%~a%" name)))))))
|
||||
(ygo-set
|
||||
(sxql:where (:in :code-id
|
||||
(sxql:select :id
|
||||
(sxql:from (sxql:make-sql-symbol
|
||||
(mito.class.table:table-name
|
||||
(find-class 'ygo-set-name))))
|
||||
clauses))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun ygo-select-set-item (item-id variant-id)
|
||||
"Helper function. Select a single YGO-SET-ITEM by ITEM-ID and VARIANT-ID."
|
||||
(mito:select-dao 'ygo-set-item
|
||||
(mito:includes 'ygo-set 'variant-condition)
|
||||
(sxql:where (:and (:= :item-id item-id)
|
||||
(:= :variant-id variant-id)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; https://lispcookbook.github.io/cl-cookbook/clos.html#pretty-printing
|
||||
;;
|
||||
;; (defmethod print-object ((obj person) stream)
|
||||
;; (print-unreadable-object (obj stream :type t)
|
||||
;; (with-accessors ((name name)
|
||||
;; (lisper lisper))
|
||||
;; obj
|
||||
;; (format stream "~a, lisper: ~a" name lisper))))
|
||||
;;
|
||||
;; (defmethod print-object ((obj person) stream)
|
||||
;; (print-unreadable-object (obj stream :type t)
|
||||
;; (format stream "~a, lisper: ~a" (name obj) (lisper obj))))
|
||||
;;
|
||||
;; (defmethod print-object ((obj person) stream)
|
||||
;; (print-unreadable-object (obj stream :type t :identity t)))
|
||||
;;
|
||||
;; Caution: trying to access a slot that is not bound by default will lead to an error. Use slot-boundp.
|
||||
|
||||
(defmethod print-object ((obj ygo-card) stream)
|
||||
(print-unreadable-object (obj stream :type t)
|
||||
(let ((args))
|
||||
(when (ygo-passcode-of obj)
|
||||
(push (ygo-passcode-of obj) args))
|
||||
(ignore-errors
|
||||
(with-accessors ((name name-of))
|
||||
obj
|
||||
(when (and (slot-boundp obj 'name)
|
||||
(slot-value obj 'name))
|
||||
(push (name-of name) args))))
|
||||
(when args
|
||||
(format stream "~{~a~^ - ~}" (reverse args))))))
|
||||
|
||||
(defmethod print-object ((obj ygo-set) stream)
|
||||
(print-unreadable-object (obj stream :type t)
|
||||
(let ((args))
|
||||
(when (mito:object-id obj)
|
||||
(push (mito:object-id obj) args))
|
||||
(ignore-errors
|
||||
(with-accessors ((passcode ygo-passcode-of)
|
||||
(name name-of)
|
||||
(code ygo-code-of)
|
||||
(rarity ygo-rarity-of)
|
||||
(edition ygo-edition-of))
|
||||
obj
|
||||
(when (and (slot-boundp obj 'passcode)
|
||||
(slot-value obj 'passcode))
|
||||
(push (ygo-passcode-of passcode) args))
|
||||
(when (and (slot-boundp obj 'code)
|
||||
(slot-value obj 'code))
|
||||
(push (ygo-set-code-of code) args))
|
||||
(when (and (slot-boundp obj 'rarity)
|
||||
(slot-value obj 'rarity))
|
||||
(push (ygo-rarity-of rarity) args))
|
||||
(when (and (slot-boundp obj 'edition)
|
||||
(slot-value obj 'edition))
|
||||
(push (ygo-edition-of edition) args))
|
||||
(when (and (slot-boundp obj 'name)
|
||||
(slot-value obj 'name))
|
||||
(push (name-of name) args))))
|
||||
(when args
|
||||
(format stream "~{~a~^ - ~}" (reverse args))))))
|
||||
|
||||
(defun ygo-card-names-from-list (&rest args)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:retrieve-by-sql
|
||||
(sxql:select (:ygo_card.id :name)
|
||||
(sxql:from :ygo_card)
|
||||
(sxql:left-join :ygo_card_name :on (:= :ygo_card.name_id :ygo_card_name.id))
|
||||
(sxql:where (:in :ygo_card_name.id
|
||||
(sxql:select :name_id
|
||||
(sxql:from :ygo_card)
|
||||
(sxql:where (:in :id args))))))))))
|
||||
|
||||
(defun ygo-card-names-by-deck-id (id)
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:retrieve-by-sql
|
||||
(sxql:select (:ygo_card.id :name)
|
||||
(sxql:from :ygo_card)
|
||||
(sxql:left-join :ygo_card_name :on (:= :ygo_card.name_id :ygo_card_name.id))
|
||||
(sxql:where (:in :ygo_card_name.id
|
||||
(sxql:select :name_id
|
||||
(sxql:from :ygo_card)
|
||||
(sxql:where (:in :id
|
||||
(sxql:select :passcode
|
||||
(sxql:from :deck_item)
|
||||
(sxql:where (:= :deck_id id)))))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun count-all-dao ()
|
||||
(let ((class-list (append (registered-classes (registry) :cl-deck-builder2.models.ygoprodeck.fields)
|
||||
(registered-classes (registry) :cl-deck-builder2.models.ygoprodeck.classes)))
|
||||
(lst '()))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (class class-list lst)
|
||||
(push (list class (mito:count-dao class)) lst))))))
|
||||
|
||||
;; If you have altnerative artwork and you are the main card, youll get a list with length > 1
|
||||
;; If you have alternative artwork and you are an alternative artwork card, you'll get the main list with length 1
|
||||
(defmethod has-alternative-artwork ((id integer))
|
||||
(find-dao 'ygo-alternative-artwork :passcode-id id))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; So in the CSV importer I had a function PRE-SEED-DB-ITEMS that
|
||||
;; would copy CC-ITEM x5 VARIANT-CONDITION to seed something like 250k
|
||||
;; items in the db. We're just going to duplicate the logic here.
|
||||
;;
|
||||
;; INPUT: (select-dao 'ygo-set)
|
||||
(defun pre-seed-db-items (ygo-sets)
|
||||
(let ((variants (select-dao 'variant-condition)))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (itm ygo-sets)
|
||||
(dolist (variant variants)
|
||||
(mito:create-dao 'ygo-set-item :item-id (mito:object-id itm)
|
||||
:variant-id (mito:object-id variant))))
|
||||
(mito:count-dao 'ygo-set-item)))))
|
||||
|
||||
(defun set-ygo-set-item-qty (amt)
|
||||
"Helper function. Set the QTY of every YGO-SET-ITEM to AMT."
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(mito:execute-sql
|
||||
(sxql:update (sxql:make-sql-symbol
|
||||
(mito.class.table:table-name
|
||||
(find-class 'ygo-set-item)))
|
||||
(sxql:set= :qty amt))))))
|
||||
38
src/models/ygoprodeck.lisp
Normal file
38
src/models/ygoprodeck.lisp
Normal file
@ -0,0 +1,38 @@
|
||||
#|
|
||||
|
||||
src/models/ygoprodeck.lisp
|
||||
|
||||
Yu-Gi-Oh! Pro Deck JSON Importer v1
|
||||
|
||||
Looks like this is old/outdated code and due to be deleted soon!
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.models.ygoprodeck)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; These models correspond to the YGOProDeck JSON dump. API Guide:
|
||||
;; https://ygoprodeck.com/api-guide/
|
||||
(defclass ygo-info ()
|
||||
((desc :accessor ygo-description-of :col-type :text)
|
||||
(frame-type :accessor ygo-frame-type-of :col-type :text)
|
||||
(type :accessor ygo-type-of :col-type :text)
|
||||
(passcode :accessor ygo-passcode-of :col-type :integer)
|
||||
(name :accessor name-of :col-type :text)
|
||||
(race :accessor ygo-race-of :col-type :text)
|
||||
(archetype :accessor ygo-archetype-of :col-type (or :text :null))
|
||||
(attribute :accessor ygo-attribute-of :col-type (or :text :null))
|
||||
(linkmarkers :accessor ygo-linkmarkers-of :col-type (or :text :null))
|
||||
(atk :accessor ygo-atk-of :col-type (or :integer :null))
|
||||
(def :accessor ygo-def-of :col-type (or :integer :null))
|
||||
(level :accessor ygo-level-of :col-type (or :integer :null))
|
||||
(linkval :accessor ygo-linkval-of :col-type (or :integer :null))
|
||||
(scale :accessor ygo-scale-of :col-type (or :integer :null)))
|
||||
(:metaclass registered-table-class))
|
||||
|
||||
;; banlist_info
|
||||
;; card_images
|
||||
;; card_prices
|
||||
;; card_sets
|
||||
;; jq '.[][]|{card_sets}|select( .card_sets != null )|.[][]' cardinfo.php
|
||||
|
||||
70
src/toolkit/git.lisp
Normal file
70
src/toolkit/git.lisp
Normal file
@ -0,0 +1,70 @@
|
||||
#|
|
||||
|
||||
src/toolkit/git.lisp
|
||||
|
||||
Tools For Working with git repository information
|
||||
|
||||
e.g. commit id, commit author, message, date, etc.
|
||||
|
||||
TODO Use INFERIOR-SHELL? Turns out it just calls UIOP:RUN-PROGRAM...
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.toolkit.git)
|
||||
|
||||
(defparameter *git-directory*
|
||||
(relative-pathname ".git")
|
||||
"The base path to the directory we run git in during UIOP:RUN-PROGRAM.")
|
||||
|
||||
(defparameter +git-binary+
|
||||
(format nil "git --no-pager --git-dir ~a" *git-directory*)
|
||||
"The full git command line, with *GIT-DIRECTORY* passed in already. What could go wrong?")
|
||||
|
||||
(defparameter +git-log+
|
||||
(concatenate 'string
|
||||
+git-binary+
|
||||
" log --format=\"%h%nAuthor: %an%nDate: %cD%n%s%n%b%n----\"")
|
||||
"Full command line to git log.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun git-revision ()
|
||||
"Query git rev-parse for the current HEAD revision id."
|
||||
(let ((command
|
||||
(concatenate 'string
|
||||
+git-binary+
|
||||
" rev-parse --short HEAD")))
|
||||
(string-trim '(#\Newline)
|
||||
(uiop:run-program command :output :string :error-output nil))))
|
||||
|
||||
(defun git-log ()
|
||||
"Query git log into a somewhat parseable format."
|
||||
(cl-ppcre:split
|
||||
"\\n+----\\n"
|
||||
(uiop:run-program +git-log+ :output :string)))
|
||||
|
||||
;; Not terrible...
|
||||
(defun parse-git-log (msg)
|
||||
"Split the output of GIT-MESSAGES-LIST into an actual LIST.
|
||||
|
||||
ARGUMENTS
|
||||
MSG The output of GIT-MESSAGES-LIST.
|
||||
|
||||
SEE GIT-LOG"
|
||||
(let ((state :in-commit)
|
||||
(c '()))
|
||||
(loop for line in (split-sequence:split-sequence #\Newline msg) do
|
||||
(case state
|
||||
(:in-commit (setf (getf c :commit) line
|
||||
state :in-author))
|
||||
(:in-author (setf (getf c :author) line
|
||||
state :in-date))
|
||||
(:in-date (setf (getf c :date) line
|
||||
state :in-subject))
|
||||
(:in-subject (setf (getf c :subject) line
|
||||
state :in-message))
|
||||
(:in-message (setf (getf c :message)
|
||||
(format nil "~a~a~%"
|
||||
(getf c :message "")
|
||||
line)))))
|
||||
c))
|
||||
62
src/toolkit/money.lisp
Normal file
62
src/toolkit/money.lisp
Normal file
@ -0,0 +1,62 @@
|
||||
#|
|
||||
|
||||
Money Stuff
|
||||
|
||||
Storing Floating Point values in an SQL database is *BAD*!:
|
||||
|
||||
CL-DECK-BUILDER2> (with-connection (db)
|
||||
(mito:retrieve-by-sql
|
||||
(sxql:select ((:as 0.005 :real)))))
|
||||
((:REAL 0.004999999888241291d0))
|
||||
|
||||
So I'm taking expert's advice and storing money as a fixed point integer with 100 divisions (cents).
|
||||
|
||||
Deflate: Mito -> RDBMS
|
||||
|
||||
Now with test suite!
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.toolkit.money)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defgeneric currency-deflate (obj)
|
||||
(:documentation "CURRENCY-DEFLATE takes a NUMBER or a STRING and converts it into a fixed point number.
|
||||
|
||||
;; One Half Dollar / $0.50 / 50 Cents / These are all the same thing
|
||||
(CURRENCY-DEFLATE 1/2) => 50
|
||||
(CURRENCY-DEFLATE 0.50) => 50
|
||||
(CURRENCY-DEFLATE 0.5d0) => 50
|
||||
(CURRENCY-DEFLATE \"1/2\") => 50
|
||||
(CURRENCY-DEFLATE \"0.50\") => 50
|
||||
(CURRENCY-DEFLATE \"0.5d0\") => 50
|
||||
|
||||
;; One Dollar / $1.00 / 100 Cents / These are all the same thing
|
||||
(CURRENCY-DEFLATE 1) => 100
|
||||
(CURRENCY-DEFLATE 1.00) => 100
|
||||
(CURRENCY-DEFLATE 1.0d0) => 100
|
||||
(CURRENCY-DEFLATE \"1\") => 100
|
||||
(CURRENCY-DEFLATE \"1.00\") => 100
|
||||
(CURRENCY-DEFLATE \"1.0d0\") => 100
|
||||
|
||||
;; Ten Dollars / $10.00 / 1000 Cents / These are all the same thing
|
||||
(CURRENCY-DEFLATE 10) => 1000
|
||||
(CURRENCY-DEFLATE 10.00) => 1000
|
||||
(CURRENCY-DEFLATE 10.0d0) => 1000
|
||||
(CURRENCY-DEFLATE \"10\") => 1000
|
||||
(CURRENCY-DEFLATE \"10.00\") => 1000
|
||||
(CURRENCY-DEFLATE \"10.0d0\") => 1000")
|
||||
(:method ((number number))
|
||||
;; CEILING or FLOOR?
|
||||
(ceiling (* 100 number)))
|
||||
(:method ((string string))
|
||||
(currency-deflate
|
||||
(read-from-string
|
||||
(if (eq (char string 0) #\$)
|
||||
(subseq string 1)
|
||||
string)))))
|
||||
|
||||
(defgeneric currency-inflate (obj)
|
||||
(:documentation "CURRENCY-INFLATE takes a NUMBER and converts it into a STRING representation of the fixed point amount of cents (100 cents per dollar) into \"$DD.CC\" format.")
|
||||
(:method ((number number))
|
||||
(format nil "~$" (float (/ number 100)))))
|
||||
62
src/toolkit/packages.lisp
Normal file
62
src/toolkit/packages.lisp
Normal file
@ -0,0 +1,62 @@
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.toolkit.paths
|
||||
(:use #:cl)
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:*public-directory*
|
||||
#:*static-directory*)
|
||||
(:export #:relative-pathname
|
||||
#:public-pathname
|
||||
#:static-pathname
|
||||
#:ygo-pathname
|
||||
|
||||
#:image-files-list
|
||||
#:make-static-filename-kind
|
||||
#:probe-file-list
|
||||
#:probe-image-files-list
|
||||
#:relative-file-list
|
||||
#:static-probe-file-list
|
||||
#:ydk-rename-files
|
||||
#:ygo-probe-file-list
|
||||
#:random-pathname-name))
|
||||
|
||||
;; #:CL-DECK-BUILDER2.TOOLKIT.GIT depends on #:CL-DECK-BUILDER2.TOOLKIT.PATHS
|
||||
(defpackage #:cl-deck-builder2.toolkit.git
|
||||
(:use #:cl)
|
||||
(:import-from #:cl-deck-builder2.toolkit.paths
|
||||
#:relative-pathname)
|
||||
(:export #:git-revision
|
||||
#:parse-git-log
|
||||
#:git-log))
|
||||
|
||||
(defpackage #:cl-deck-builder2.toolkit.money
|
||||
(:use #:cl)
|
||||
(:export #:currency-inflate
|
||||
#:currency-deflate))
|
||||
|
||||
(defpackage #:cl-deck-builder2.toolkit.time
|
||||
(:use #:cl)
|
||||
(:export #:generate-status-report))
|
||||
|
||||
(defpackage #:cl-deck-builder2.toolkit.utils
|
||||
(:use #:cl)
|
||||
(:export #:grouped
|
||||
#:normalize-newlines
|
||||
#:strip-bom
|
||||
|
||||
#:query-param
|
||||
#:generate-pages
|
||||
#:get-opposite-direction
|
||||
|
||||
#:rle-encode
|
||||
#:rle-encode-plist
|
||||
#:rle-decode
|
||||
#:latex-escape))
|
||||
|
||||
(uiop:define-package #:cl-deck-builder2.toolkit
|
||||
(:use #:cl)
|
||||
(:use-reexport #:cl-deck-builder2.toolkit.git
|
||||
#:cl-deck-builder2.toolkit.money
|
||||
#:cl-deck-builder2.toolkit.paths
|
||||
#:cl-deck-builder2.toolkit.time
|
||||
#:cl-deck-builder2.toolkit.utils))
|
||||
149
src/toolkit/paths.lisp
Normal file
149
src/toolkit/paths.lisp
Normal file
@ -0,0 +1,149 @@
|
||||
#|
|
||||
|
||||
src/toolkit/paths.lisp
|
||||
|
||||
Utilities For Working With Directories, Files, Paths, etc.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.toolkit.paths)
|
||||
|
||||
;;;; Code for munging paths and finding files at paths and renaming
|
||||
;;;; files and that sort of thing.
|
||||
|
||||
(defvar +ygoprodeck-images-root+
|
||||
(merge-pathnames #P"ygoprodeck/" *public-directory*)
|
||||
"The path to where the web server can display YGOProDeck images.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun probe-file-list (seq defaults)
|
||||
"PROBE-FILE-LIST wille apply PROBE-FILE to every file in SEQ.
|
||||
|
||||
It appears we also do some MERGE-PATHNAMES trickery."
|
||||
(mapcar (lambda (filename)
|
||||
(probe-file
|
||||
(merge-pathnames filename defaults)))
|
||||
seq))
|
||||
|
||||
(defun relative-file-list (seq &key (type "jpg"))
|
||||
"RELATIVE-FILE-LIST takes a LIST of files and transforms them into data that can be presented on the web interface, e.g. for A HREF URLs.
|
||||
|
||||
RELATIVE is in the title because we use PATHNAME-NAME to strip out any directory components on elements of SEQ.
|
||||
|
||||
ARGUMENTS:
|
||||
SEQ A LIST of files.
|
||||
DEFAULTS This is passed as the defaults argument to MERGE-PATHNAMES.
|
||||
|
||||
SEE STATIC-RELATIVE-FILE-LIST
|
||||
SEE YGO-RELATIVE-FILE-LIST"
|
||||
(mapcar (lambda (file)
|
||||
(make-pathname :name file :type type))
|
||||
(mapcar #'pathname-name seq)))
|
||||
|
||||
(defun static-probe-file-list (seq)
|
||||
"STATIC-PROBE-FILE-LIST takes a LIST of Yu-Gi-Oh! passcodes and transforms them into data that can be presented on the web interface,e.g. for A HREF URLs.
|
||||
|
||||
STATIC-PROBE-FILE-LIST takes a LIST of files and transforms them into data that can be presented on the web interface, e.g. for A HREF URLs. We use *PUBLIC-DIRECTORY* as the root directory for the output.
|
||||
|
||||
ARGUMENTS:
|
||||
SEQ A LIST of files.
|
||||
|
||||
SEE RELATIVE-FILE-LIST"
|
||||
(probe-file-list seq
|
||||
(relative-pathname *public-directory*)))
|
||||
|
||||
(defun ygo-probe-file-list (seq)
|
||||
"YGO-RELATIVE-FILE-LIST takes a LIST of Yu-Gi-Oh! passcodes and transforms them into data that can be presented on the web interface,e.g. for A HREF URLs.
|
||||
|
||||
ARGUMENTS:
|
||||
SEQ A LIST of files.
|
||||
|
||||
SEE RELATIVE-FILE-LIST"
|
||||
(probe-file-list
|
||||
(relative-file-list (mapcar #'princ-to-string seq) :type "jpg")
|
||||
(relative-pathname +ygoprodeck-images-root+)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun make-static-filename-kind (pathname-name maybe-list &key (type "jpg"))
|
||||
"We use UIOP:ENSURE-LIST so this may be called with one LIST argument.
|
||||
|
||||
TODO That seems kinda hacky to me."
|
||||
(merge-pathnames
|
||||
(make-pathname :name (format nil "~A-~{~A~^-~}"
|
||||
pathname-name
|
||||
(uiop:ensure-list maybe-list))
|
||||
:type type)
|
||||
*public-directory*))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Get the files from the file system .. so sloppy ...
|
||||
(defun image-files-list (name)
|
||||
(mapcar
|
||||
(lambda (kind)
|
||||
(make-static-filename-kind name kind))
|
||||
'("MAIN" "EXTRA" "SIDE" "MAIN-EXTRA" "MAIN-SIDE" "FINAL")))
|
||||
|
||||
(defun probe-image-files-list (name &optional (strip t))
|
||||
(let* ((pathname *public-directory*)
|
||||
(len (length (namestring pathname))))
|
||||
(remove
|
||||
NIL
|
||||
(mapcar
|
||||
(lambda (path)
|
||||
(if (probe-file path)
|
||||
(if strip
|
||||
(subseq (namestring path) len)
|
||||
path)))
|
||||
(image-files-list name)))))
|
||||
|
||||
;; TODO UIOP:ENOUGH-PATHNAME
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This had to be here, in WEB package probably, because YDK depends
|
||||
;; on TOOLKIT so it can't go in TOOLKIT because it depends on YDK: it
|
||||
;; uses YDK-NAME-OF. Perhaps I could pass just a name into this and
|
||||
;; make it deck agnostic.
|
||||
;;
|
||||
;; Okay I've done exactly that.
|
||||
(defun ydk-rename-files (old-name new-name)
|
||||
"Rename the files from DECK if there are any files according to PROBE-IMAGE-FILES-LIST.
|
||||
|
||||
If there are images, NEW-NAME will replace the PATHNAME-NAME of the old images."
|
||||
(let* ((old-files (probe-image-files-list old-name nil))
|
||||
(new-files
|
||||
(mapcar (lambda (path)
|
||||
(merge-pathnames
|
||||
(make-pathname :name path :type "jpg") *public-directory*))
|
||||
(mapcar (lambda (old-path)
|
||||
(cl-ppcre:regex-replace-all old-name (pathname-name old-path) new-name))
|
||||
old-files))))
|
||||
;; (format t "<pre>~a</pre>" (mapcar #'list old-files new-files))))
|
||||
(mapcar (lambda (pair)
|
||||
(when (probe-file (car pair))
|
||||
(rename-file (car pair) (cadr pair))))
|
||||
(mapcar #'list old-files new-files))))
|
||||
|
||||
(defun relative-pathname (name)
|
||||
(asdf:system-relative-pathname :cl-deck-builder2 name))
|
||||
|
||||
(defun public-pathname (name)
|
||||
(merge-pathnames name *public-directory*))
|
||||
|
||||
(defun static-pathname (name)
|
||||
(merge-pathnames name *static-directory*))
|
||||
|
||||
(defun ygo-pathname (name)
|
||||
(merge-pathnames name +ygoprodeck-images-root+))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Was originally from files.lisp
|
||||
|
||||
(defun digest-file-string (digest-spec pathspec &rest args)
|
||||
(format nil "~{~x~}"
|
||||
(coerce (apply #'ironclad:digest-file digest-spec pathspec args)
|
||||
'list)))
|
||||
|
||||
;; (random-filename (pathname-type pathspec)) => uuid.type
|
||||
(defun random-pathname-name (&key type)
|
||||
(let ((uuid (uuid:print-bytes nil (uuid:make-v4-uuid))))
|
||||
(format nil "~a~@[.~a~]" uuid type)))
|
||||
89
src/toolkit/time.lisp
Normal file
89
src/toolkit/time.lisp
Normal file
@ -0,0 +1,89 @@
|
||||
;; I noticed I've been doing a lot of work with time. This is time
|
||||
;; helpers.
|
||||
|
||||
(in-package #:cl-deck-builder2.toolkit.time)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun time-format (when &optional (format local-time:+rfc3339-format+))
|
||||
(local-time:format-timestring nil when :format format))
|
||||
|
||||
(defun time-format/date-only (when)
|
||||
(time-format when local-time:+rfc3339-format/date-only+))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun day- (when &optional (amount 1))
|
||||
"Subtract AMOUNT days from WHEN."
|
||||
(local-time:timestamp- when amount :day))
|
||||
|
||||
(defun day+ (when &optional (amount 1))
|
||||
"Add AMOUNT days to WHEN."
|
||||
(local-time:timestamp+ when amount :day))
|
||||
|
||||
(defun month- (when &optional (amount 1))
|
||||
"Subtract AMOUNT months from WHEN."
|
||||
(local-time:timestamp-
|
||||
(local-time:timestamp- when amount :month)
|
||||
local-time:+seconds-per-day+ :sec))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun time-now ()
|
||||
"Today's date, passed through FORMAT-DMY."
|
||||
(local-time:now))
|
||||
|
||||
(defun time-yesterday ()
|
||||
"Yesterday's date, passed through FORMAT-DMY."
|
||||
(day- (time-now)))
|
||||
|
||||
;; TODO Why am I using this?
|
||||
(defun time-first-of-month ()
|
||||
"The first day of this month."
|
||||
(local-time:timestamp-minimize-part
|
||||
(time-now) :day))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun n-month-list (&key (when (time-now)) (start 1) (n 6))
|
||||
"Produce a LIST of the last N months, using WHEN as the reference point.
|
||||
The values iterate numerically from START, that is, the result will be length N - START.
|
||||
The date will be on the first of each month, in chronological order."
|
||||
(mapcar (lambda (n)
|
||||
(month- when n))
|
||||
(loop for i from start upto n collect i)))
|
||||
|
||||
(defun n-day-list (&key (when (time-now)) (start 0) (n 5))
|
||||
"Produce a LIST of the last N days, using WHEN as a reference point.
|
||||
The values will iterate numerically from START, that is, the result will be length N - START.
|
||||
The exact times will not be modified. The results will be in chronological order."
|
||||
(mapcar (lambda (n)
|
||||
(day- when n))
|
||||
(loop for i from start upto n collect i)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun time-friday (&key (when (time-now)))
|
||||
(local-time:adjust-timestamp
|
||||
when
|
||||
(offset :day-of-week :friday)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun format-status-report (&key (stream *standard-output*) (when (time-friday)))
|
||||
(let ((date-str (time-format/date-only when))
|
||||
(day-map (reverse
|
||||
(mapcar #'time-format/date-only (n-day-list :when when :n 4)))))
|
||||
(format stream
|
||||
"#+TITLE: Status Report: Week of ~A~%~%* Status Report: ~
|
||||
Week of ~A~%~%Total hours: 40 h.~%~%~{** ~A~%~%Hours: 0800A-1600P (8h)~%~%~}"
|
||||
date-str date-str day-map)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defparameter *status-report-base-dir*
|
||||
(probe-file #P"~/code/cl-deck-builder2/doc/status-report/"))
|
||||
|
||||
(defun generate-status-report (&key (when (time-friday)))
|
||||
(let ((filespec (merge-pathnames
|
||||
(format nil "~a.org" (time-format/date-only when))
|
||||
*status-report-base-dir*)))
|
||||
(with-open-file (f filespec
|
||||
:direction :output
|
||||
:if-exists :error
|
||||
:if-does-not-exist :create)
|
||||
(format-status-report :stream f :when when)
|
||||
(probe-file filespec))))
|
||||
141
src/toolkit/utils.lisp
Normal file
141
src/toolkit/utils.lisp
Normal file
@ -0,0 +1,141 @@
|
||||
;;;; src/toolkit/toolkit.lisp
|
||||
|
||||
(in-package #:cl-deck-builder2.toolkit.utils)
|
||||
|
||||
;; https://stackoverflow.com/a/11965885
|
||||
;; def grouped(l, n):
|
||||
;; for i in xrange(0, len(l), n):
|
||||
;; yield l[i:i+n]
|
||||
|
||||
(defun grouped (seq &optional (n 1000))
|
||||
"Group elements in a list by some number of elements.
|
||||
|
||||
ARGUMENTS
|
||||
SEQ The sequence to be grouped.
|
||||
N The number of elements per grouping."
|
||||
(loop :for i :upto (1- (length seq)) :by n
|
||||
:collect (subseq seq i (min (length seq)
|
||||
(+ i n)))))
|
||||
|
||||
;; Not sure how I arrived at this gist.
|
||||
;;
|
||||
;; <https://gist.github.com/html/4085786>
|
||||
;;
|
||||
;; My code is modified slightly.
|
||||
(defun normalize-newlines (string)
|
||||
"Remove or replace #\Return(#\Newline)? sequences with just #\Newline.
|
||||
|
||||
The \#Newline following #\Return is optional, so just #\Return also gets turned into #\Newline.
|
||||
|
||||
ARGUMENTS
|
||||
STRING The target string."
|
||||
(ppcre:regex-replace-all
|
||||
(format nil "~C(\\n)?" #\Return)
|
||||
string
|
||||
(format nil "~C" #\Newline)))
|
||||
|
||||
;; Is this necessary? I uploaded a file with a BOM and it exploded.
|
||||
(defun strip-bom (string)
|
||||
"If STRING is UTF-8 and contains a UTF-8 BOM it will be removed.
|
||||
|
||||
ARGUMENTS
|
||||
STRING The string to check."
|
||||
|
||||
(when string
|
||||
(case (type-of (char string 0))
|
||||
(extended-char (subseq string 1))
|
||||
(t string))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun query-param (name parsed)
|
||||
"Parse query param values. Get the value of the specified element NAME in the query PARSED.
|
||||
|
||||
ARGUMENTS
|
||||
NAME The query to search for in the parameter list.
|
||||
PARSED The parameter list."
|
||||
;; TODO STRING=? STRING-EQUAL?? Maybe I should add a &KEY (test #'STRING=)?
|
||||
(assoc-utils:aget parsed name))
|
||||
|
||||
;; (defun generate-pages ()
|
||||
;; "Generate pagination"
|
||||
;; (let ((pages nil))
|
||||
;; (dotimes (i 10)
|
||||
;; (push (list :id (+ 1 i) :start (* 10 i)) pages))
|
||||
;; (reverse pages)))
|
||||
|
||||
;; TODO Passing weird floats to this. How can I put the weird math into here?
|
||||
;;
|
||||
;; I made it into a helper function for now.
|
||||
;; No idea how to even explain this. It works!
|
||||
(defun generate-pages-helper (start &optional (max 10) (multiplier 10))
|
||||
"Generate pagination up to MAX pages, with MULTIPLIER items per page."
|
||||
;; We always want 10 pages. If we start at page 0, subtract five,
|
||||
;; then take the nearest lowest non-negative integer (0), this gets
|
||||
;; us a comfy left bound.
|
||||
(let ((start- (- start 5)))
|
||||
;; If START- is less than zero, make it zero. This gives us a safe
|
||||
;; left bound.
|
||||
(when (< start- 0)
|
||||
(setf start- 0))
|
||||
(loop for i from 0 upto (1- (min (min max 8) (- max start -8))) collect
|
||||
`(:id ,(+ start- i) :offset ,(* multiplier (+ start- i))))))
|
||||
|
||||
(defun generate-pages (length offset &optional (limit 10))
|
||||
"Generate pagination for LENGTH number of pages, with LIMIT number of items per page, offset into the list by OFFSET number of pages.
|
||||
|
||||
ARGUMENTS
|
||||
LENGTH The length of the array we're generating pages for.
|
||||
OFFSET The starting index.
|
||||
LIMIT The number of entries per page. Default is 10."
|
||||
(generate-pages-helper (floor (/ offset limit))
|
||||
(ceiling (/ length limit))
|
||||
limit))
|
||||
|
||||
(defun get-opposite-direction (direction)
|
||||
"Get the opposite direction"
|
||||
(if (string= direction "asc")
|
||||
"desc"
|
||||
"asc"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Idea for RLE from PCL by Paul Graham
|
||||
;; This implementation based on <https://gist.github.com/trhura/5820848>
|
||||
;;
|
||||
;; Nope it's not I wrote my own implementation!
|
||||
(defun rle-encode (lst &key (key #'identity) (test #'eq))
|
||||
(loop for line in (mapcar key (remove-duplicates lst :key key :test test))
|
||||
collect (cons (count line lst :key key :test test) line)))
|
||||
;; (sort * ;#'> :key #'car))
|
||||
|
||||
(defun rle-decode (lst)
|
||||
(loop for line in lst
|
||||
nconc (make-list 3 :initial-element (second line))))
|
||||
|
||||
;; XXX Where does this go?
|
||||
(defun rle-encode-plist (plist &key (key #'identity) (test #'eq))
|
||||
(rle-encode
|
||||
(mapcar (lambda (plist)
|
||||
(setf (getf plist :name)
|
||||
(princ-to-string (getf plist :name)))
|
||||
plist)
|
||||
plist)
|
||||
:key key :test test))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; For The Label Maker
|
||||
;; https://tex.stackexchange.com/a/119383
|
||||
(defun latex-escape (s)
|
||||
(cl-ppcre:regex-replace-all
|
||||
"(\\\\backslash)"
|
||||
(cl-ppcre:regex-replace-all
|
||||
"~"
|
||||
(cl-ppcre:regex-replace-all
|
||||
"(\\^)"
|
||||
(cl-ppcre:regex-replace-all
|
||||
"([\$\#&%_{}])"
|
||||
(cl-ppcre:regex-replace-all "\\" s "\\backslash")
|
||||
"\\\\\\1")
|
||||
"\\\\\\1{}")
|
||||
"\\\\texttt{\\~{}}")
|
||||
"$\\1$"))
|
||||
|
||||
75
src/view.lisp
Normal file
75
src/view.lisp
Normal file
@ -0,0 +1,75 @@
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.view
|
||||
(:use #:cl)
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:*template-directory*)
|
||||
(:import-from #:cl-deck-builder2.i18n
|
||||
#:with-locale)
|
||||
(:import-from #:caveman2
|
||||
#:*response*
|
||||
#:response-headers)
|
||||
(:import-from #:djula
|
||||
#:add-template-directory
|
||||
#:compile-template*
|
||||
#:render-template*
|
||||
#:*djula-execute-package*)
|
||||
(:import-from #:datafly
|
||||
#:encode-json)
|
||||
(:export #:render
|
||||
#:render-json)
|
||||
(:documentation "The VIEW package.
|
||||
|
||||
We just use the defaults generated by Caveman2.
|
||||
|
||||
It provides rendering functions for web view.
|
||||
|
||||
Additionally, we have i18n support with gettext."))
|
||||
|
||||
(in-package :cl-deck-builder2.view)
|
||||
|
||||
(djula:add-template-directory *template-directory*)
|
||||
|
||||
(defparameter *template-registry* (make-hash-table :test 'equal)
|
||||
"Hash table of registered templates. Used for caching.")
|
||||
|
||||
(defun render (template-path &optional env (lang "en_US"))
|
||||
"Use Djula to render a template."
|
||||
(let ((template (gethash template-path *template-registry*)))
|
||||
(unless template
|
||||
(setf template (djula:compile-template* (princ-to-string template-path)))
|
||||
(setf (gethash template-path *template-registry*) template))
|
||||
(with-locale (lang)
|
||||
(apply #'djula:render-template* template nil env))))
|
||||
|
||||
(defun render-json (object)
|
||||
"Use Datafly to render a JSON object."
|
||||
(setf (getf (response-headers *response*) :content-type) "application/json")
|
||||
(encode-json object))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Execute package definition
|
||||
|
||||
(defpackage #:cl-deck-builder2.djula
|
||||
(:use :cl)
|
||||
(:import-from :cl-deck-builder2.config
|
||||
:config
|
||||
:appenv
|
||||
:developmentp
|
||||
:productionp)
|
||||
(:import-from :caveman2
|
||||
:url-for)
|
||||
(:documentation "The package in which template expressions are evaluated.
|
||||
|
||||
SEE <https://quickref.common-lisp.net/djula.html#g_t_276866_2769>"))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(setf djula:*djula-execute-package* (find-package :cl-deck-builder2.djula))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(in-package #:djula)
|
||||
|
||||
(djula:def-filter :describe (it)
|
||||
(with-output-to-string (s) (describe it s)))
|
||||
351
src/web/builder.lisp
Normal file
351
src/web/builder.lisp
Normal file
@ -0,0 +1,351 @@
|
||||
#|
|
||||
|
||||
src/web/builder.lisp
|
||||
|
||||
"The Deck Builder"
|
||||
|
||||
I figure we can also put YDK stuff here since they sorta do the
|
||||
same thing. Since CSV import comes from Crystal Commerce I've left
|
||||
that in the crystal-commerce file.
|
||||
|
||||
"The old one used to just have a list of cards, and you would
|
||||
click it, and add it to the deck."
|
||||
- Yuki, ~July 2023
|
||||
|
||||
TODO I think some of these modules are going to have conflicting
|
||||
names, e.g. RENDER-SAVED-DECK-LIST and SAVED-DECK-LIST ... Maybe
|
||||
I ought to start packaging this up.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
;; TODO Not in use yet.
|
||||
;; I really should be using https://github.com/40ants/reblocks
|
||||
(defclass builder-session ()
|
||||
((current-deck :accessor builder-session-current-deck
|
||||
:initform (make-instance 'ydk)
|
||||
:initarg :deck))
|
||||
(:documentation "A BUILDER-SESSION encapsulates a deck building session."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defparameter *current-deck* (make-instance 'ydk)
|
||||
"An instance of YDK that the builder uses as a working region.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun render-current-deck-list ()
|
||||
"Helper function. Render the current deck list from *CURRENT-DECK*.
|
||||
|
||||
The HTMX JS in the builder is what this gets output to."
|
||||
|
||||
(let ((deck-info (ydk-query *current-deck*)))
|
||||
;; No Deck info? Just return an empty list.
|
||||
(render-with-env #P"builder/current-deck-list.html"
|
||||
`(:active "/builder"
|
||||
:deck-id ,(ignore-errors (ydk-id-of *current-deck*))
|
||||
:main-deck ,(ignore-errors (getf deck-info :main-deck))
|
||||
:extra-deck ,(ignore-errors (getf deck-info :extra-deck))
|
||||
:side-deck ,(ignore-errors (getf deck-info :side-deck))))))
|
||||
|
||||
(defun render-saved-deck-list (&optional id)
|
||||
"Helper function. Render the saved deck list from SAVED-DECK-LIST."
|
||||
(render-with-env #P"builder/saved-deck-list.html"
|
||||
`(:active "/builder"
|
||||
:current-deck-id ,(ignore-errors
|
||||
(ydk-id-of *current-deck*))
|
||||
:id ,id
|
||||
:saved-deck-list ,(select-ydk-deck))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Index route
|
||||
(defroute ("/builder" :method :GET) (&key _parsed)
|
||||
"The builder home page. The *CURRENT-DECK* is used as a temporary workspace to create a YDK style deck listing."
|
||||
(v:info :builder "GET /builder => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :active "/builder"
|
||||
:class 'ygo-info
|
||||
:params _parsed
|
||||
:tpl #P"builder/index.html")))
|
||||
|
||||
(defroute ("/builder/current-deck-list" :method :GET) ()
|
||||
"The endpoint for RENDER-CURRENT-DECK-LIST.
|
||||
|
||||
TODO This should be re-written as a Redblocks Widget."
|
||||
|
||||
;; Haha, I moved the hack somewhere else. Now it's somebody elses
|
||||
;; problem. I actually think I fixed the hack. This comment stays
|
||||
;; for now.
|
||||
(with-logged-in-user
|
||||
(render-current-deck-list)))
|
||||
|
||||
(defroute ("/builder/saved-deck-list" :method :GET) ()
|
||||
"The endpoint for RENDER-SAVED-DECK-LIST.
|
||||
|
||||
TODO This should be re-written as a Redblocks Widget."
|
||||
(with-logged-in-user
|
||||
(render-saved-deck-list)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Search route
|
||||
(defroute ("/builder/search" :method :POST) (&key _parsed)
|
||||
"Main deck builder card search route. Will return a list of data from YGOProDeck. Now souped up and using an ALIST to pass parameters around."
|
||||
(v:info :builder "POST /builder/search => ~a~%" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :active "/builder"
|
||||
:class 'ygo-info
|
||||
:params _parsed
|
||||
:tpl #P"builder/search-results.html")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; POST ROUTES
|
||||
;;
|
||||
;; TODO Review Logic
|
||||
;;
|
||||
;; Always Extra, then Side
|
||||
;; "fusion"
|
||||
;; "link"
|
||||
;; "ritual"
|
||||
;; "synchro"
|
||||
;; "xyz"
|
||||
;; "fusion_pendulum"
|
||||
;; "ritual_pendulum"
|
||||
;; "synchro_pendulum"
|
||||
;; "xyz_pendulum"
|
||||
;;
|
||||
;; TODO Pretty Gnarly!
|
||||
(defroute ("/builder/add/:passcode" :method :POST) (&key passcode _parsed)
|
||||
"Try to add PASSCODE to *CURRENT-DECK*.
|
||||
|
||||
TODO Parameters: PASSCODE DECK"
|
||||
(v:info :builder "POST /builder/add/~d => ~a" passcode _parsed)
|
||||
|
||||
;; Clumsily enforce login
|
||||
(unless (logged-in-p)
|
||||
(_ "Oops"))
|
||||
|
||||
(let ((passcode (ignore-errors
|
||||
(parse-integer passcode)))
|
||||
(target-deck (alexandria:make-keyword
|
||||
(string-upcase
|
||||
(or
|
||||
(query-param "deck" _parsed)
|
||||
"MAIN")))))
|
||||
(when passcode
|
||||
(let* ((card-info (ygo-select-info-by-passcode passcode))
|
||||
(frame-type (ygo-frame-type-of card-info)))
|
||||
(labels ((is-special (frame-type)
|
||||
(or
|
||||
;; First check what kind of monster it is
|
||||
(string= "fusion" frame-type)
|
||||
(string= "link" frame-type)
|
||||
;; Ritual cards go in the main deck...
|
||||
;; (string= "ritual" frame-type)
|
||||
(string= "synchro" frame-type)
|
||||
(string= "xyz" frame-type)
|
||||
(string= "fusion_pendulum" frame-type)
|
||||
;; (string= "ritual_pendulum" frame-type)
|
||||
(string= "synchro_pendulum" frame-type)
|
||||
(string= "xyz_pendulum" frame-type)))
|
||||
(try-add (frame-type passcode target-deck)
|
||||
(v:info :builder "TRY-ADD ~a ~a ~a" frame-type passcode target-deck)
|
||||
(cond ((is-special frame-type)
|
||||
;; It's a Special Summon - try to add it to the Extra Deck, then Side Deck.
|
||||
(cond ((< (length (ydk-extra-deck-of *current-deck*)) +extra-deck-card-limit+)
|
||||
;; Add to extra deck
|
||||
(ydk-add *current-deck* :extra passcode))
|
||||
((< (length (ydk-side-deck-of *current-deck*)) +extra-deck-card-limit+)
|
||||
;; Add to side deck
|
||||
(ydk-add *current-deck* :side passcode))
|
||||
(t (v:info :builder (_ "Deck ~a has too many cards~%") (ydk-name-of *current-deck*)))))
|
||||
;; So if we get here theoretically the card shouldn't be a "Special Summon"
|
||||
((and (eq target-deck :main)
|
||||
(< (length (ydk-main-deck-of *current-deck*)) +main-deck-card-limit+))
|
||||
;; Add to main deck
|
||||
(ydk-add *current-deck* target-deck passcode))
|
||||
((and (eq target-deck :extra)
|
||||
(< (length (ydk-extra-deck-of *current-deck*)) +extra-deck-card-limit+)
|
||||
(not (equal frame-type "ritual")))
|
||||
;; Add to extra deck
|
||||
(ydk-add *current-deck* target-deck passcode))
|
||||
((and (eq target-deck :side)
|
||||
(< (length (ydk-side-deck-of *current-deck*)) +extra-deck-card-limit+)
|
||||
(not (equal frame-type "ritual")))
|
||||
;; Add to side deck
|
||||
(ydk-add *current-deck* target-deck passcode)))))
|
||||
;; TODO Where should we validate deck constrains? Here or ADD?
|
||||
;; For now we'll do it here.
|
||||
(if (< (count passcode (ydk-concatenate *current-deck*)) 3)
|
||||
;; There *are* fewer than three of this card in the deck...
|
||||
(try-add frame-type passcode target-deck)
|
||||
(flash-error (format nil (_ "Deck ~a has too many cards~%") (ydk-name-of *current-deck*))))))
|
||||
(setf (getf (response-headers *response*) :HX-Trigger) "deck-list-changed")
|
||||
(render-current-deck-list))))
|
||||
|
||||
(defroute ("/builder/remove" :method :POST) (&key _parsed)
|
||||
"Try to remove PASSCODE from *CURRENT-DECK*.
|
||||
|
||||
TODO Parameters: PASSCODE DECK"
|
||||
(v:info :builder "POST /builder/remove => ~a" _parsed)
|
||||
|
||||
(let ((index (query-param "index" _parsed))
|
||||
(deck (query-param "deck" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer index)
|
||||
(:string deck))
|
||||
(ydk-delete-index *current-deck* (alexandria:make-keyword (string-upcase deck)) index)
|
||||
(setf (getf (response-headers *response*) :HX-Trigger) "deck-list-changed"))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error (princ-to-string e))
|
||||
(redirect "/builder" 302))))
|
||||
|
||||
(render-current-deck-list))
|
||||
|
||||
(defroute ("/builder/clear" :method :POST) ()
|
||||
"Clear the *CURRENT-DECK* of any cards using YDK-CLEAR."
|
||||
(ydk-clear *current-deck*)
|
||||
(render-current-deck-list))
|
||||
|
||||
(defroute ("/builder/create" :method :POST) (&key _parsed)
|
||||
"Create a new deck. This will preserve some information from *CURRENT-DECK*, giving it a new name, and immediately synchronising it to the database. You may use the CLEAR route to erase the deck."
|
||||
(v:info :builder "POST /builder/create => ~a" _parsed)
|
||||
|
||||
(let ((name (query-param "deck-create-name" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:string name))
|
||||
(let ((found (ydk-deck-by-name name)))
|
||||
(if found
|
||||
;; The deck already exists
|
||||
(progn
|
||||
(flash-message
|
||||
(format nil (_ "Deck ~a already exists in database; loading...") name))
|
||||
(setf *current-deck* (ydk-sync found)))
|
||||
(progn
|
||||
(flash-message
|
||||
(format nil (_ "Creating deck ~a into database.") name))
|
||||
(setf *current-deck*
|
||||
(make-instance 'ydk
|
||||
:name name
|
||||
:created-by (user-name)
|
||||
:main-deck (ydk-main-deck-of *current-deck*)
|
||||
:extra-deck (ydk-extra-deck-of *current-deck*)
|
||||
:side-deck (ydk-side-deck-of *current-deck*)))
|
||||
;; Sync it to the database to save it to the
|
||||
;; names list - doesn't matter if it has no
|
||||
;; cards in it.
|
||||
(let ((new (ydk-sync *current-deck*)))
|
||||
(when new
|
||||
(setf (ydk-id-of *current-deck*)
|
||||
(mito:object-id new))))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
|
||||
(render-saved-deck-list))
|
||||
|
||||
(defroute ("/builder/delete" :method :DELETE) (&key _parsed)
|
||||
"Delete the deck specified by DECK-CREATE-NAME in the HTML.
|
||||
|
||||
TODO Parameters: NAME The name of the deck to use YDK-DECK-DELETE-BY-NAME on."
|
||||
(v:info :builder "DELETE /builder/delete => ~a" _parsed)
|
||||
|
||||
(let ((name (query-param "deck-create-name" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:string name))
|
||||
(ydk-deck-delete-by-name name))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
|
||||
(render-saved-deck-list))
|
||||
|
||||
(defroute ("/builder/save" :method :POST) ()
|
||||
"Save *CURRENT-DECK* to the database using YDK-SYNC. Return an updated deck listing with RENDER-CURRENT-DECK-LIST."
|
||||
(v:info :builder "POST /builder/save")
|
||||
|
||||
(v:info :builder "~a" (ydk-sync *current-deck*))
|
||||
|
||||
(render-current-deck-list))
|
||||
|
||||
(defroute ("/builder/load" :method :POST) (&key _parsed)
|
||||
"Load Deck POST Route. Load ID into *CURRENT-DECK*."
|
||||
(v:info :builder "POST /builder/load => ~a" _parsed)
|
||||
|
||||
(let ((id (query-param "deck-load-id" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(when found
|
||||
(setf *current-deck* (ydk-sorted (ydk-sync found)))
|
||||
(flash-message
|
||||
(format nil (_ "Found entry ~A (~d); loading...~%")
|
||||
(ydk-name-of found) (mito:object-id found))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
|
||||
(render-current-deck-list))
|
||||
|
||||
(defroute ("/builder/rename" :method :POST) (&key _parsed)
|
||||
"Try to rename a deck. Rename Deck ID to DECK-CREATE-NAME.
|
||||
|
||||
TODO There is other code to rename, isn't there? It looks like that code is inteded to be used from the Deck Overview page. This is just in the builder."
|
||||
(v:info :builder "POST /builder/rename => ~a" _parsed)
|
||||
|
||||
(let ((create-name (query-param "deck-create-name" _parsed))
|
||||
(id (query-param "deck-load-id" _parsed)))
|
||||
;; We want to change the name of LOAD-NAME to CREATE-NAME.
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(ydk-rename-deck found create-name)
|
||||
(flash-message
|
||||
(format nil (_ "Found entry ~A (~d); renaming to ~a.~%")
|
||||
(ydk-name-of found) id create-name))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
|
||||
(render-saved-deck-list))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Since we're doing this in a builder context I thought it would be
|
||||
;; better to do this here than at /category/saved-category-list as
|
||||
;; that seemed a bit redundant. Surely there's a better way to
|
||||
;; organize all this stuff!
|
||||
(defroute ("/builder/saved-category-list" :method :GET) (&key _parsed)
|
||||
"Route for rendering the saved category list.
|
||||
|
||||
This is a \"widget\" that we include with Djula, and render separately via HTMX AJAX."
|
||||
(let ((id (query-param "id" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (find-dao 'category :id id)))
|
||||
(if found
|
||||
(render-category found
|
||||
:tpl #P"builder/saved-category-list.html"))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)
|
||||
(render-category (find-dao 'category :id (max-dao 'category))
|
||||
:tpl #P"builder/saved-category-list.html")))))
|
||||
|
||||
;; TODO This has got to be better!
|
||||
(defroute ("/builder/decks-by-cat-id" :method :GET) (&key |id|)
|
||||
"Saved Deck List helper. Display the saved deck list, and if an |ID| is provided, send that as the current ID."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"builder/saved-deck-list.html"
|
||||
`(:active "/builder"
|
||||
:current-deck-id ,(ignore-errors
|
||||
(ydk-id-of *current-deck*))
|
||||
:id ,|id|
|
||||
:saved-deck-list ,(select-ydk-deck
|
||||
(if |id|
|
||||
(sxql:where (:= :category-id |id|))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/builder/move-to-category" :method :POST) (&key _parsed)
|
||||
"Move *CURRENT-DECK* into CATEGORY ID. TODO Implement this?"
|
||||
(v:info :builder "GET /builder/move-to-category => ~a" _parsed))
|
||||
92
src/web/cards.lisp
Normal file
92
src/web/cards.lisp
Normal file
@ -0,0 +1,92 @@
|
||||
#|
|
||||
|
||||
src/web/cards.lisp
|
||||
|
||||
Card Browser
|
||||
|
||||
TODO Link To Inventory Item
|
||||
TODO This needs to be rewritten using YGOProDeck 2 still.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defroute ("/cards" :method :GET) (&key _parsed)
|
||||
"Card Browser Main Route. We use RENDER-RESULTS from `/inventory` URL.
|
||||
|
||||
TODO Cards should probably have their own RENDER-RESULTS. RENDER-CARD?"
|
||||
(v:info :cards "GET /cards => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :active "/cards"
|
||||
:class 'ygo-info
|
||||
:params _parsed
|
||||
:tpl #P"cards/index.html")))
|
||||
|
||||
(defroute ("/cards/search" :method :POST) (&key _parsed)
|
||||
"Card Browser Search POST Route. We also user RENDER-RESULTS here."
|
||||
(v:info :cards "POST /cards/search => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :active "/cards"
|
||||
:class 'ygo-info
|
||||
:params _parsed
|
||||
:tpl #P"cards/search-results.html")))
|
||||
|
||||
(defroute ("/cards/:id/view" :method :GET) (&key id)
|
||||
"View Route for Card ID. We use YGO-SELECT-INFO-BY-ID to get the PASSCODE to get the YGO-SET-BY-PASSCODE."
|
||||
(v:info :cards "GET /cards/~d/view" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(let* ((variants (select-variant-condition))
|
||||
(ygo-info (ygo-select-info-by-id id))
|
||||
(passcode (ygo-passcode-of ygo-info))
|
||||
(found (ygo-card-sets passcode)))
|
||||
(if found
|
||||
(render-with-env #P"cards/view.html"
|
||||
`(:ygo-card-sets ,found
|
||||
:variants ,variants)))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error (format nil "/cards/~d/view.error => ~a~%" id e))))))
|
||||
|
||||
(defroute ("/cards/by-passcode/:id" :method :GET) (&key id)
|
||||
"View YGO-INFO by PASSCODE ID."
|
||||
(alexandria:if-let ((info (find-dao 'ygo-info :passcode id)))
|
||||
(redirect (format nil "/cards/~d/view" (mito:object-id info)))
|
||||
(redirect "/cards")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; This is bad, but could be better for other things
|
||||
(defroute ("/cards/:id/image" :method :GET) (&key id)
|
||||
"Get the card image for card ID.
|
||||
|
||||
TODO Rewrite with templates
|
||||
TODO This is bad, the way that it's written right now it will take one ID, ideally, this should wrap a list of IDs to save on database bandwidth. Each request triggers a FIND-DAO."
|
||||
(v:debug :cards "GET /cards/~d/image" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (find-dao 'ygo-info :id id)))
|
||||
(if found
|
||||
(format nil
|
||||
"<img class=\"w3-image w3-card-4 zoom\" src=\"/public/ygoprodeck/~a.jpg\" alt=\"Card Image for Yu-Gi-Oh! ~a - ~a\">"
|
||||
(ygo-passcode-of found)
|
||||
(ygo-passcode-of found)
|
||||
(name-of found))))))))
|
||||
|
||||
(defroute ("/cards/by-passcode/:id/price" :method :GET) (&key id)
|
||||
"Get the YGO-PRICE info for this PASSCODE ID. The pricing info comes from YGOProDeck."
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (find-dao 'ygo-price :passcode-id id)))
|
||||
(render-with-env #P"cards/ygo-price.html"
|
||||
(list :price found)))))))
|
||||
138
src/web/category.lisp
Normal file
138
src/web/category.lisp
Normal file
@ -0,0 +1,138 @@
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defparameter *current-category* nil)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun render-category (id &key (tpl #P"category/index.html") env)
|
||||
"Helper function. Use RENDER-WITH-ENV to display template TPL with environment ENV.
|
||||
|
||||
ID is the CATEGORY we wish to render.
|
||||
|
||||
TODO etypecase? defmethod?"
|
||||
(let ((found (ignore-errors
|
||||
(find-dao 'category :id id))))
|
||||
(render-with-env tpl
|
||||
(append env
|
||||
`(:active "/category"
|
||||
:category ,found
|
||||
:categories ,(select-category)
|
||||
:children ,(ignore-errors (category-full-tree :node.name (category-name-of found)))
|
||||
:id ,(ignore-errors (mito:object-id found)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/category" :method :GET) (&key _parsed)
|
||||
"Category Viewer Main Route.
|
||||
|
||||
TODO Parameters: ID The desired CATEGORY ID."
|
||||
(with-logged-in-user
|
||||
(render-category (query-param "id" _parsed))))
|
||||
|
||||
(defroute ("/category/search" :method :POST) (&key _parsed)
|
||||
"POST Category Search Route.
|
||||
|
||||
TODO Implement this?"
|
||||
(with-logged-in-user
|
||||
(render-category (query-param "id" _parsed))))
|
||||
|
||||
(defroute ("/category/:id/view" :method :GET) (&key id)
|
||||
"Category Viewer Single Route.
|
||||
|
||||
TODO Parameters: ID The desired CATEGORY ID."
|
||||
(with-logged-in-user
|
||||
(render-category id)))
|
||||
|
||||
(defroute ("/category/list" :method :GET) (&key _parsed)
|
||||
"GET route for the list of categories."
|
||||
(v:info :web "GET /category/list => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-category (query-param "id" _parsed))))
|
||||
|
||||
(defroute ("/category/:id/delete" :method :DELETE) (&key id)
|
||||
"DELETE a CATEGORY.
|
||||
|
||||
TODO Parameters: ID The ID of the CATEGORY to remove.
|
||||
TODO Also delete associated deck metadata?"
|
||||
(v:info :web "DELETE /category/:id/delete" id)
|
||||
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (find-dao 'category :id id)))
|
||||
(when found
|
||||
(category-delete-tree (category-name-of found))
|
||||
(v:info :web "DELETE /category/:id/delete OK" id)
|
||||
(flash-message (_ "Success!")))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
|
||||
(defroute ("/category/:id/rename" :method :POST) (&key id _parsed)
|
||||
"POST route to RENAME a CATEGORY.
|
||||
|
||||
TODO Parameters: NAME The new name of the CATEGORY. ID of the CATEGORY to be RENAMEd."
|
||||
(v:info :web "POST /category/~d/rename => ~a" id _parsed)
|
||||
|
||||
(let ((name (query-param "name" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id)
|
||||
(:string name))
|
||||
(if (category-rename (find-dao 'category :id id) name)
|
||||
(format nil "OK!")
|
||||
(format nil "Error!")))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defroute ("/category/fake-data" :method :GET) ()
|
||||
"Route to generate new fake CATEGORY data.
|
||||
|
||||
TODO Parameters: NAME The name of the new child CATEGORY. ID The parent of the new child CATEGORY."
|
||||
|
||||
(v:info :web "GET /category/fake-data")
|
||||
(category-insert-fake-data)
|
||||
(v:info :web "GET /category/fake-data OK"))
|
||||
|
||||
(defroute ("/category/new-parent" :method :POST) (&key _parsed)
|
||||
"Create a new parent by NAME. We use CATEGORY-INSERT-RIGHT-OF."
|
||||
(v:info :web "POST /category/new-parent => ~a" _parsed)
|
||||
|
||||
(let ((id (or (query-param "id" _parsed) 0))
|
||||
(name (query-param "name" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id)
|
||||
(:string name))
|
||||
(let ((left-of (ignore-errors
|
||||
(category-name-of (find-dao 'category :id id)))))
|
||||
(category-insert-right-of name left-of)))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/category/new-child" :method :POST) (&key _parsed)
|
||||
"POST route for a new child CATEGORY.
|
||||
|
||||
TODO Parameters: NAME The name of the new child CATEGORY. ID The parent of the new child CATEGORY."
|
||||
(v:info :web "POST /category/new-child => ~a" _parsed)
|
||||
|
||||
(let ((id (query-param "id" _parsed))
|
||||
(name (query-param "name" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id)
|
||||
(:string name))
|
||||
(let ((left-of (ignore-errors
|
||||
(category-name-of (find-dao 'category :id id)))))
|
||||
(category-insert-new-child name left-of)
|
||||
(format nil "OK!")))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/category/explain" :method :GET) ()
|
||||
"TODO This needs to be incorporated into the documentation."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"category/explain.html"
|
||||
`(:active "/category"
|
||||
:categories ,(select-category)))))
|
||||
239
src/web/constructed-decks.lisp
Normal file
239
src/web/constructed-decks.lisp
Normal file
@ -0,0 +1,239 @@
|
||||
#|
|
||||
|
||||
src/web/construct-decks.lisp
|
||||
|
||||
Web Routes For Construct Decks
|
||||
|
||||
TODO Pick one: /construct/ or /construct/ ?
|
||||
|
||||
Features Requsted:
|
||||
|
||||
- DONE Card Names
|
||||
- DONE Card Prices - I think we'll need to wire this up to the
|
||||
YGO-CC-ITEM. That requires rewriting that component to use the new
|
||||
YGO-SET instead of the CSV.
|
||||
- DONE Sort by Price - Honestly having trouble sorting this junk lmao!
|
||||
- Show only YGO-SET-ITEMS with inventory - see constructed-decks.lisp<models>
|
||||
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defparameter *current-constructed-deck* nil)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun render-construct-deck (id tpl)
|
||||
(with-logged-in-user
|
||||
(let ((deck (first
|
||||
(select-constructed-decks
|
||||
(sxql:where (:= :id id))))))
|
||||
(when deck
|
||||
(render-with-env tpl
|
||||
(list :active "/construct"
|
||||
:deck deck
|
||||
:id (mito:object-id deck)
|
||||
:name (cl-deck-builder2.models.constructed-decks::deck-name-of deck)
|
||||
:saved-deck-list (select-constructed-decks)))))))
|
||||
|
||||
;; I think this takes a CAR and a CDR pair of YGO-SET ID and VARIANT ID
|
||||
;; I'm pretty sure it's supposed to be finding YGO-SET-ITEMs though
|
||||
(defun selected-sets-to-deck-listing (cards)
|
||||
(let ((lst '()))
|
||||
(with-connection (db)
|
||||
(with-transaction
|
||||
(dolist (card cards (reverse lst))
|
||||
(destructuring-bind (set variant)
|
||||
card
|
||||
(let* ((set-id (cdr set))
|
||||
(variant-id (cdr variant))
|
||||
(set-item (first (ygo-select-set-item set-id variant-id)))
|
||||
(set (first (ygo-set (sxql:where (:= :id set-id)))))
|
||||
(variant (mito:find-dao 'variant-condition :id variant-id)))
|
||||
(with-slots ((passcode-id cl-deck-builder2.models.ygoprodeck.classes::passcode-id))
|
||||
set
|
||||
(push (list :deck-set set
|
||||
:condition variant
|
||||
:set-item set-item
|
||||
:card (ygo-card-by-passcode passcode-id))
|
||||
lst)))))))))
|
||||
|
||||
;; XXX Where does this go? What does this accomplish?
|
||||
(defun select-deck-as-plist (id)
|
||||
(let ((lst '()))
|
||||
(dolist (itm (retrieve-dao 'deck-item :deck-id id) (reverse lst))
|
||||
(push (list :deck-item itm) lst))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun default-constructed-deck-is-valid-to-pull ()
|
||||
(valid-pull-p
|
||||
(deck-to-pull-set-items-qty-as-alist *current-constructed-deck*)
|
||||
(deck-to-pull-desired-qty-as-alist *current-constructed-deck*)))
|
||||
|
||||
(defun default-constructed-deck-invalid-qtys ()
|
||||
(find-any-invalid-qtys
|
||||
(deck-to-pull-set-items-qty-as-alist *current-constructed-deck*)
|
||||
(deck-to-pull-desired-qty-as-alist *current-constructed-deck*)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun store-combined-deck-as-current (original-deck selected-listing)
|
||||
(setf *current-constructed-deck*
|
||||
(loop for original in (reverse original-deck)
|
||||
for selected in selected-listing
|
||||
collect (apply #'make-instance 'constructed-deck-intermediate (append original selected)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; We have to actually pull the inventory.
|
||||
;; This is the old code but it's written for YDK-DECK object so maybe I'll write one for CONSTRUCTED-DECK-INTERMEDIATE.
|
||||
(defun pull-from-inventory (cdi-items)
|
||||
"Attempt to find inventory stock for every card in this deck, and if we are able to secure it, construct and insert a new PULLED-DECK into the database."
|
||||
(let ((counts (deck-to-pull-desired-qty-as-alist cdi-items)))
|
||||
(dolist (row counts)
|
||||
(decf (qty-of (car row)) (cdr row))
|
||||
;; Update each one and save - wrapping this in a transaction causes issues with pulling multiple items.
|
||||
(save-dao (car row)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/construct" :method :GET) ()
|
||||
"Constructed Deck View Main Route. Login Required."
|
||||
(v:info :construct "GET /construct")
|
||||
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"construct/index.html"
|
||||
(list :active "/construct"
|
||||
:saved-deck-list (select-constructed-decks)))))
|
||||
|
||||
(defroute ("/construct/:id/view" :method :GET) (&key id)
|
||||
"Constructed Deck View deck by ID Route. Login Required."
|
||||
(v:info :construct "GET /construct/~d" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-construct-deck id #P"construct/index.html")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/construct/ygo-set-item" :method :GET) (&key _parsed)
|
||||
"Find the YGO-SET-ITEM associated with the |SET-ID| and |VARIANT-ID|
|
||||
|
||||
TODO This needs a rewrite as it currently actually accepts multiple
|
||||
CARDs and operates on their component |SET-ID| and |VARIANT-ID| which
|
||||
is really not optimal. Ideally we should be handling this all in bulk
|
||||
with better routes."
|
||||
(v:info :cards "GET /cards/ygo-set-items ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(alexandria:if-let ((cards (query-param "cards" _parsed)))
|
||||
(dolist (card cards)
|
||||
(let ((|set-id| (query-param "set-id" card))
|
||||
(|variant-id| (query-param "variant-id" card)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer |set-id|)
|
||||
(:integer |variant-id|))
|
||||
(return
|
||||
(render-with-env #P"cards/variant-results.html"
|
||||
(list :id (gensym)
|
||||
:item (find |variant-id|
|
||||
(select-ygo-cc-item-variants |set-id|)
|
||||
:key (alexandria:compose #'mito:object-id #'variant-of))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error (format nil "/cards/ygo-set-items => ~d:~d ~a~%" |set-id| |variant-id| e)))))))))
|
||||
|
||||
|
||||
(defroute ("/construct/:id/select-sets" :method :GET) (&key id)
|
||||
"Select the YDK-SET for the corresponding PASSCODEs. Use Deck ID from the deck builder."
|
||||
(v:info :construct "GET /construct/~d/select-sets" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(with-connection (db)
|
||||
(let* ((cards (mito:retrieve-dao 'deck-item :deck-id id))
|
||||
(sets (mapcar (alexandria:compose #'ygo-card-sets #'deck-passcode-of) cards))
|
||||
(variants (select-variant-condition)))
|
||||
(render-with-env #P"construct/select-sets.html"
|
||||
(list :sets (reverse sets)
|
||||
:deck-id id
|
||||
:variants variants))))))
|
||||
|
||||
(defroute ("/construct/:id/select-sets" :method :POST) (&key id _parsed)
|
||||
"Constructed Decks Select Sets POST Route - Attempt to SUBTRACT-DESIRED-FROM-SET-ITEM-QTY-AS-ALIST, and if VALID-PULL-P, call PULL-FROM-INVENTORY. Otherwise, FLASH-ERROR to the user about Insufficient Inventory."
|
||||
(v:info :construct "POST /construct/~d/select-sets ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(alexandria:if-let ((cards (query-param "cards" _parsed)))
|
||||
(let ((original-deck (select-deck-as-plist id))
|
||||
(selected-listing (selected-sets-to-deck-listing cards)))
|
||||
|
||||
;; Store the current constructed deck template
|
||||
(store-combined-deck-as-current original-deck selected-listing)
|
||||
|
||||
;; See if there are any issues with the current inventory
|
||||
(if (default-constructed-deck-is-valid-to-pull)
|
||||
(progn
|
||||
;; Decrement the stock from the YGO-SET-ITEM
|
||||
(pull-from-inventory *current-constructed-deck*)
|
||||
;; Create a new CONSTRUCTED-DECK based on *CURRENT-CONSTRUCTED-DECK*
|
||||
(cdi-pull-from-inventory *current-constructed-deck*)
|
||||
(flash-message (_ "Deck constructed!"))
|
||||
(render-with-env #P"construct/constructed-deck-list.html"
|
||||
(list :original-deck original-deck
|
||||
:deck-id id
|
||||
:total-price nil
|
||||
:table *current-constructed-deck*)))
|
||||
(let ((err (default-constructed-deck-invalid-qtys)))
|
||||
(with-connection (db)
|
||||
(flash-error (format nil (_ "Insufficient Inventory: <a href=\"/cards/by-passcode/~a\" target=\"_blank\">~a</a>")
|
||||
;; TODO all this nesting again...
|
||||
(ygo-passcode-of err)
|
||||
(ygo-passcode-of err))))
|
||||
(redirect (format nil "/construct/~d/select-sets" id))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/construct/:id/deconstruct" :method :POST) (&key id _parsed)
|
||||
"Deconstruct deck. That is, increment the QTY of the the contents to of the CONSTRUCTED-DECK-AS-CDI-LIST."
|
||||
(v:info :construct "POST /construct/~d/deconstruct ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(return-to-inventory
|
||||
(constructed-deck-as-cdi-list id)))
|
||||
|
||||
(_ "Ok!"))
|
||||
|
||||
(defroute ("/construct/:id/selected-sets" :method :GET) (&key id _parsed)
|
||||
"Query CONSTRUCTED-DECK ID for the YGO-SET-ITEMS it contains. We use CONSTRUCTED-DECK-AS-CDI-LIST again."
|
||||
(v:info :construct "GET /construct/~d/selected-sets ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((table (constructed-deck-as-cdi-list id)))
|
||||
(render-with-env #P"construct/constructed-deck-list.html"
|
||||
(list :table table)))))
|
||||
|
||||
(defroute ("/construct/:id/update" :method :POST) (&key id |name| |sell-price| |sold| _parsed)
|
||||
"Update a CONSTRUCTED-DECK by ID"
|
||||
(v:info :construct "POST /construct/~d/update ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((found (find-dao 'constructed-deck :id id)))
|
||||
(when found
|
||||
(when |name| (setf (deck-name-of found) |name|))
|
||||
(when |sell-price| (setf (deck-sell-price-of found) |sell-price|))
|
||||
(when (string= |sold| "on") (setf (deck-sold found) 1))
|
||||
(update-dao found)
|
||||
(flash-message (_ "Deck Updated"))
|
||||
(redirect (format nil "/construct/~d/view" id))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; This one looks like: Get all the cards in a deck id 13 and query all the sets using YGO-CARD-SETS
|
||||
|
||||
;; (let* ((cards (retrieve-dao 'deck-item :deck-id 13))
|
||||
;; (all-sets (mapcar #'deck-passcode-of cards)))
|
||||
;; (mapcar #'cl-deck-builder2.models.ygoprodeck.methods::ygo-card-sets
|
||||
;; (reverse all-sets)))
|
||||
|
||||
;; (with-connection (db)
|
||||
;; (with-transaction
|
||||
;; (let ((v (mito:find-dao 'cl-deck-builder2.models.ygoprodeck.fields::variant-condition :name "Near Mint")))
|
||||
;; (mapcar (lambda (set)
|
||||
;; (mito:find-dao 'cl-deck-builder2.models.ygoprodeck.classes::ygo-set-item
|
||||
;; :item set
|
||||
;; :variant v))
|
||||
;; *))))
|
||||
76
src/web/contact.lisp
Normal file
76
src/web/contact.lisp
Normal file
@ -0,0 +1,76 @@
|
||||
#|
|
||||
|
||||
# Contact Form
|
||||
|
||||
GET /contact Index
|
||||
GET /contact/admin Admin Panel
|
||||
GET /contact/:id View Submission TODO
|
||||
|
||||
DELETE /contact Clear All
|
||||
DELETE /contact/:id Delete By ID
|
||||
|
||||
POST /contact New Submission
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun render-feedback (&optional (tpl #P"contact/index.html"))
|
||||
(render-with-env tpl (append
|
||||
(list :active "/contact")
|
||||
(auth (:admin)
|
||||
(list :feedback (select-feedback))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/contact" :method :GET) ()
|
||||
"Contact Form Index Page"
|
||||
(v:info :contact "GET /contact")
|
||||
|
||||
(with-logged-in-user
|
||||
(render-feedback)))
|
||||
|
||||
(defroute ("/contact/admin" :method :GET) ()
|
||||
"Contact Form Admin Panel"
|
||||
(with-logged-in-user
|
||||
(render-feedback #P"contact/admin.html")))
|
||||
|
||||
(defroute ("/contact" :method :DELETE) ()
|
||||
"Delete *ALL* FEEDBACK."
|
||||
(v:info :contact "DELETE /contact")
|
||||
|
||||
(auth (:admin)
|
||||
(progn
|
||||
(delete-from 'feedback)
|
||||
(flash-message (_ "Feedback cleared."))
|
||||
(render-feedback #P"contact/list.html"))
|
||||
(flash-error (_ "Something went wrong. Try again?"))))
|
||||
|
||||
(defroute ("/contact/:id/delete" :method :DELETE) (&key id)
|
||||
"Delete FEEDBACK with matching ID."
|
||||
|
||||
(auth (:admin)
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(delete-by-values 'feedback :id id))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/contact" :method :POST) (&key _parsed)
|
||||
"User Submit Feedback POST Route. Login Required."
|
||||
(v:info :contact "POST /contact => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((user (find-dao 'user :email (user-name)))
|
||||
(body (query-param "query" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:string body))
|
||||
(if (ignore-errors
|
||||
(create-feedback user body))
|
||||
(flash-message (_ "Thanks! We got your message."))
|
||||
(flash-error (_ "Something went wrong. Try again?"))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))
|
||||
(redirect "/contact")))
|
||||
376
src/web/decks.lisp
Normal file
376
src/web/decks.lisp
Normal file
@ -0,0 +1,376 @@
|
||||
#|
|
||||
|
||||
src/web/decks.lisp
|
||||
|
||||
Deck Overview Web Interface
|
||||
|
||||
Here we see the cards in the deck, we have the option to generate
|
||||
deck images, and we have the option to pull the deck from
|
||||
inventory.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO both YDK-DATA-TO-TEMPLATE and RENDER-YDK desperately need an overhaul.
|
||||
(defun ydk-to-template-data (ydk)
|
||||
"Transform information from YDK-QUERY on YDK into: main, side, extra decks, with RLE encodings of all three, plus metadata."
|
||||
(let ((data (ydk-query ydk)))
|
||||
(when data
|
||||
(labels ((filter-kind (lst kind)
|
||||
(remove-if
|
||||
(lambda (card)
|
||||
(if (eq (getf card :kind) kind)
|
||||
nil
|
||||
t))
|
||||
(reverse lst))))
|
||||
(let ((main-deck (filter-kind data 0))
|
||||
(extra-deck (filter-kind data 1))
|
||||
(side-deck (filter-kind data 2)))
|
||||
(list
|
||||
:name (ydk-name-of ydk)
|
||||
:created-by (ydk-created-by ydk)
|
||||
|
||||
:main-deck main-deck
|
||||
:extra-deck extra-deck
|
||||
:side-deck side-deck
|
||||
|
||||
:main-deck-rle (rle-encode-plist main-deck :key (lambda (plist) (getf plist :name)) :test #'string=)
|
||||
:extra-deck-rle (rle-encode-plist extra-deck :key (lambda (plist) (getf plist :name)) :test #'string=)
|
||||
:side-deck-rle (rle-encode-plist side-deck :key (lambda (plist) (getf plist :name)) :test #'string=)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; TODO This is ugly still. Fix it.
|
||||
(defun draw-deck-image-by-id (id)
|
||||
(let ((found (find-dao 'ydk-deck :id id)))
|
||||
(when found
|
||||
(let ((ydk (ydk-sync found)))
|
||||
(draw-deck-image ydk (ydk-name-of ydk))))))
|
||||
|
||||
;; TODO this only works with decks from the database as it uses
|
||||
;; YDK-DECK-INFO-BY-ID, making the name of this function a
|
||||
;; misnomer. It should be RENDER-YDK-BY-DECK-ID. I'd use YDK-QUERY for
|
||||
;; now beacuse that nets you INNER-JOIN with fields coming from
|
||||
;; datafly as an associated list... sloppy work.
|
||||
(defun render-ydk (id tpl)
|
||||
"Render a YDK-DECK from the databse with ID using template TPL. We also use YDK-TO-TEMPLATE-DATA to query additional deck information."
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(if found
|
||||
(render-with-env
|
||||
tpl
|
||||
(append
|
||||
(list :active "/decks"
|
||||
:id id
|
||||
:category (with-connection (db)
|
||||
(ydk-category-of found))
|
||||
:saved-deck-list (select-ydk-deck)
|
||||
:saved-category-list (select-category)
|
||||
:files (probe-image-files-list
|
||||
(ydk-name-of found)))
|
||||
(ydk-to-template-data found)))
|
||||
(_ "Nothing to see here..."))))
|
||||
|
||||
(defgeneric ydk-listing-as (id tpl)
|
||||
(:documentation "Looks like this is a kludge to accept ID as a string or integer. TODO Move to generics.lisp")
|
||||
(:method ((id string) (tpl pathname))
|
||||
(ydk-listing-as (parse-integer id) tpl))
|
||||
(:method ((id integer) (tpl pathname))
|
||||
(render-ydk id tpl)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/decks" :method :GET) (&key _parsed)
|
||||
"Deck List Main Route. Login Required."
|
||||
(with-logged-in-user
|
||||
(let ((id (query-param "deck-load-id" _parsed)))
|
||||
(if id
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(render-with-env #P"decks/index.html"
|
||||
`(:active "/decks"
|
||||
:files ,(probe-image-files-list (ydk-name-of found))
|
||||
:id ,id
|
||||
:category ,(ydk-category-of found)
|
||||
:saved-deck-list ,(select-ydk-deck)
|
||||
:saved-category-list ,(select-category))))
|
||||
(render-with-env #P"decks/index.html"
|
||||
`(:active "/decks"
|
||||
:saved-deck-list ,(select-ydk-deck)
|
||||
:saved-category-list ,(select-category)))))))
|
||||
|
||||
(defroute ("/decks/:id/view" :method :GET) (&key id)
|
||||
"Deck Viewer Main Route. Login Required. View YDK-DECK with YDK-DECK-BY-ID. Uses RENDER-YDK."
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(if found
|
||||
(render-ydk id #P"decks/index.html")
|
||||
(progn
|
||||
(flash-error (format nil (_ "No Deck ID ~d") id))
|
||||
(render-with-env #P"decks/index.html"
|
||||
`(:active "/decks"
|
||||
:saved-deck-list ,(select-ydk-deck)
|
||||
:saved-category-list ,(select-category)))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error (format nil "~a~%" e))
|
||||
(render-with-env #P"decks/index.html"
|
||||
`(:active "/decks"
|
||||
:saved-deck-list ,(select-ydk-deck)
|
||||
:saved-category-list ,(select-category)))))))
|
||||
|
||||
(defroute ("/decks/:id/generate-cover-images" :method :GET) (&key id)
|
||||
"Deck Viewer - Generate Cover Image. Login Required. Render a static image and display it with DECK-IMAGE-LISTING template."
|
||||
(v:info :decks "GET /decks/~d/generate-cover-images" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(if (draw-deck-image-by-id id)
|
||||
(ydk-listing-as id #P"decks/deck-image-listing.html")
|
||||
(_ "Something went wrong. Try again?")))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/decks/:id/delete-generated-images" :method :DELETE) (&key id)
|
||||
"Deck Viewer - Delete Generate Cover Image. Login Required."
|
||||
(v:info :decks "DELETE /decks/~d/delete-generated-images" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(when found
|
||||
(if (notany #'null
|
||||
(mapcar #'uiop:delete-file-if-exists
|
||||
(probe-image-files-list (ydk-name-of found) nil)))
|
||||
(flash-message (_ "Success!"))
|
||||
(flash-error (_ "Something went wrong. Try again?"))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/decks/:id/to-category" :method :POST) (&key id _parsed)
|
||||
"POST route to send deck ID to category ID."
|
||||
(v:info :decks "POST /decks/~d/to-category._parsed = ~a~%" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((cat-id (query-param "category-id" _parsed)))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id)
|
||||
(:integer cat-id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(when found
|
||||
(setf (ydk-category-of found)
|
||||
(find-dao 'category :id cat-id))
|
||||
(with-connection (db)
|
||||
(mito:save-dao found))
|
||||
(render-with-env #P"decks/category-select.html"
|
||||
`(:category-id ,(mito:object-id
|
||||
(ydk-category-of found))
|
||||
:deck-id ,(mito:object-id found)
|
||||
:categories ,(select-category))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))))
|
||||
|
||||
(defroute ("/decks/:id/rename" :method :POST) (&key id _parsed)
|
||||
"Deck Viewer - Rename deck ID with new name. Will also rename the generated image files, if they exist."
|
||||
(v:info :decks "GET /decks/~d/rename._parsed = ~a~%" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((name (query-param "name" _parsed)))
|
||||
;; We want to change the name of LOAD-NAME to CREATE-NAME.
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id)
|
||||
(:string name))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
;; Ahaha that was a fun hunt. Using YDK-DECK-RENAME
|
||||
;; before RENAME-FILES caused the OLD-NAME in
|
||||
;; RENAME-FILES to be NEW-NAME... Rename the files
|
||||
;; before renaming the database entry.
|
||||
(v:info :decks "RENAME ~a => ~a" (ydk-name-of found) name)
|
||||
(ydk-rename-files (ydk-name-of found) name)
|
||||
(ydk-rename-deck found name)
|
||||
(flash-message
|
||||
(format nil "Found entry ~A (~d); renaming to ~a.~%"
|
||||
(ydk-name-of found) id name))
|
||||
(redirect (format nil "/decks/~d/view" id) 302)))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e))))))
|
||||
|
||||
(defroute ("/decks/:id/pull" :method :GET) (&key id)
|
||||
"Pull deck ID using YDK-DECK-PULL-FROM-INVENTORY.
|
||||
|
||||
TODO I think This is outdated."
|
||||
(v:info :decks "GET /decks/~d/pull" id)
|
||||
|
||||
;; We want to "pull" the deck from inventory. That is, take the list
|
||||
;; of cards in the deck and remove them from the inventory count.
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
;; The deck exists by ID
|
||||
(when found
|
||||
(let ((pulled (ydk-deck-pull-from-inventory found)))
|
||||
(if pulled
|
||||
(progn
|
||||
(flash-message
|
||||
(format nil "Found entry ~A (~d); pulling cards.~%"
|
||||
(ydk-name-of found) id))
|
||||
(redirect (format nil "/construct/~d/view"
|
||||
(mito:object-id pulled))
|
||||
302))
|
||||
(flash-message
|
||||
(format nil "Unable to pull deck ~d?~%" id)))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/decks/cards-in-decks" :method :GET) (&key _parsed)
|
||||
"Route to display all the unique cards in all decks."
|
||||
(v:info :decks "GET /decks/cards-in-decks => ~a" _parsed)
|
||||
|
||||
(render #P"decks/cards-in-decks.html"
|
||||
(list :active "/decks"
|
||||
:table (cards-in-all-decks))))
|
||||
|
||||
(defroute ("/decks/:id/name" :method :GET) (&key id)
|
||||
"Route to display the name of the YDK-DECK by this ID.
|
||||
|
||||
TODO This should be a batch request."
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(let ((found (ydk-deck-by-id id)))
|
||||
(if found
|
||||
;; Deck names like "29036" are coming back as INTEGER
|
||||
;; which is causing issues with Caveman2. It seems to
|
||||
;; use REDUCE #'LENGTH to measure the content length.
|
||||
;; It didn't like: (LENGTH 29036)
|
||||
(princ-to-string (ydk-name-of found))
|
||||
(_ "No Name")))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/decks/by-category/:id" :method :GET) (&key id _parsed)
|
||||
"Query a list of decks by category."
|
||||
(v:info :decks "GET /decks/by-category/~d => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render #P"decks/decks-by-category.html"
|
||||
(list :active "/decks"
|
||||
:table (by-category 'ydk-deck id)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; All the various kinds of deck representations: HTML, HTML as Text,
|
||||
;; Text as Text Area, Resulting Deck File Images
|
||||
(defroute ("/decks/:id/html-listing" :method :GET) (&key id _parsed)
|
||||
"Helper route. Get the builder HTML listing using YDK-LISTING-AS and DECK-HTML-RESULTS template."
|
||||
(v:info :decks "GET /decks/~d/html-listing => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(ydk-listing-as id #P"decks/deck-html-results.html")))
|
||||
|
||||
(defroute ("/decks/:id/html-text-listing" :method :GET) (&key id _parsed)
|
||||
"Helper route. Get the HTML listing using YDK-LISTING-AS and DECK-TEXT-THREE-COLUMN template."
|
||||
(v:info :decks "GET /decks/~d/html-text-listing => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(ydk-listing-as id #P"decks/deck-text-three-column.html")))
|
||||
|
||||
(defroute ("/decks/:id/text-listing" :method :GET) (&key id _parsed)
|
||||
"Helper route. Get the text listing using YDK-LISTING-AS and DECK-TEXT-TEXTAREA template."
|
||||
(v:info :decks "GET /decks/~d/text-listing => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(ydk-listing-as id #P"decks/deck-text-textarea.html")))
|
||||
|
||||
(defroute ("/decks/:id/text-listing-with-brs" :method :GET) (&key id _parsed)
|
||||
"Helper route. Get the text listing using YDK-LISTING-AS and DECK-TEXT-TEXTAREA template with <brs>."
|
||||
(v:info :decks "GET /decks/~d/text-listing-with-brs => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(ydk-listing-as id #P"decks/deck-text-textarea-with-brs.html")))
|
||||
|
||||
(defroute ("/decks/:id/image-listing" :method :GET) (&key id _parsed)
|
||||
"Helper route. Get the image listing using YDK-LISTING-AS and DECK-IMAGE-LISTING template."
|
||||
(v:info :decks "GET /decks/~d/text-listing => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(ydk-listing-as id #P"decks/deck-image-listing.html")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/decks/:id/delete" :method :DELETE) (&key id)
|
||||
"Delete Deck by ID."
|
||||
(v:info :builder "DELETE /decks/:id/delete => ~a" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer id))
|
||||
(ydk-deck-delete-by-id id)
|
||||
(flash-message (format nil (_ "Deck ~a deleted success!" id))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))
|
||||
|
||||
(redirect "/decks")))
|
||||
|
||||
(defroute ("/decks/search" :method :GET) (&key _parsed)
|
||||
"Deck Viewer Search Main Route."
|
||||
(v:info :builder "GET /decks/search => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"decks/search.html"
|
||||
(list :active "/decks"))))
|
||||
|
||||
(defroute ("/decks/search" :method :POST) (&key _parsed)
|
||||
"Deck Viewer Search POST route.
|
||||
|
||||
TODO Ensure this is functional."
|
||||
(v:info :builder "GET /decks/search => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let* ((name (query-param "name" _parsed))
|
||||
(decks (select-ydk-deck
|
||||
(sxql:where (%sxql-like :name name)))))
|
||||
|
||||
(render-with-env #P"decks/search.html"
|
||||
(list :active "/decks"
|
||||
:decks decks)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; XXX Duplicate code from /builder/saved-deck-list
|
||||
(defroute ("/decks/deck-select" :method :GET) (&key |id|)
|
||||
"Deck Select Route Helper."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"decks/deck-select.html"
|
||||
(list :active "/decks"
|
||||
:id (ignore-errors
|
||||
(parse-integer |id|))
|
||||
:decks (select-ydk-deck)))))
|
||||
|
||||
(defroute ("/decks/category-select" :method :GET) (&key |deck-id| |category-id|)
|
||||
"Category Select Route Helper.
|
||||
TODO Return Sub-categories."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"decks/category-select.html"
|
||||
(list :active "/decks"
|
||||
:category-id (ignore-errors
|
||||
(parse-integer |category-id|))
|
||||
:deck-id (ignore-errors
|
||||
(parse-integer |deck-id|))
|
||||
:categories (select-category)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/decks/kde/:id" :method :GET) (&key id)
|
||||
"KDE Team Deck List Viewer. View Deck by ID"
|
||||
(render-with-env #P"kde-team.html"
|
||||
(ydk-to-kde
|
||||
(ydk-sync
|
||||
(ydk-deck-by-id id)))))
|
||||
15
src/web/exception.lisp
Normal file
15
src/web/exception.lisp
Normal file
@ -0,0 +1,15 @@
|
||||
#|
|
||||
|
||||
src/web/exception.lisp
|
||||
|
||||
Error Pages
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defmethod on-exception ((app <web>) (code (eql 404)))
|
||||
(declare (ignore app))
|
||||
(merge-pathnames #P"_errors/404.html"
|
||||
*template-directory*))
|
||||
49
src/web/flash-message.lisp
Normal file
49
src/web/flash-message.lisp
Normal file
@ -0,0 +1,49 @@
|
||||
(in-package #:cl-deck-builder2.web.flash-message)
|
||||
|
||||
(defvar *flash-messages* '())
|
||||
|
||||
(defclass flash-message ()
|
||||
((body :accessor flash-body-of
|
||||
:initarg :body)
|
||||
(class :accessor flash-class-of
|
||||
:initarg :class)
|
||||
(title :accessor flash-title-of
|
||||
:initarg :title)))
|
||||
|
||||
(defun flash (class title body)
|
||||
"Essentially HASH-TABLE-PUSH: helper function to PUSHNEW a VALUE associated with KEY to *SESSION* HASH-TABLE."
|
||||
(let ((obj (make-instance 'flash-message
|
||||
:class class
|
||||
:title title
|
||||
:body body)))
|
||||
(push obj *flash-messages*)
|
||||
(flash-body-of obj)))
|
||||
|
||||
(defun flash-gethash ()
|
||||
(let ((messages *flash-messages*))
|
||||
(setf *flash-messages* '())
|
||||
(reverse messages)))
|
||||
|
||||
;; error -> is-danger
|
||||
(defun flash-error (msg)
|
||||
(flash "is-danger" "Error" (princ-to-string msg)))
|
||||
|
||||
;; message -> is-success
|
||||
(defun flash-message (msg)
|
||||
(flash "is-success" "Success" (princ-to-string msg)))
|
||||
|
||||
;; info -> is-info
|
||||
(defun flash-info (title msg)
|
||||
(flash "is-info" title (princ-to-string msg)))
|
||||
|
||||
;; link -> is-link
|
||||
(defun flash-link (title msg)
|
||||
(flash "is-link" title (princ-to-string msg)))
|
||||
|
||||
;; primary -> is-primary
|
||||
(defun flash-primary (title msg)
|
||||
(flash "is-primary" title (princ-to-string msg)))
|
||||
|
||||
;; warning -> is-warning
|
||||
(defun flash-warning (msg)
|
||||
(flash "is-warning" "warning" (princ-to-string msg)))
|
||||
81
src/web/index.lisp
Normal file
81
src/web/index.lisp
Normal file
@ -0,0 +1,81 @@
|
||||
#|
|
||||
|
||||
src/web/index.lisp
|
||||
|
||||
Some static top-level routes.
|
||||
|
||||
If there isn't much to the page it probably appears here e.g. / /about /news
|
||||
|
||||
|#
|
||||
|
||||
(in-package :cl-deck-builder2.web)
|
||||
|
||||
(defroute index "/" ()
|
||||
"Main HTML index."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"index.html" `(:active "/"))))
|
||||
|
||||
;; (render-markdown
|
||||
;; (relative-pathname "doc/index.md")
|
||||
;; :title "Index" :env `(:active "/index"))
|
||||
|
||||
(defroute "/about" ()
|
||||
"About page."
|
||||
(with-logged-in-user
|
||||
(render-markdown
|
||||
(relative-pathname "doc/about.md")
|
||||
:title "About" :env `(:active "/about"))))
|
||||
|
||||
(defroute "/news" ()
|
||||
"News page. We use parse git log in toolkit/git.lisp."
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"news.html"
|
||||
`(:active "/news"
|
||||
:git-log ,(mapcar #'parse-git-log (git-log))))))
|
||||
|
||||
(defroute ("/todo" :method :GET) ()
|
||||
"To-Do list page. This is my personal professional todo list!"
|
||||
(with-logged-in-user
|
||||
(render-markdown
|
||||
(asdf:system-relative-pathname :cl-deck-builder2
|
||||
"doc/todo.md")
|
||||
:title "To-Do List"
|
||||
:env `(:active "/todo"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/markdown" :method :GET) (&key _parsed)
|
||||
"A utility URL to parse markdown files.
|
||||
|
||||
In a production environment you would probably want to disable this URL, as it could potentially allow an attacker to read arbitrary source files. That isn't a concern since we're running in a Docker container."
|
||||
(with-logged-in-user
|
||||
(let* ((path (query-param "path" _parsed))
|
||||
(pathspec (asdf:system-relative-pathname :cl-deck-builder2 path)))
|
||||
(alexandria:if-let ((extracted-title (ignore-errors
|
||||
(car (uiop:read-file-lines pathspec)))))
|
||||
(render-markdown pathspec :title extracted-title)
|
||||
(render-with-env #P"markdown.html" (list :title "Oops!" :html "Nothing to see here..."))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun extract-router-docs (app)
|
||||
"Courtesy of knobo: https://github.com/fukamachi/caveman/pull/108"
|
||||
(sort
|
||||
(mapcar (lambda (route)
|
||||
(list
|
||||
(myway.rule::rule-url (myway.route:route-rule route))
|
||||
(documentation (ningle.route:route-controller route) 'function)
|
||||
(car (map-set:ms-map 'list 'identity (myway.rule::rule-methods (myway.route:route-rule route))))
|
||||
(myway.rule::rule-param-keys (myway.route:route-rule route))))
|
||||
(myway:mapper-routes (ningle.app::mapper app)))
|
||||
#'string<
|
||||
:key #'car))
|
||||
|
||||
(defroute doc "/doc" (&key |org|)
|
||||
"This url shows this the documentation."
|
||||
(with-logged-in-user
|
||||
(let ((docs (extract-router-docs *web*))
|
||||
(tpl (if |org|
|
||||
#P"docs.md"
|
||||
#P"docs.html")))
|
||||
(render-with-env tpl
|
||||
`(:active "/doc"
|
||||
:docs ,docs)))))
|
||||
244
src/web/inventory.lisp
Normal file
244
src/web/inventory.lisp
Normal file
@ -0,0 +1,244 @@
|
||||
#|
|
||||
|
||||
src/web/inventory.lisp
|
||||
|
||||
Crystal Commerce-style Inventory Management User Interface and helpers.
|
||||
|
||||
TODO pass over the results of (make-search-query) such that
|
||||
:total-qty is the aggregate of:
|
||||
|
||||
(select 'ygo-cc-item (where (:= :item_id xxx)))
|
||||
|
||||
(reduce #'+
|
||||
(mapcar (alexandria:compose #'read-from-string #'cc-sell-price-of)
|
||||
(retrieve-dao 'ygo-cc-item :item-id 48883)))
|
||||
|
||||
(reduce #'+ (mapcar #'cc-qty-of (retrieve-dao 'ygo-cc-item :item-id 48883)))
|
||||
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defun render-results (&key (active "/inventory") (class 'cc-item) (params nil) (tpl #P"inventory/search-results.html"))
|
||||
"Mega helper function. Render function for anything that currently queries the databse. We search both PRODUCT-NAME and NAME, as well as querying a list of VARIANTs, with a LIMIT on the number of results and an OFFSET into those search results. You may also specify a DIRECTION, and SORT-BY options.
|
||||
|
||||
TODO Major rewrite candidate right here.
|
||||
TODO Integrate new SEARCH-SESSION object after that's done."
|
||||
(let ((direction (or (query-param "direction" params) "desc"))
|
||||
(variant (or (query-param "variant" params)
|
||||
(find-dao 'variant-condition :name "Near Mint")))
|
||||
(variants (select-variant-condition))
|
||||
(limit (or (query-param "limit" params) "10"))
|
||||
(name (or
|
||||
(query-param "name" params)
|
||||
(query-param "product-name" params)))
|
||||
(offset (or (query-param "offset" params) "0"))
|
||||
(sort-by (or (query-param "sort-by" params) "id")))
|
||||
(handler-case
|
||||
(ratify:with-parsed-forms
|
||||
((:integer limit)
|
||||
(:integer offset)
|
||||
(:string direction)
|
||||
(:string sort-by))
|
||||
;; NAME can be blank, so...
|
||||
(let* ((filtered-cards (make-search-query class params))
|
||||
(length (make-count-query class params))
|
||||
(pages (generate-pages length offset limit)))
|
||||
(render-with-env tpl
|
||||
`(:active ,active
|
||||
:cards ,filtered-cards
|
||||
:direction ,direction
|
||||
:last-page ,(car (last pages))
|
||||
:length ,length
|
||||
:limit ,limit
|
||||
:name ,name
|
||||
:offset ,offset
|
||||
:opposite-direction ,(get-opposite-direction direction)
|
||||
:pages ,pages
|
||||
:search-params ,+search-params+
|
||||
:sort-by ,sort-by
|
||||
:total ,(count-dao class)
|
||||
:variant ,variant
|
||||
:variants ,variants))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error (format nil "~a/search.error => ~a~%" active e))))))
|
||||
|
||||
;; USE REINITIALIZE-INSTANCE to update the existing YGO-SET-ITEM from _PARSED
|
||||
(defun patch-card (card _parsed)
|
||||
(let ((set-id (query-param "set-id" card))
|
||||
(variant-id (query-param "variant-id" card)))
|
||||
(handler-case
|
||||
(ratify-parsing:with-parsed-forms
|
||||
((:integer set-id)
|
||||
(:integer variant-id))
|
||||
(let ((found (find-or-create-instance 'ygo-set-item :item-id set-id :variant-id variant-id))
|
||||
(clean (filter-alist _parsed)))
|
||||
(v:info :inventory "PATCH-CARD: ~a" found)
|
||||
(if found
|
||||
;; TODO redraw item based on context? Like patching from the inventory list vs patching from the editor?
|
||||
;; (redirect (format nil "/inventory/~d/edit" (mito:object-id found)) 303)
|
||||
(progn
|
||||
(apply #'reinitialize-instance found (assoc-utils:alist-plist clean))
|
||||
(update-dao found)
|
||||
(_ "Save"))
|
||||
(progn
|
||||
(flash-error (format nil "Error udpating id ~d:~d" set-id variant-id))))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Inventory Viewer
|
||||
(defroute ("/inventory" :method :GET) (&key _parsed)
|
||||
"Inventory Viewer GET route. Will display index with search results."
|
||||
(v:info :inventory "GET /inventory ~a" _parsed)
|
||||
|
||||
;; (with-logged-in-user
|
||||
;; (render-results :params _parsed :tpl #P"inventory/index.html"))
|
||||
(redirect "/cards"))
|
||||
|
||||
#|
|
||||
(defroute ("/inventory" :method :POST) (&key _parsed)
|
||||
"Inventory Viewer search POST route. Will display index with search results."
|
||||
(v:info :inventory "POST /inventory ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :params _parsed :tpl #P"inventory/index.html")))
|
||||
|
||||
(defroute ("/inventory/search" :method :POST) (&key _parsed)
|
||||
"Inventory Viewer search POST route. Will display index with search results."
|
||||
(v:info :inventory "POST /inventory/search ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(render-results :params _parsed)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Inventory Item Editor
|
||||
;;
|
||||
;; TODO PUT?? POST?? GET??
|
||||
|
||||
;; New Item
|
||||
(defroute ("/inventory/new" :method :GET) ()
|
||||
"Display the page for creation of a new inventory item"
|
||||
(v:info :inventory "GET /inventory/new")
|
||||
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"inventory/new.html"
|
||||
`(:active "/inventory"
|
||||
:card ,(make-instance 'cc-item)))))
|
||||
|
||||
(defroute ("/inventory/new" :method :POST) (&key _parsed)
|
||||
"POST method for the processing the information from page for creation of a new inventory item."
|
||||
(v:info :inventory "POST /inventory/new => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(let ((clean (filter-alist _parsed)))
|
||||
(let ((new (apply #'cc-create (assoc-utils:alist-plist clean))))
|
||||
(when (mito:object-id new)
|
||||
(redirect (format nil "/inventory/~d/edit" (mito:object-id new))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Inventory Item Importer
|
||||
(defroute ("/inventory/import" :method :GET) ()
|
||||
"Inventory Item Importer. TODO"
|
||||
(v:info :inventory "GET /inventory/import")
|
||||
|
||||
(with-logged-in-user
|
||||
(render-with-env #P"inventory/import.html"
|
||||
`(:active "/inventory"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Seems like this one needs to be last. It has something to do with
|
||||
;; the wildcard :ID parameter. Maybe we ought to add the /edit back?
|
||||
|
||||
(defroute ("/inventory/:id/edit" :method :GET) (&key id)
|
||||
"Edit Route for Inventory Item.
|
||||
|
||||
ARGUMENTS
|
||||
ID The ID of the CC-ITEM inventory item you wish to edit."
|
||||
(v:info :inventory "GET /inventory/~d/edit" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify-parsing:with-parsed-forms
|
||||
((:integer id))
|
||||
(render-with-env #P"inventory/edit.html"
|
||||
`(:active "/inventory"
|
||||
:errors ,(flash-gethash :errors)
|
||||
:messages ,(flash-gethash :messages)
|
||||
:card ,(cc-select-by-id id))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/inventory/:id/edit" :method :POST) (&key id _parsed)
|
||||
"CC-ITEM Update POST route. If the item exists, update it using REINITIALIZE-INSTANCE, after filtering _PARSED through FILTER-ALIST.
|
||||
|
||||
TODO Differentiate between CC-ITEM and YGO-CC-ITEM?"
|
||||
(v:info :inventory "POST /inventory/~d/edit => ~a" id _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify-parsing:with-parsed-forms
|
||||
((:integer id))
|
||||
(with-connection (db)
|
||||
(let ((found (mito:find-dao 'cc-item :id id))
|
||||
(clean (filter-alist _parsed)))
|
||||
(when found
|
||||
(apply #'reinitialize-instance found (assoc-utils:alist-plist clean))
|
||||
(mito:save-dao found)
|
||||
(redirect (format nil "/inventory/~d/edit" (mito:object-id found)) 303)))))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|
||||
(defroute ("/inventory/:id/delete" :method :DELETE) (&key id)
|
||||
"DELETE an Inventory Item specified by ID."
|
||||
(v:info :inventory "DELETE /inventory/~d/delete" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify-parsing:with-parsed-forms
|
||||
((:integer id))
|
||||
(cc-delete-by-id id))
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
|#
|
||||
|
||||
(defroute ("/inventory/patch" :method :PATCH) (&key _parsed)
|
||||
"YGO-CC-ITEM PATCH route. This appears to be functionally identical to EDIT route for ID, but this is using YGO-CC-ITEM as class. The POST route appears to be used for CC-ITEM object."
|
||||
(v:info :inventory "PATCH /inventory/patch => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(alexandria:if-let ((cards (query-param "cards" _parsed)))
|
||||
(dolist (card cards)
|
||||
(patch-card card _parsed))
|
||||
(patch-card _parsed _parsed))))
|
||||
|
||||
;; Huh? It works??
|
||||
(defroute ("/inventory/variants/:id" :method :GET) (&key id)
|
||||
"Display the VARIANTs for this inventory item using SELECT-YGO-CC-ITEM-VARIANTS."
|
||||
(v:info :inventory "GET /inventory/variants/~d" id)
|
||||
|
||||
(with-logged-in-user
|
||||
(handler-case
|
||||
(ratify-parsing:with-parsed-forms
|
||||
((:integer id))
|
||||
(render-with-env #P"inventory/variant-results.html"
|
||||
(list :active "/inventory"
|
||||
:id id
|
||||
:cards (select-ygo-cc-item-variants id))))
|
||||
;; :cards ,filtered-cards
|
||||
;; :variant ,variant
|
||||
;; :variants ,variants
|
||||
;; :direction ,direction
|
||||
;; :length ,length
|
||||
;; :total ,(count-dao class)
|
||||
;; :limit ,limit
|
||||
;; :name ,name
|
||||
;; :offset ,offset
|
||||
;; :opposite-direction ,(get-opposite-direction direction)
|
||||
;; :pages ,(generate-pages length offset limit)
|
||||
;; :search-params ,+search-params+
|
||||
;; :sort-by ,sort-by)
|
||||
|
||||
(ratify:combined-error (e)
|
||||
(flash-error e)))))
|
||||
171
src/web/label-maker.lisp
Normal file
171
src/web/label-maker.lisp
Normal file
@ -0,0 +1,171 @@
|
||||
#|
|
||||
|
||||
src/web/label-maker.lisp
|
||||
|
||||
Label Maker Front-End
|
||||
|
||||
https://www.uline.com/product/detail/s-20247/store-fixtures/price-tag-insert-cards-1-1-4-x-2
|
||||
|
||||
Supports arbitrary number of labels.
|
||||
Currently tested with LABELS-LENGTH set to 32 (ULINE S-20247) or 30 (Avery 5160).
|
||||
|
||||
We generate a LaTeX file then use PDFLaTeX to produce a pdf in
|
||||
GENERATE-LABELS-FOR-ATTACHMENT-ID.
|
||||
|
||||
The barcodes are generated by ZXingWriter.
|
||||
|
||||
TODO A lot of functionality that resides in the web interface needs to be moved to the model interface:
|
||||
- public-relative-pathname
|
||||
- generate-labels
|
||||
- generate-labels-for-attachment
|
||||
- generate-labels-for-attachment-id
|
||||
- *current-label-class*
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-deck-builder2.web.label-maker
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.models.label-maker)
|
||||
(:import-from #:caveman2
|
||||
#:<app>
|
||||
#:defroute
|
||||
#:redirect
|
||||
#:clear-routing-rules)
|
||||
(:import-from #:cl-deck-builder2.i18n
|
||||
#:_)
|
||||
(:import-from #:cl-deck-builder2.toolkit
|
||||
#:query-param
|
||||
#:random-pathname-name)
|
||||
(:import-from #:cl-deck-builder2.web
|
||||
#:flash-error
|
||||
#:flash-message
|
||||
#:render-with-env
|
||||
#:render-markdown-file)
|
||||
(:import-from #:cl-deck-builder2.web.query
|
||||
#:select-attachment-by-id)
|
||||
(:import-from #:cl-deck-builder2.models.attachment
|
||||
#:attachment-valid-p
|
||||
#:create-attachment)
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:*public-directory*
|
||||
#:*static-directory*
|
||||
#:*template-directory*)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:export #:*web*))
|
||||
|
||||
(in-package #:cl-deck-builder2.web.label-maker)
|
||||
|
||||
(defclass <web> (<app>) ())
|
||||
(defvar *web* (make-instance '<web>))
|
||||
(clear-routing-rules *web*)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defparameter *base-pathspec* #P"/tmp/labels/")
|
||||
|
||||
(defparameter *current-label-class* 'latex-label-uline-s-20247
|
||||
"The most recently used class for making labels.
|
||||
|
||||
The idea was you could select the types of labels from a select box on the Label Maker page.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun public-relative-pathname (pathspec)
|
||||
"PROBE-FILE on PATHSPEC in *PUBLIC-DIRECTORY*.
|
||||
|
||||
TODO I think this is duplicate code from TOOLKIT.PATHS."
|
||||
(probe-file
|
||||
(merge-pathnames
|
||||
pathspec
|
||||
cl-deck-builder2.config:*public-directory*)))
|
||||
|
||||
;; TODO All of this needs to be rewritten in some kind of pipeline form.
|
||||
(defun generate-labels (output &key (class 'latex-label-uline-s-20247) csv pdf tex)
|
||||
"Create output with RENDER-PAGE."
|
||||
(ensure-directories-exist *base-pathspec*)
|
||||
(let ((page (make-instance class :csv csv)))
|
||||
(with-open-file (s tex
|
||||
:if-exists :supersede
|
||||
:direction :output)
|
||||
(format s "~a" (render-page page))))
|
||||
|
||||
(uiop:delete-file-if-exists (probe-file #P"~/public/labels.pdf"))
|
||||
(if (inferior-shell:run
|
||||
`(and
|
||||
(cd "/tmp/labels/")
|
||||
(pdflatex ,tex)
|
||||
(mv ,pdf ,output)))
|
||||
output))
|
||||
|
||||
;; TODO ENOUGH-PATHNAME
|
||||
;; TODO rewrite this using defclass like we did for CARDINFO
|
||||
(defun generate-labels-for-attachment (path file-key)
|
||||
(generate-labels (make-pathname :name file-key
|
||||
:type "pdf"
|
||||
:directory (namestring *public-directory*))
|
||||
:class *current-label-class*
|
||||
:csv path
|
||||
:tex #P"/tmp/labels/labels.tex"
|
||||
:pdf #P"/tmp/labels/labels.pdf"))
|
||||
|
||||
(defun generate-labels-for-attachment-id (id)
|
||||
(let ((found (select-attachment-by-id id)))
|
||||
(when found
|
||||
(generate-labels-for-attachment
|
||||
(public-relative-pathname
|
||||
(;; Trim leading "/"
|
||||
subseq
|
||||
(namestring (mito-attachment:file-url found)) 1))
|
||||
(pathname-name
|
||||
(mito-attachment:file-key found))))))
|
||||
|
||||
(defun label-maker-process-files (files)
|
||||
"Process FILES with ATTACHMENT-VALID-P, CREATE-ATTACHMENT, then GENERATE-LABELS-FOR-ATTACHMENT-ID."
|
||||
(dolist (file files)
|
||||
(if (attachment-valid-p file)
|
||||
(destructuring-bind (content filename content-type)
|
||||
file
|
||||
|
||||
(setf filename (random-pathname-name :type (pathname-type filename)))
|
||||
|
||||
(let ((success (create-attachment content filename content-type)))
|
||||
(if success
|
||||
(progn
|
||||
;; Create ATTACHMENT was successful
|
||||
(generate-labels-for-attachment-id (mito:object-id success))
|
||||
(flash-message (format nil (_ "Success! Download link: <a href=\"/public/~a.pdf\">labels.pdf</a>")
|
||||
(pathname-name
|
||||
(mito-attachment:file-key success)))))
|
||||
(flash-error (_ "Something went wrong. Try again?")))))
|
||||
(flash-error (_ "Invalid upload.")))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/" :method :GET) ()
|
||||
"Label Maker Main Route."
|
||||
(render-with-env #P"label-maker.html"
|
||||
`(:active "/label-maker")))
|
||||
|
||||
(defroute ("/instructions" :method :GET) ()
|
||||
"Display Label Maker Instructions using RENDER-MARKDOWN-FILE."
|
||||
(render-markdown-file
|
||||
(asdf:system-relative-pathname :cl-deck-builder2 "doc/label-maker.md")))
|
||||
|
||||
(defroute ("/" :method :POST) (&key _parsed)
|
||||
"Label Maker POST route.
|
||||
|
||||
TODO Parameters: FILES A list of CSV files to process. CLASS the class of label you wish to generate. May be one of LATEX-LABEL-ULINE-S-20247 or LATEX-LABEL-AVERY-5160."
|
||||
(v:info :label-maker "POST /label-maker => ~a" _parsed)
|
||||
|
||||
(let ((files (query-param "files" _parsed))
|
||||
(class (query-param "class" _parsed)))
|
||||
|
||||
;; Check the CLASS parameter
|
||||
(setf *current-label-class*
|
||||
(find-class
|
||||
(cond ((string= class "latex-label-uline-s-20247") 'latex-label-uline-s-20247)
|
||||
(t 'latex-label-avery-5160))))
|
||||
|
||||
(if files
|
||||
(label-maker-process-files files)
|
||||
(flash-error (_ "No files.")))
|
||||
(redirect "/label-maker")))
|
||||
64
src/web/packages.lisp
Normal file
64
src/web/packages.lisp
Normal file
@ -0,0 +1,64 @@
|
||||
;;;; src/web/package.lisp
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.web.flash-message
|
||||
(:use #:cl)
|
||||
(:export #:flash
|
||||
#:flash-gethash
|
||||
#:flash-error
|
||||
#:flash-message))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.web.query
|
||||
(:use #:cl
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models)
|
||||
(:export #:%sxql-like
|
||||
|
||||
#:select-attachment
|
||||
#:select-category
|
||||
#:select-constructed-deck-items
|
||||
#:select-constructed-decks
|
||||
#:select-deck-item
|
||||
#:select-feedback
|
||||
#:select-ydk-deck
|
||||
|
||||
#:cards-in-all-decks
|
||||
#:select-attachment-by-id
|
||||
#:select-variant-condition
|
||||
#:select-ygo-cc-item-variants
|
||||
#:ygo-select-info-by-id
|
||||
#:ygo-select-info-by-passcode
|
||||
#:ygo-set-item-by-id
|
||||
#:ygo-set-item-by-item-id))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defpackage #:cl-deck-builder2.web
|
||||
(:use #:cl
|
||||
#:caveman2
|
||||
#:cl-deck-builder2.db
|
||||
#:cl-deck-builder2.models
|
||||
#:cl-deck-builder2.i18n
|
||||
#:cl-deck-builder2.toolkit
|
||||
#:cl-deck-builder2.web.query
|
||||
#:cl-deck-builder2.web.flash-message)
|
||||
(:local-nicknames (#:v #:org.shirakumo.verbose))
|
||||
(:import-from #:cl-deck-builder2.config
|
||||
#:*public-directory*
|
||||
#:*static-directory*
|
||||
#:*template-directory*)
|
||||
(:import-from #:cl-deck-builder2.draw
|
||||
#:draw-deck-image)
|
||||
(:import-from #:cl-deck-builder2.view #:render)
|
||||
(:import-from #:hermetic
|
||||
#:setup
|
||||
#:login
|
||||
#:logged-in-p
|
||||
#:user-name
|
||||
#:logout
|
||||
#:auth)
|
||||
(:export #:*web*
|
||||
#:make-chat-client
|
||||
#:make-chat-server))
|
||||
146
src/web/params.lisp
Normal file
146
src/web/params.lisp
Normal file
@ -0,0 +1,146 @@
|
||||
#|
|
||||
|
||||
Various constants or parameters used around the web interface
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; builder.lisp
|
||||
|
||||
(defparameter +main-deck-card-limit+ 60)
|
||||
|
||||
(defparameter +extra-deck-card-limit+ 15)
|
||||
|
||||
(defparameter +search-params+
|
||||
'(:ATTRIBUTE ("DARK" "DIVINE" "EARTH" "FIRE" "LIGHT" "WATER" "WIND")
|
||||
:TYPE
|
||||
("Effect Monster" "Flip Effect Monster" "Fusion Monster"
|
||||
"Gemini Monster" "Link Monster" "Normal Monster"
|
||||
"Normal Tuner Monster" "Pendulum Effect Fusion Monster"
|
||||
"Pendulum Effect Monster" "Pendulum Effect Ritual Monster"
|
||||
"Pendulum Flip Effect Monster" "Pendulum Normal Monster"
|
||||
"Pendulum Tuner Effect Monster" "Ritual Effect Monster"
|
||||
"Ritual Monster" "Skill Card" "Spell Card" "Spirit Monster"
|
||||
"Synchro Monster" "Synchro Pendulum Effect Monster"
|
||||
"Synchro Tuner Monster" "Token" "Toon Monster" "Trap Card"
|
||||
"Tuner Monster" "Union Effect Monster" "XYZ Monster"
|
||||
"XYZ Pendulum Effect Monster")
|
||||
:RACE
|
||||
("Abidos the Third" "Adrian Gecko" "Alexis Rhodes" "Amnael" "Andrew"
|
||||
"Aqua" "Arkana" "Aster Phoenix" "Axel Brodie" "Bastion Misaw" "Beast"
|
||||
"Beast-Warrior" "Bonz" "Camula" "Chazz Princet" "Christine" "Chumley Huffi"
|
||||
"Continuous" "Counter" "Creator-God" "Cyberse" "David"
|
||||
"Dinosaur" "Divine-Beast" "Don Zaloog" "Dr. Vellian C" "Dragon" "Emma"
|
||||
"Equip" "Espa Roba" "Fairy" "Field" "Fiend" "Fish" "Illusionist"
|
||||
"Insect" "Ishizu" "Ishizu Ishtar" "Jaden Yuki" "Jesse Anderso" "Joey"
|
||||
"Joey Wheeler" "Kagemaru" "Kaiba" "Keith" "Lumis and Umb" "Lumis Umbra"
|
||||
"Machine" "Mai" "Mai Valentine" "Mako" "Nightshroud" "Normal"
|
||||
"Odion" "Paradox Broth" "Pegasus" "Plant" "Psychic" "Pyro"
|
||||
"Quick-Play" "Reptile" "Rex" "Ritual" "Rock" "Sea Serpent" "Seto Kaiba"
|
||||
"Spellcaster" "Syrus Truesda" "Tania" "Tea Gardner" "The Supreme K"
|
||||
"Thelonious Vi" "Thunder" "Titan" "Tyranno Hassl" "Warrior"
|
||||
"Weevil" "Winged Beast" "Wyrm" "Yami Bakura" "Yami Marik" "Yami Yugi"
|
||||
"Yubel" "Yugi" "Zane Truesdal" "Zombie")
|
||||
:FRAME-TYPE
|
||||
("effect" "effect_pendulum" "fusion" "fusion_pendulum" "link"
|
||||
"normal" "normal_pendulum" "ritual" "ritual_pendulum" "skill" "spell"
|
||||
"synchro" "synchro_pendulum" "token" "trap" "xyz" "xyz_pendulum")
|
||||
:ARCHETYPE
|
||||
("\"C\"" "-Eyes Dragon" "@Ignister" "A.I." "ABC" "Abyss Actor" "Abyss Script"
|
||||
"Adamancipator" "Advanced Crystal Beast" "Adventurer Token" "Aesir" "Aether"
|
||||
"Albaz Dragon" "Alien" "Alligator" "Allure Queen" "Ally of Justice"
|
||||
"Altergeist" "Amazement" "Amazoness" "Amorphage" "Ancient Gear"
|
||||
"Ancient Treasure" "Ancient Warriors" "Anti" "Apoqliphort" "Appliancer"
|
||||
"Aquaactress" "Aquamirror" "Arcana Force" "Archfiend" "Armed Dragon" "Aroma"
|
||||
"Artifact" "Assault Mode" "Atlantean" "Attraction" "Attribute Summoner"
|
||||
"B.E.S." "Bamboo Sword" "Barbaros" "Barian's" "Batteryman" "Battleguard"
|
||||
"Battlewasp" "Battlin' Boxer" "Battlin' Boxing" "Beetrooper"
|
||||
"Black Luster Soldier" "Blackwing" "Blaze Accelerator" "Blue-Eyes" "Bonding"
|
||||
"Book of" "Boot-Up" "Borrel" "Bounzer" "Branded" "Bridge" "Bugroth" "Bujin"
|
||||
"Burning Abyss" "Butterfly" "Butterspy" "Bystial" "Cataclysmic"
|
||||
"Celtic Guard" "Chaos" "Chaos Phantom" "Charmer" "Chemicritter" "Chronomaly"
|
||||
"Chrysalis" "Cipher" "Clear Wing" "Cloudian" "Code Talker" "Codebreaker"
|
||||
"Constellar" "Contact" "Cosmic Synchro Monster" "Counter Fairy" "Crusadia"
|
||||
"Crystal" "Crystal Beast" "Crystron" "Cubic" "Cupid" "CXyz" "Cyber"
|
||||
"Cyber Angel" "Cyber Dragon" "Cyberdark" "Cynet" "D.D." "D/D" "D/D/D"
|
||||
"Danger!" "Dark Contract" "Dark Magician" "Dark Scorpion" "Dark World"
|
||||
"Darklord" "Deep Sea" "Demise" "Deskbot" "Despia" "Destiny HERO"
|
||||
"Destruction Sword" "Dice" "Digital Bug" "Dinomist" "Dinomorphia"
|
||||
"Dinowrestler" "Divine Dragon" "Djinn" "Dododo" "Dogmatika" "Doll"
|
||||
"Doodle Beast" "Doodlebook" "Doriado" "Dracoslayer" "Dracoverlord"
|
||||
"Dragonmaid" "Dragunity" "Dream Mirror" "Drytron" "Dual Avatar" "Duston"
|
||||
"Earthbound" "Edge Imp" "Egyptian God" "Eldlich" "Elemental HERO"
|
||||
"Elemental Lord" "Elementsaber" "Empowered Warrior" "Endymion" "Evil Eye"
|
||||
"Evil HERO" "Evil★Twin" "Evolsaur" "Evoltile" "Evolzar"
|
||||
"Exchange of the Spirit" "Exodia" "Exosister" "Eyes Restrict" "F.A." "Fabled"
|
||||
"Fairy" "Fairy Tail" "Fire Fist" "Fire Formation" "Fire King" "Firewall"
|
||||
"Fishborg" "Flamvell" "Fleur" "Floowandereeze" "Flower Cardian" "Fluffal"
|
||||
"Forbidden" "Fortune Fairy" "Fortune Lady" "Fossil" "Frightfur" "Frog"
|
||||
"From the Underworld" "Fur Hire" "Fusion" "G Golem" "Gadget" "Gagaga"
|
||||
"Gaia Knight" "Gaia The Fierce Knight" "Galaxy" "Galaxy-Eyes" "Gandora"
|
||||
"Gate Guardian" "Geargia" "Gem-" "Generaider" "Genex" "Ghostrick" "Ghoti"
|
||||
"Gimmick Puppet" "Gishki" "Gizmek" "Glacial Beast" "Gladiator Beast" "Gogogo"
|
||||
"Gold Pride" "Golden Castle of Stromberg" "Golden Land" "Gorgonic" "Gouki"
|
||||
"Gravekeeper's" "Graydle" "Greed" "Grepher" "Guardian" "Guardragon" "Gunkan"
|
||||
"Gusto" "Harpie" "Hazy" "Hellfire" "Herald" "Heraldic" "Heraldry" "HERO"
|
||||
"Heroic" "Hi-Speedroid" "Hieratic" "Hole" "Holy Knight"
|
||||
"Horus the Black Flame Dragon" "Hyperion" "Ice Barrier" "Icejade" "Igknight"
|
||||
"Impcantation" "Infernity" "Infernoble Knight" "Infernoid" "Infestation"
|
||||
"Infinitrack" "Invoked" "Inzektor" "Iron Chain" "Jar" "Jester" "Jinzo" "Junk"
|
||||
"Jurrac" "Kaiju" "Kairyu-Shin" "Karakuri" "Kashtira" "Knight" "Knightmare"
|
||||
"Koa'ki Meiru" "Koala" "Kozmo" "Krawler" "Kuriboh" "Labrynth"
|
||||
"Labyrinth Wall" "Lady of Lament" "Laval" "Legendary Knight" "Libromancer"
|
||||
"Lightsworn" "Lil-la" "Live☆Twin" "Lswarm" "Lunalight" "Lyrilusc" "Machina"
|
||||
"Madolche" "Madoor" "Magical Musket" "Magician" "Magician Girl" "Magikey"
|
||||
"Magistus" "Magnet Warrior" "Majespecter" "Majestic" "Maju" "Malefic"
|
||||
"Malicevorous" "Man-Eater Bug" "Manadome" "Marincess" "Martial Art Spirit"
|
||||
"Mask" "Masked HERO" "Materiactor" "Mathmech" "Mayakashi" "Mayakashi Shiranui"
|
||||
"Mecha Phantom Beast" "Megalith" "Mekk-Knight" "Meklord" "Melffy" "Melodious"
|
||||
"Mermail" "Metalfoes" "Metaphys" "Mikanko" "Mist Valley" "Mokey Mokey"
|
||||
"Monarch" "Morphtronic" "Mystical Beast of the Forest" "Myutant" "Naturia"
|
||||
"Nekroz" "Nemeses" "Nemleria" "Nemurelia" "Neo Space" "Neo-Spacian" "Neos"
|
||||
"Nephthys" "Nimble" "Ninja" "Ninjitsu Art" "Noble Knight" "Nordic"
|
||||
"Nouvellez" "Number" "Numeron" "Odd-Eyes" "Ogdoadic" "Ojama" "Onomat"
|
||||
"Orcust" "Overlay" "P.U.N.K." "Paladins of Dragons" "Paleozoic" "Parasite"
|
||||
"Parshath" "Pendulum" "Pendulum Dragon" "Penguin" "Performage" "Performapal"
|
||||
"Phantasm Spiral" "Phantom Beast" "Phantom Knights" "Photon"
|
||||
"Plunder Patroll" "Polymerization" "Possessed" "Potan" "Power Tool"
|
||||
"Prank-Kids" "Predaplant" "Prediction Princess" "Priestess" "PSY-Frame"
|
||||
"Puppet" "Purrely" "Qli" "Raidraptor" "Rank-Up-Magic" "Recipe" "Red-Eyes"
|
||||
"Reptilianne" "Rescue-ACE" "Resonator" "Rikka" "Ritual Beast" "Roid" "Rokket"
|
||||
"Roland" "Rose" "Rose Dragon" "Runick" "S-Force" "Sacred Beast"
|
||||
"Salamangreat" "Scareclaw" "Scrap" "Scrap-Iron" "Secret Six Samurai"
|
||||
"Seven Emperors" "Seventh" "Shaddoll" "Shark" "Shinobird" "Shiranui"
|
||||
"Silent Magician" "Silent Swordsman" "Simorgh" "Six Samurai" "Skull Servant"
|
||||
"Sky Scourge" "Sky Striker" "Slime" "Solemn" "Solfachord" "Speedroid"
|
||||
"Spellbook" "Sphinx" "Spider" "Spirit Message" "Spiritual Art" "Spright"
|
||||
"Springans" "SPYRAL" "Star" "Star Seraph" "Stardust" "Starliege"
|
||||
"Starry Knight" "Stealth Kragen" "Steelswarm" "Stellarknight" "Subterror"
|
||||
"Sunavalon" "Sunseed" "Sunvine" "Super Defense Robot" "Super Quant"
|
||||
"Superheavy" "Superheavy Samurai" "Supreme King" "Swordsoul" "Sylvan"
|
||||
"Symphonic" "Symphonic Warrior" "Synchro" "Synchron" "T.G." "Tearlaments"
|
||||
"Tellarknight" "Tenyi" "The Agent" "The Sanctuary in the Sky" "The Weather"
|
||||
"Therion" "Thunder Dragon" "Time Thief" "Timelord" "Tindangle" "Toon" "Train"
|
||||
"Transcendrake" "Trap Hole" "Trap Monster" "Traptrix" "Tri-Brigade" "Triamid"
|
||||
"Trickstar" "True Draco" "U.A." "Umbral Horror" "Umi" "Unchained" "Ursarctic"
|
||||
"Utopia" "Utopic" "Valkyrie" "Vampire" "Vanquish Soul" "Vassal" "Vaylantz"
|
||||
"Vendread" "Venom" "Vernusylph" "Virtual World" "Visas" "Vision HERO" "Void"
|
||||
"Volcanic" "Vylon" "War Rock" "Watt" "White" "Wicked God" "Wind-Up"
|
||||
"Windwitch" "Witchcrafter" "World Chalice" "World Legacy" "Worm" "X-Saber"
|
||||
"Xyz" "Yang Zing" "Yosenju" "Yubel" "Zefra" "ZEXAL" "Zoodiac")
|
||||
;; Card Rarity - Not in use at the moment.
|
||||
:RARITY
|
||||
("10000 Secret Rare" "Collector's Rare" "Common" "Ghost/Gold Hybrid Rare"
|
||||
"Ghost Rare" "Gold Rare" "Gold Secret Rare" "Mosaic Rare" "Parallel Rare"
|
||||
"Platinum Rare" "Platinum Secret Rare" "Premium Gold Rare" "Prismatic Secret Rare"
|
||||
"Quarter Century Secret Rare" "Rare" "Rare Parallel Rare" "Rush Rare"
|
||||
"Secret Pharaoh's Rare" "Secret Rare" "Shatterfoil" "Starfoil Rare"
|
||||
"Starlight Rare" "Super Parallel Rare" "Super Rare" "Ultimate Rare"
|
||||
"Ultra Parallel Rare" "Ultra Pharaoh's Rare" "Ultra Rare")
|
||||
:LIMIT
|
||||
("10" "50" "100" "1000" "2000")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; search.lisp
|
||||
41
src/web/qr.lisp
Normal file
41
src/web/qr.lisp
Normal file
@ -0,0 +1,41 @@
|
||||
#|
|
||||
|
||||
src/web/qr.lisp
|
||||
|
||||
QR Generator
|
||||
|
||||
New style web page with DEFCLASS brings some challenges: APPLY
|
||||
#'FN e.g. MAKE-INSTANCE usually expects a PLIST e.g. :SLOT VALUE,
|
||||
however, rendering with HTMX/HTML will require (SYMBOL-VALUE
|
||||
:SLOT) e.g. "8-BIT-BYTE" which makes matching them up
|
||||
tricky. Perhaps this is a solved problem.
|
||||
|
||||
|#
|
||||
|
||||
(in-package #:cl-deck-builder2.web)
|
||||
|
||||
(defparameter *qr-settings* (make-instance 'qr-settings)
|
||||
"The saved settings for the QR module.")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defroute ("/qr" :method :GET) ()
|
||||
"QR Generator Main Route. Display the index page. Login Required."
|
||||
(v:info :qr "GET /qr")
|
||||
|
||||
(with-logged-in-user
|
||||
(setf (getf (response-headers *response*) :cache-control) "no-cache, must-revalidate")
|
||||
(render-with-env #P"qr.html"
|
||||
(append
|
||||
(list :active "/qr")
|
||||
(qr-to-plist *qr-settings* t)))))
|
||||
|
||||
(defroute ("/qr" :method :POST) (&key _parsed)
|
||||
"QR Generator Main Route. Update the *QR-SETTINGS* and display the result. Login Required."
|
||||
(v:info :qr "POST /qr => ~a" _parsed)
|
||||
|
||||
(with-logged-in-user
|
||||
(alexandria:if-let ((settings (reinitialize-instance *qr-settings* :content _parsed)))
|
||||
(alexandria:if-let ((html (qr-generate settings)))
|
||||
html
|
||||
(_ "Something went wrong. Try again?"))
|
||||
(setf *qr-settings* (make-instance 'qr-settings)))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user