model.scm 13.3 KB
Newer Older
Nala Ginrut's avatar
Nala Ginrut committed
1
;;  -*-  indent-tabs-mode:nil; coding: utf-8 -*-
2
;;  Copyright (C) 2015,2018,2019
Nala Ginrut's avatar
Nala Ginrut committed
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
;;  Artanis is free software: you can redistribute it and/or modify
;;  it under the terms of the GNU General Public License and GNU
;;  Lesser General Public License published by the Free Software
;;  Foundation, either version 3 of the License, or (at your option)
;;  any later version.

;;  Artanis is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;  GNU General Public License and GNU Lesser General Public License
;;  for more details.

;;  You should have received a copy of the GNU General Public License
;;  and GNU Lesser General Public License along with this program.
;;  If not, see <http://www.gnu.org/licenses/>.

(define-module (artanis mvc model)
  #:use-module (artanis utils)
  #:use-module (artanis env)
Nala Ginrut's avatar
Nala Ginrut committed
23
  #:use-module (artanis config)
Nala Ginrut's avatar
Nala Ginrut committed
24
25
  #:use-module (artanis fprm)
  #:use-module (artanis db)
26
  #:use-module (artanis irregex)
Nala Ginrut's avatar
Nala Ginrut committed
27
  #:use-module (ice-9 match)
Nala Ginrut's avatar
Nala Ginrut committed
28
  #:use-module (ice-9 format)
Nala Ginrut's avatar
Nala Ginrut committed
29
  #:use-module (srfi srfi-1)
Nala Ginrut's avatar
Nala Ginrut committed
30
31
32
  #:export (create-artanis-model
            load-app-models
            do-model-create
Nala Ginrut's avatar
Nala Ginrut committed
33
34
            model-field-add!
            field-validator-add!))
Nala Ginrut's avatar
Nala Ginrut committed
35
36
37
38

(define (opts-add new old)
  (apply lset-adjoin eq? new old))

Nala Ginrut's avatar
Nala Ginrut committed
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
(define opts-del plist-remove)

(define* (opts-ref opts o #:optional (value? #f))
  (let lp((next opts))
    (cond
     ((null? next) #f)
     ((eq? o (car next))
      (if value?
          (cadr next)
          o))
     (else (lp (cdr next))))))

(define (meta-update! o meta k)
  (hashq-set! meta k (opts-del (hashq-ref meta k) o)))

Nala Ginrut's avatar
Nala Ginrut committed
54
55
56
57
58
(define (create-model-meta fields)
  (let ((ht (make-hash-table)))
    (for-each (lambda (f) (hash-set! ht (car f) (cdr f))) fields)
    ht))

Nala Ginrut's avatar
Nala Ginrut committed
59
60
61
62
(define (get-kw-val kw lst)
  (cond
   ((or (null? lst) (not (kw-arg-ref lst kw))) (list lst))
   (else
Nala Ginrut's avatar
Nala Ginrut committed
63
    (call-with-values
Nala Ginrut's avatar
Nala Ginrut committed
64
        (lambda () (plist-remove lst kw))
Nala Ginrut's avatar
Nala Ginrut committed
65
      (lambda (opts kv)
Nala Ginrut's avatar
Nala Ginrut committed
66
67
        (list (cadr kv) opts))))))

Nala Ginrut's avatar
Nala Ginrut committed
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
(define *db-specific-types*
  '((mysql
     (text . longtext)
     (boolean . boolean))
    (postgresql
     (text . text)
     (boolean . boolean))
    (sqlite3
     (text . text)
     (boolean . integer))))

