#lang scheme/base
(require "depend.ss")
(define-struct (session active-record) (expiration store) #:mutable)
(define current-session (make-parameter #f))
(define session-expiration-interval (make-parameter 14))
(define (expiration-helper (date (current-date)))
(exact->inexact (date->julian-day (date+ date (session-expiration-interval)))))
(define (uuid-helper u)
(uuid->string (make-uuid u)))
(define (build-session handle
(uuid (make-uuid))
(store (make-immutable-hash-registry)))
(define (helper expiration store)
(make-session handle uuid expiration
(call-with-input-string store in->registry)))
(with-handlers ((identity
(lambda (e)
((current-log) 'build-session! e)
(void))))
(exec handle 'make-session! `((uuid . ,(uuid-helper uuid))
(expiration . ,(expiration-helper))
(store . ,(call-with-output-string
(lambda (out)
(registry->out store out)))))))
(apply helper (row handle 'load-session `((uuid . ,(uuid-helper uuid))))))
(define (save-session! session)
(exec (active-record-handle session)
'save-session!
`((uuid . ,(uuid-helper (active-record-id session)))
(expiration . ,(expiration-helper))
(store . ,(call-with-output-string
(lambda (out)
(registry->out (session-store session) out)))))))
(define (refresh-session! session)
(define (helper new-session)
(set-session-expiration! session (session-expiration new-session))
(set-session-store! session (session-store new-session)))
(helper (build-session (active-record-handle session)
(active-record-id session)
(session-expiration session)
(session-store session))))
(define (session-ref session key (default #f))
(registry-ref (session-store session) key default))
(define (session-set! session key val)
(registry-set! (session-store session) key val))
(define (session-del! session key)
(registry-del! (session-store session) key))
(define (destroy-session! session)
(exec (active-record-handle session)
'destroy-session!
`((uuid . ,(uuid-helper (active-record-id session))))))
(define (session-expired? session)
(< (session-expiration session) (date->julian-day (current-date))))
(define (call-with-session session proc)
(dynamic-wind void
(lambda ()
(proc session))
(lambda ()
(save-session! session))))
(define (with-session session proc)
(call-with-session session
(lambda (session)
(parameterize ((current-session session))
(proc)))))
(provide/contract
(session-ref (->* (session? any/c)
(any/c)
any))
(session-set! (-> session? any/c any/c any))
(session-del! (-> session? any/c any))
(session-expired? (-> session? any))
(call-with-session (-> session?
(-> session? any)
any))
(with-session (-> session? (-> any) any))
(build-session (->* (handle?)
(uuid? registry?)
session?))
(save-session! (-> session? any))
(refresh-session! (-> session? any))
(destroy-session! (-> session? any))
(current-session (parameter/c (or/c false/c session?)))
(session-expiration-interval (parameter/c number?))
(session? (-> any/c any))
)