1. David Krentzlin
  2. webapp

Commits

David Krentzlin  committed 6e76009

initial import

  • Participants
  • Branches default

Comments (0)

Files changed (5)

File .hgignore

View file
+syntax: glob
+*.so
+*.import.*
+webapp-cmd

File webapp-cmd.scm

View file
+(use webapp posix chicken-syntax args filepath matchable)
+
+
+(define (absolutize-path path)
+  (if (absolute-pathname? path)
+      (normalize-pathname path)
+      (normalize-pathname (conc (current-directory) "/" path))))
+
+(define (exit-with-message msg #!optional (code 0))
+  (let ((port (if (zero? code) (current-output-port) (current-error-port))))
+    (display msg port)
+    (exit code)))
+
+(define (generate-file base relative proc)
+  (print "File: " relative)
+  (with-output-to-file (absolutize-path (filepath:combine base relative))
+    proc))
+
+(define (generate-directory base relative)
+  (let ((full-path (absolutize-path (filepath:combine base relative))))
+    (if (directory-exists? full-path)
+        (print "Directory: " relative " [exists]")
+        (begin
+          (print "Directory: " relative)
+          (create-directory full-path #t)))))
+
+(define (generate argv)
+  (define opts (list (args:make-option (h help) #:none "Display this text" (usage "generate appname [path]" opts))))
+  
+  (receive (options operands) (args:parse argv opts)
+    (when (zero? (length operands))
+      (usage  "generate appname [path]" opts ))
+
+    (let* ((appname (car operands))
+           (base-path (absolutize-path (or (and (not (null? (cdr operands))) (cadr operands)) "./")))
+           (needed-dirs (map (cut filepath:combine appname <> ) (list "public" "log" "lib" "db" "config"))))
+      (print "Generating files in " base-path)
+      
+      (for-each
+       (lambda (path)
+         (generate-directory base-path path))
+       needed-dirs)
+      
+      (generate-file base-path (sprintf "~A/init.scm" appname)
+         (lambda ()
+           (print ";; include your application's modules here")
+           (print "(use webapp)")))
+      
+      (generate-file base-path (sprintf "~A/lib/~A.setup" appname appname)
+         (lambda ()
+           (print ";; put the code to compile your app-modules here")))
+      
+      (generate-file base-path (sprintf "~A/lib/~A.meta" appname appname)
+          (lambda ()
+            (print "((depends webapp))"))))))
+
+(define (run argv)
+  (define opts
+    (list
+     (args:make-option (e environment) (required: "ENV")   "startup in ENVIRONMENT")
+     (args:make-option (h help) #:none "Display this text" (usage "run [options ...]" opts))))
+  (receive (options operands) (args:parse argv opts)
+    ;; load modules
+    (let* ((root-path (absolutize-path "./"))
+           (app-file  (filepath:combine root-path "init.scm")))
+      (unless (file-exists? app-file)
+        (exit-with-message (sprintf "There is no init-file. ~A does not exist!~%" app-file) 1))
+      (load app-file)
+      (boot (absolutize-path "./")))))
+
+(define (usage usage-msg opts #!optional (code 0))
+  (let ((msg (with-output-to-string
+               (lambda ()
+                 (if usage-msg
+                     (printf "Usage: ~A ~A~%~A" (car (argv)) usage-msg (args:usage opts))
+                     (printf "Usage: ~A command [options ...]~%" (car (argv))))))))
+    (exit-with-message msg code)))
+
+(define (help )
+  (let ((msg (with-output-to-string
+               (lambda ()
+                 (printf "Usage: ~A command [options ...]~%" (car (argv)))
+                 (newline)
+                 (printf "Available commands: ~%run\t\t Run the application~%generate \t Generate application skeleton~%")))))
+    (exit-with-message msg)))
+
+(define (main cmd-args)
+  (when (null? cmd-args)
+    (usage #f #f 1))
+  (let ((command (car cmd-args))
+        (opts    (cdr cmd-args)))
+    (case (string->symbol command)
+      ((-h --help) (help))
+      ((run) (run opts))
+      ((generate) (generate opts))
+      (else (usage #f #f 1)))))
+
+(main (command-line-arguments))
+
+
+
+
+
+  

File webapp.meta

View file
+((depends "spiffy" "spiffy-uri-match" "intarweb" "filepath" "sxml-transforms" "simple-configuration" "sxml-fu" "log5scm" "http-session"))

File webapp.scm

View file
+;; 
+;; %%HEADER%%
+;; 
+
+(module webapp 
+
+(boot app-root routes add-routes
+          environment=?
+          development?
+          production?
+          test?
+          sxml json render)
+
+(import scheme chicken ports data-structures)
+
+(use posix spiffy simple-directory-handler spiffy-uri-match intarweb filepath sxml-transforms
+     simple-configuration sxml-fu log5scm http-session posix)
+
+(define app-root     (make-parameter #f))
+(define modules-path (make-parameter #f))
+(define lib-path     (make-parameter #f))
+(define config-path  (make-parameter #f))
+(define log-path     (make-parameter #f))
+
+(define (setup-paths)
+  (lib-path      (filepath:combine (app-root) "app/lib"))
+  (modules-path  (filepath:combine (app-root) "app/modules"))
+  (log-path      (filepath:combine (app-root) "log"))
+  (config-path   (filepath:combine (app-root) "config")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;environment-information
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define environment (make-parameter (string->symbol (or (get-environment-variable "APP_ENV") "development"))))
+
+(define (environment=? what)
+  (eq? (environment) what))
+
+(define (development?) (environment=? 'development))
+(define (production?)  (environment=? 'production))
+(define (test?)        (environment=? 'test))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; routes and route-handling
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define routes (make-parameter (list)))
+
+(define (add-routes additional-routes)
+    (routes (cons (routes) additional-routes)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; rendering
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define doctype-rules
+  `((html5 *preorder* . ,(constantly "<!DOCTYPE HTML>"))))
+
+(define (render render-spec)
+    (with-headers (alist-ref 'headers render-spec ) (lambda () (write-logged-response)))
+    (with-output-to-port (response-port (current-response))
+      (lambda ()
+        (SRV:send-reply (alist-ref 'content render-spec )))))
+
+;; Rendering sxml
+;; (render (sxml `(blog-page "foo")))
+(define (sxml content #!optional (rules (list)) (default-rules (list (append doctype-rules universal-conversion-rules))))
+  `((headers . ((connection close) (content-type text/html)))
+    (content . ,(with-output-to-string
+                  (lambda ()
+                    (output-xml content (append rules default-rules)))))))
+
+(define (json content)
+  `((headers . ((connection close) (content-type application/json)))
+    (content ,content)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; configurations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define configuration (make-parameter #f))
+
+(define (load-configuration)
+  (let ((path (filepath:combine (config-path) "configuration.scm")))
+    (when (file-exists? path)
+      (log-for (app info) "Loading configuration")
+      (let ((cfg (config-read path)))
+        (configuration (config-ref cfg (list  (environment)) default: (list)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Logging
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (setup-basic-logging)
+  (define-category app)
+  (define-category error)
+  (define-category warning)
+  (define-category debug)
+  (define-category info)
+  (let ((logfile-path (filepath:combine (log-path) "application.log")))
+    (if (development?)
+        (start-sender app-sender-stderr (port-sender (current-error-port)) (category app)))
+    (start-sender app-sender (port-sender logfile-path) (category app))))
+
+(define (setup-extended-logging) #t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Startup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (startup #!key (root "./public") (port 8080))
+  (parameterize ((root-path   root)
+                 (server-port port)
+                 (debug-log (and (development?) (current-error-port)))
+                 (handle-directory simple-directory-handler)
+                 (vhost-map `((".*" . ,(uri-match/spiffy (routes))))))
+    (log-for (app debug) "Starting up server on port ~A " port)
+    (start-server)))
+
+(define (boot approot)
+  (parameterize ((app-root approot))
+    (setup-paths)
+    (setup-basic-logging)
+    (log-for (app info) "Bootstrapping the application in environment: ~A" (environment))
+    (load-configuration)
+    (setup-extended-logging)
+    (startup)))
+
+
+)

File webapp.setup

View file
+(define version "0.1")
+
+(compile -s -O2 -d0 webapp.scm -j webapp)
+(compile -s -O2 -d0 webapp.import.scm)
+
+(install-extension
+  'webapp
+  '("webapp.import.so" "webapp.so")
+  `((version ,version)))
+