new file mode 100644

@@ -0,0 +1 @@

+*.fasl

new file mode 100644

@@ -0,0 +1,107 @@

+(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))))

new file mode 100644

@@ -0,0 +1,18 @@

+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*-

+(in-package :asdf-user)

+

+(defsystem :redirector 

+    :description ""

+    :author "Ed L <edward@elangley.org>"

+    :license "MIT"

+    :depends-on (#:alexandria

+                 #:uiop

+                 #:serapeum

+                 #:araneus

+                 #:spinneret

+                 #:lquery

+                 #:graph-db

+                 #:fwoar.lisputils

+                 #:closer-mop)

+    :serial t

+    :components ((:file "main")))