(define (db-specific-type type)
  (or
   (assoc-ref
    (assoc-ref *db-specific-types* (get-conf '(db dbd)))
    type)
   (throw 'artanis-err 500 db-specific-type
          "Invalid DB specific type `~a'" type)))

Nala Ginrut's avatar
Nala Ginrut committed
87
88
(define (general-field-handler name . opts)
  (define (get-maxlen lst) (get-kw-val #:maxlen lst))
89
  (define (get-diswidth lst) (get-kw-val #:diswidth lst))
Nala Ginrut's avatar
Nala Ginrut committed
90
91
92
  (define (get-integer-fractional-part lst)
    (match (get-kw-val #:integer-fractional lst)
      ;; We don't check the type here, deley to let FPRM check it.
93
      (((i f) . _) (list i f))
Nala Ginrut's avatar
Nala Ginrut committed
94
      (else '())))
Nala Ginrut's avatar
Nala Ginrut committed
95
96
97
  (case name
    ;; Auto index field
    ((auto) (list 'serial (opts-add '(#:no-edit #:not-null #:primary-key) opts)))
Nala Ginrut's avatar
Nala Ginrut committed
98
99
    ((tiny-integer) `(tinyint ,@(get-diswidth opts)))
    ((small-integer) `(smallint ,@(get-diswidth opts)))
Nala Ginrut's avatar
Nala Ginrut committed
100
101
    ;; 64 long integer
    ((big-integer) (list 'integer 64 opts))
Nala Ginrut's avatar
Nala Ginrut committed
102
103
104
    ;; NOTE: No, we may not going to provide fix-sized binary field, in Django,
    ;;       BinaryField could be used to store data which is upto 4GB into DB.
    ;;       It is a bad design to store binary BLOB directly IMO.
Nala Ginrut's avatar
Nala Ginrut committed
105
106
    ;; Raw binary data
    ;; ((binary) (list 'longblob opts)) ; longblob for mysql
Nala Ginrut's avatar
Nala Ginrut committed
107
108
109
110
111
    ;; NOTE: Unlimited sized plain text field is still acceptable.
    ;;       It's OK if you convert blob into base64 string to text field.
    ;;       But remember that you pay what you choose.
    ((text) (list (db-specific-type 'text) opts))
    ((boolean) (list (db-specific-type 'boolean) opts))
112
113
114
    ;; Integer part is the total number of digits.
    ;; Fractional part is the number of digits following the decimal point.
    ((float) `(float ,@(get-integer-fractional-part opts)))
Nala Ginrut's avatar
Nala Ginrut committed
115
    ((double) `(double ,@(get-integer-fractional-part opts)))
Nala Ginrut's avatar
Nala Ginrut committed
116
    ((char-field) `(varchar ,@(get-maxlen opts)))))
Nala Ginrut's avatar
Nala Ginrut committed
117
118
119

(define (date-field-handler now . opts)
  (let ((new-opts
Nala Ginrut's avatar
Nala Ginrut committed
120
         (cons #:no-edit
Nala Ginrut's avatar
Nala Ginrut committed
121
               (case now
Nala Ginrut's avatar
Nala Ginrut committed
122
123
124
                 ((auto) '(#:auto-now))
                 ((auto-once) '(#:auto-now-once))
                 (else '())))))
Nala Ginrut's avatar
Nala Ginrut committed
125
126
127
128
    (list 'date (opts-add new-opts opts))))

(define *model-field-handlers*
  `((auto . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
129
130
    (tiny-integer . ,general-field-handler)
    (small-integer . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
131
    (big-integer . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
132
    (boolean . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
133
134
    (float . ,general-field-handler)
    (double . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
135
    (text . ,general-field-handler)
Nala Ginrut's avatar
Nala Ginrut committed
136
137
138
139
140
141
    (char-field . ,general-field-handler)
    (date-field . ,date-field-handler)))

;; handler returns a list contains the valid field type in certain DBD
(define (model-field-add! name handler)
  (set! *model-field-handlers*
142
    (assoc-set! *model-field-handlers* name handler)))
Nala Ginrut's avatar
Nala Ginrut committed
143

Nala Ginrut's avatar
Nala Ginrut committed
144
145
146
147
148
;; NOTE: Different from auto_now* in Django, we allow users pass new value
;;       even auto_now* was specified.
;; NOTE: #:default will overwrite #:auto-now or #:auto-now-once. So don't use
;;       them together.
(define (fixed-date-field-val cmd meta k)
Nala Ginrut's avatar
Nala Ginrut committed
149
150
  (define (gen-local-date-str)
    (call-with-output-string
151
152
      (lambda (port)
        (write-date (get-local-time) port))))
Nala Ginrut's avatar
Nala Ginrut committed
153
154
155
156
157
158
159
  (let ((info (hashq-ref meta k)))
    (cond
     ((opts-ref (cddr info) #:auto-now #t)
      ;; Automatically set the field to now each time.
      (gen-local-date-str))
     ((opts-ref (cddr info) #:auto-now-once #t)
      ;; Set the field to now only once when the object is first created.
Nala Ginrut's avatar
Nala Ginrut committed
160
161
      (if (eq? cmd 'create)
          (meta-update! #:auto-now-once meta k)
162
163
          (throw 'artanis-err 500 fixed-date-field-val
                 "#:auto-now-once should be used with `create' command"))
Nala Ginrut's avatar
Nala Ginrut committed
164
      (gen-local-date-str))
165
166
     (else (throw 'artanis-err 500 fixed-date-field-val
                  "Shouldn't be here, why no default setting?")))))
Nala Ginrut's avatar
Nala Ginrut committed
167

Nala Ginrut's avatar
Nala Ginrut committed
168
169
(define-syntax-rule (check-field-value type r)
  (unless r
Nala Ginrut's avatar
Nala Ginrut committed
170
    (throw 'artanis-err 500 'check-field-value
171
           (format #f "~a check failed: ~a" type r))))
Nala Ginrut's avatar
Nala Ginrut committed
172
173

(define (auto-field-validator v)
174
175
  (throw 'artanis-err 500 auto-field-validator
         "AUTO field: you shouldn't set it manually!"))
Nala Ginrut's avatar
Nala Ginrut committed
176
177
178
179
180

(define BIGINT_MAX 9223372036854775808)
(define (big-integer-validator v)
  (check-field-value
   'big-integer
181
   (and (integer? v) (>= v (- BIGINT_MAX)) (<= v BIGINT_MAX))))
Nala Ginrut's avatar
Nala Ginrut committed
182
183
184
185
186
187
188
189

;; NOTE: Boolean should be string since all the values should be upcased.
(define (boolean-validator v)
  (check-field-value
   'boolean
   (let ((vv (string-upcase v)))
     (or (string=? vv "FALSE") (string=? vv "TRUE")))))

190
(define *date-re*
191
  (string->irregex "\\d{4}-\\d{2}-\\d{2} \\d{2}:\\d{2}:\\d{2}"))
192
193
194
195
196
197
198
199
200
201
(define (date-validator v)
  (check-field-value
   'date
   (irregex-search *date-re* v)))

(define (datetime-validator v)
  (check-field-value
   'datetime
   (irregex-search *date-re* v)))

Nala Ginrut's avatar
Nala Ginrut committed
202
203
(define (tinyint-validator v) v)
(define (smallint-validator v) v)
204
205
206
(define (float-validator v)
  ;; TODO: Is it possible to check integer-fractional by definition in migration?
  v)
Nala Ginrut's avatar
Nala Ginrut committed
207

Nala Ginrut's avatar
Nala Ginrut committed
208
209
210
;; FIXME: Shoud we check type validation in Scheme level? Or leave it as DB work.
(define *field-validators*
  `((auto . ,auto-field-validator)
Nala Ginrut's avatar
Nala Ginrut committed
211
212
    (tiny-integer . ,tinyint-validator)
    (small-integer . ,smallint-validator)
Nala Ginrut's avatar
Nala Ginrut committed
213
214
    (big-integer . ,big-integer-validator)
    (boolean . ,boolean-validator)
215
216
    (float . ,float-validator)
    (double . ,float-validator)
Nala Ginrut's avatar
Nala Ginrut committed
217
218
219
220
221
    (date . ,date-validator)
    (datetime . ,datetime-validator)))

(define (field-validator-add! type validator)
  (set! *field-validators*
222
    (assoc-set! *field-validators* type validator)))
Nala Ginrut's avatar
Nala Ginrut committed
223
224
225
226
227
228
229
230
231
232
233

(define (general-field-validator v)
  ;; TODO: maybe do some security check?
  v)

(define (validate-field-value v info)
  (cond
   ((or (kw-arg-ref info #:validator) (assoc-ref *field-validators* (car info)))
    => (lambda (h) (h v)))
   (else (general-field-validator v))))

234
;; Don't use it directly, since there's no existance-check in meta here.
Nala Ginrut's avatar
Nala Ginrut committed
235
(define (return-default-val cmd meta k)
236
  (let ((info (hashq-ref meta k)))
Nala Ginrut's avatar
Nala Ginrut committed
237
238
239
240
241
242
243
244
    (cond
     ((kw-arg-ref (cadr info) #:default)
      => (lambda (thunk) (list (thunk) k)))
     (else
      (case (car info)
        ((date-field date-time-field)
         (list (fixed-date-field-val cmd meta k) k))
        (else '())))))) ; no default value
Nala Ginrut's avatar
Nala Ginrut committed
245
246
247

(define (fix-fields cmd args meta)
  (define (fix-fields-to-set)
Nala Ginrut's avatar
Nala Ginrut committed
248
    (define (gen-default-val k)
Nala Ginrut's avatar
Nala Ginrut committed
249
250
251
252
253
      (cond
       ((hash-ref meta k)
        => (lambda (opts)
             (cond
              ((assoc-ref opts #:no-edit)
254
255
               (throw 'artanis-err 500 gen-default-val
                      "Field `~a' can't be edited!" k))
256
              ((hashq-ref meta k) => (lambda (info) (return-default-val cmd meta k)))
257
258
259
260
              (else (throw 'artanis-err 500 gen-default-val
                           "Field `~a' doesn't exist!" k)))))
       (else (throw 'artanis-err 500 gen-default-val
                    "No such field!" k))))
Nala Ginrut's avatar
Nala Ginrut committed
261
    (let lp((kl (hash-map->list cons meta)) (al args) (ret '()))
Nala Ginrut's avatar
Nala Ginrut committed
262
      (cond
Nala Ginrut's avatar
Nala Ginrut committed
263
264
265
266
267
268
269
       ((null? kl) `(,(reverse ret) ,@al)) ; append condition string if possible
       ((kw-arg-ref args (caar kl))
        => (lambda (v)
             (lp (cdr kl)
                 (cddr args) ; a trick to get condition string
                 (list (validate-field-value v (cdar kl)) (caar kl) ret))))
       (else (lp (cdr kl) al `(,@(return-default-val cmd meta (caar kl)) ,@ret))))))
Nala Ginrut's avatar
Nala Ginrut committed
270
271
  (case cmd
    ((set) (fix-fields-to-set))
Nala Ginrut's avatar
Nala Ginrut committed
272
    (else args)))
Nala Ginrut's avatar
Nala Ginrut committed
273
274
275
276
277
278

(define (parse-raw-fields lst)
  (define (->type type opts)
    (let ((h (assoc-ref *model-field-handlers* type)))
      (if h
          (apply h type opts)
279
280
          (throw 'artanis-err 500 parse-raw-fields
                 "Invalid field type `~a'!" type))))
281
  (let lp((next lst) (main '()) (options '()))
Nala Ginrut's avatar
Nala Ginrut committed
282
    (match next
283
      (() `(,(reverse main) ,@(reverse options)))
Joe Dong's avatar
Joe Dong committed
284
      (((? keyword? k) v rest ...)
285
       (lp rest main `(,v ,k ,@options)))
286
      ((((? symbol? name) (? symbol? type) . (or (? null? opts) ((opts ...)))) rest ...)
287
       (lp rest (cons `(,name ,@(->type type opts)) main) options))
288
289
      (else (throw 'artanis-err 500 parse-raw-fields
                   "Invalid field definition!" next)))))
Nala Ginrut's avatar
Nala Ginrut committed
290
291

;; For example:
Nala Ginrut's avatar
Nala Ginrut committed
292
293
;; (create-artanis-model
;;   people
Nala Ginrut's avatar
Nala Ginrut committed
294
295
296
297
298
299
300
;;   (id auto (#:not-null #:primary-key))
;;   (first_name char-field (#:maxlen 30 #:not-null))
;;   (last_name char-field (#:maxlen 30 #:not-null)))
(define-syntax create-artanis-model
  (lambda (x)
    (syntax-case x ()
      ((_ name) (identifier? #'name)
301
       #`(begin
Nala Ginrut's avatar
Nala Ginrut committed
302
303
304
305
306
           (define-module (app models name)
             #:use-module (artanis artanis)
             #:use-module (artanis utils)
             #:use-module (artanis db)
             #:use-module (artanis fprm))
307
308
309
           (format (artanis-current-output)
                   (WARN-TEXT "You have created model `~a' without any definition!~%")
                   'name)))
Nala Ginrut's avatar
Nala Ginrut committed
310
      ((_ name rest rest* ...) (identifier? #'name)
Nala Ginrut's avatar
Nala Ginrut committed
311
312
313
314
315
316
317
318
319
       #`(begin
           ;; NOTE: we have to encapsulate them to a module for protecting namespaces
           ;; NOTE: we're not going to imort (artanis env) directly to avoid revealing global
           ;;       env vars to users.
           (define-module (app models name)
             #:use-module (artanis artanis)
             #:use-module (artanis utils)
             #:use-module (artanis db)
             #:use-module (artanis fprm))
Nala Ginrut's avatar
Nala Ginrut committed
320
321
322
323
324
325
326
327
328
329
           (define-public #,(datum->syntax #'name (symbol-append '$ (syntax->datum #'name)))
             (let ((raw (parse-raw-fields (list `rest `rest* ...)))
                   (mt (map-table-from-DB (current-connection))))
               (when (not (mt 'table-exists? 'name))
                 (format (artanis-current-output)
                         "Creating table `~a' defined in model......"
                         'name)
                 (apply mt 'try-create 'name raw)
                 (format (artanis-current-output) "Done.~%"))
               (lambda (cmd . args)
Nala Ginrut's avatar
Nala Ginrut committed
330
                 (apply mt cmd 'name args)))))))))
Nala Ginrut's avatar
Nala Ginrut committed
331
332
333

(define (gen-model-header name)
  (call-with-output-string
334
335
336
337
338
    (lambda (port)
      (format port ";; Model ~a definition of ~a~%" name (current-appname))
      (display ";; Please add your license header here.\n" port)
      (display ";; This file is generated automatically by GNU Artanis.\n" port)
      (format port "(create-artanis-model ~a) ; DO NOT REMOVE THIS LINE!!!~%~%" name))))
Nala Ginrut's avatar
Nala Ginrut committed
339

340
341
342
343
344
345
346
347
348
349
350
351
352
;; NOTE: Whole list of types:
;;       integer
;;       primary_key
;;       decimal
;;       float
;;       boolean
;;       binary
;;       string
;;       text
;;       date
;;       time
;;       datetime
;;       timestamp
Nala Ginrut's avatar
Nala Ginrut committed
353
354
355
(define (parse-field-str str)
  `(,@(map string-trim-both (string-split str #\:)) (#:not-null)))

Nala Ginrut's avatar
Nala Ginrut committed
356
357
358
359
360
361
362
363
364
365
366
(define-syntax-rule (scan-models) (scan-app-components 'models))

(define (load-app-models)
  (define toplevel (current-toplevel))
  (display "Loading models...\n" (artanis-current-output))
  (use-modules (artanis mvc model)) ; black magic to make Guile happy
  (let ((cs (scan-models)))
    (for-each (lambda (s)
                (load (format #f "~a/app/models/~a.scm" toplevel s)))
              cs)))

Nala Ginrut's avatar
Nala Ginrut committed
367
368
369
370
371
;; NOTE: id will be generated automatically, as primary-key.
;;       You may remove it to add your own primary-key.
;; NOTE: Each field will be set as #:not-null, modify it as you wish.
(define (do-model-create name fields port)
  (display (gen-model-header name) port)
Nala Ginrut's avatar
Nala Ginrut committed
372
  )