git.fiddlerwoaroof.com
main.lisp
05ae2bfe
 (defpackage :redirector.graph
   (:use :closer-common-lisp :graph-db)
   (:export
    #:site
    #:short-name
    #:shortens
    #:init
    #:lookup-site-by-abbreviation
    #:url
    #:description
    #:with-db
    #:all-abbreviations
    #:name))
 (in-package :redirector.graph)
 (log:config :all :sane :d :nopretty :thread :daily "/var/tmp/graph.log")
 
 (def-vertex site ()
   ((url :type string)
    (description :type string))
   :fwoar-shortener)
 
 (def-vertex short-name ()
   ((name :type string))
   :fwoar-shortener)
 
 (def-edge shortens ()
   ()
   :fwoar-shortener)
 
 (defun init (path)
   (let ((*graph* (or *graph*
                      (graph-db:make-graph :fwoar-shortener path))))
     (graph-db:def-view shortens-by-abbrev :lessp (redirector.graph::shortens :fwoar-shortener)
                           (:map (lambda (shorten-edge)
                                   (yield (name (lookup-vertex (from shorten-edge))) nil))))))
 
 (defun all-abbreviations ()
   (select (:flat t)
     ((?site ?abbrev))
     (shortens ?abbrev ?site)))
 
 (defun lookup-site-by-abbreviation (abbrev)
   (declare (special abbrev))
   (select (:flat t)
     (?site)
     (lisp ?abbrev-name abbrev)
     (shortens ?abbrev ?site)
     (is ?abbrev-name (name ?abbrev))))
 
 (defmacro with-db ((path) &body body)
   (alexandria:once-only (path)
     `(let ((*graph* (or *graph*
                         (lookup-graph :fwoar-shortener)
                         (if (probe-file ,path)
                             (open-graph :fwoar-shortener ,path)
                             (init ,path)))))
        ,@body)))
 
 (defpackage :redirector.main
   (:import-from :araneus :define-controller :define-view :define-routes)
   (:use :closer-common-lisp))
 (in-package :redirector.main)
 
 (define-controller abbreviation (params)
   (redirector.graph:with-db ("/tmp/shortening-graph/")
     (redirector.graph:lookup-site-by-abbreviation
      (cdr (assoc :route params)))))
 
 (define-view redirect ((model list))
   (if model
       `(302 (:Location ,(redirector.graph:url (car model)))
             (""))
       '(404 () ("not found..."))))
 
 (define-controller list-abbreviations (params)
   (redirector.graph:with-db ("/tmp/shortening-graph/")
     (mapcar (fw.lu:destructuring-lambda ((site abbrev))
               (with-accessors ((url redirector.graph:url)
                                (description redirector.graph:description)) site
                 (with-accessors ((name redirector.graph:name)) abbrev
                   (list url description name))))
             (redirector.graph:all-abbreviations))))
 
 (araneus:define-view list-abbreviations ((abbreviation-list list))
   (redirector.graph:with-db ("/tmp/shortening-graph/")
     (spinneret:with-html-string
       (:html
        (:head)
        (:body
         (:ul.shortcuts 
          (mapcar (fw.lu:destructuring-lambda ((url description name))
                    (:li.shortcut (:a :href (format nil "/r/~a" name)
                                      (:span.abbrev name)
                                      (:span.description description)
                                      (:span.url url))))
                  abbreviation-list)))))))
 
 (define-routes shortener-routes
   (("/" :method :GET) (araneus:as-route 'list-abbreviations))
   (("/r/:route" :method :GET) (araneus:compose-route (abbreviation) redirect)))
 
 (defun main (&optional (path "/tmp/shortening-graph/"))
   (redirector.graph:with-db (path)
     (let ((app (make-instance 'ningle:<app>)))
       (shortener-routes app)
       (values (clack:clackup app)
               app))))