initail commit

5 files changed, 403 insertions, 0 deletions

diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp
new file mode 100644
index 0000000..3f945cf
--- /dev/null
+++ b/lisp/service/base-service.lisp
@@ -0,0 +1,8 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:dns-admin)
+
+(defclass base-service ()
+  ()
+  (:documentation ""))
diff --git a/lisp/service/dns-service.lisp b/lisp/service/dns-service.lisp
new file mode 100644
index 0000000..5783574
--- /dev/null
+++ b/lisp/service/dns-service.lisp
@@ -0,0 +1,223 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:dns-admin)
+
+(defclass dns-service (rest-service)
+  ((title :initarg :title
+          :initform nil
+          :accessor title)
+   (form :initarg :form
+         :initform nil
+         :accessor form))
+  (:documentation ""))
+
+(defclass dns-search-service (dns-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p)
+   (form :initarg :form
+         :initform nil
+         :accessor form)
+   (results :initarg :results
+            :initform nil
+            :accessor results))
+  (:documentation ""))
+
+(defclass dns-login-service (dns-search-service)
+  ()
+  (:documentation ""))
+
+(defclass dns-headers-service (rest-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p)
+   (headers :initarg :headers
+            :initform nil
+            :accessor headers))
+  (:documentation ""))
+
+(defclass dns-add-service (dns-search-service)
+  ()
+  (:documentation ""))
+
+(defclass dns-modify-service (dns-search-service)
+  ()
+  (:documentation ""))
+
+(defclass dns-ttl-service (dns-search-service)
+  ()
+  (:documentation ""))
+
+(defun make-dns-form (form-name action button-label &key required-p recordtype ref name ipv4addr ipv6addr canonical ptrdname)
+  (make-form form-name
+             nil
+             required-p
+             `((:name "ref" :label "Ref" :field-type ,(if required-p "hidden" "text") ,@(when (sanitize-dns-filter-param ref) `(:value ,ref)) ,@(when required-p '(:required "required")))
+               (:name "name" :label ,(format nil "Name~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param name) `(:value ,name)) ,@(when required-p '(:required "required")))
+               ,@(cond ((string= recordtype "a")
+                        `((:name "ipv4addr" :label ,(format nil "IPv4 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv4addr `(:value ,ipv4addr)) ,@(when required-p '(:required "required")))))
+                       ((string= recordtype "aaaa")
+                        `((:name "ipv6addr" :label ,(format nil "IPv6 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv6addr `(:value ,ipv6addr)) ,@(when required-p '(:required "required")))))
+                       ((string= recordtype "cname")
+                        `((:name "canonical" :label ,(format nil "Canonical~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param canonical) `(:value ,canonical)) ,@(when required-p '(:required "required")))))
+                       ((string= recordtype "ptr")
+                        `((:name "ptrdname" :label ,(format nil "PTR Dname~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param ptrdname) `(:value ,ptrdname)) ,@(when required-p '(:required "required")))
+                          (:name "ipv4addr" :label ,(format nil "IPv4 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv4addr `(:value ,ipv4addr)) ,@(when required-p '(:required "required"))))))
+               (:label ,button-label :field-type "button" :onclick ,action))))
+
+(defun make-ttl-form (form-name action button-label &key required-p ref)
+  (make-form form-name
+             nil
+             required-p
+             `((:name "ref" :label "Ref" :field-type ,(if required-p "hidden" "text") ,@(when (sanitize-dns-filter-param ref) `(:value ,ref)) ,@(when required-p '(:required "required")))
+               (:name "ttl" :label ,(format nil "TTL~a" (if required-p " *" "")) :field-type "text" ,@(when required-p '(:required "required")))
+               (:label ,button-label :field-type "button" :onclick ,action))))
+
+(defun handle-dns ()
+  (with-service (instance dns-service)
+    (setf (title instance) "Select Record Type")
+    (setf (form instance) (make-form "dns-select-recordtype-form"
+                                     nil
+                                     nil
+                                     '((:name "recordtype"
+                                        :field-type "select"
+                                        :required "required"
+                                        :onchange "on_dns_select_recordtype_changed()"
+                                        :options ((:label "A" :value "a")
+                                                  (:label "AAAA" :value "aaaa")
+                                                  (:label "CNAME" :value "cname")
+                                                  (:label "PTR" :value "ptr"))))))))
+
+(defun handle-dns-login-get ()
+  (with-service (instance dns-login-service)
+    (setf (title instance) (cond ((string= (getf (dns *webapp*) :backend-type) "infoblox")
+                                  "Provide Infoblox Credentials")
+                                 ((string= (getf (dns *webapp*) :backend-type) "nsupdate")
+                                  "Provide Path to nsupdate Keyfile")))
+    (setf (form instance) (make-form "dns-login-get-form"
+                                     nil
+                                     t
+                                     (cond ((string= (getf (dns *webapp*) :backend-type) "infoblox")
+                                            '((:name "username" :label "Username *" :field-type "text" :required "required")
+                                              (:name "pwd" :label "Password *" :field-type "password" :required "required")
+                                              (:label "Login" :field-type "button" :onclick "on_dns_login_get_clicked()")))
+                                           ((string= (getf (dns *webapp*) :backend-type) "nsupdate")
+                                            '((:name "keypath" :label "Key Path *" :field-type "text" :required "required")
+                                              (:label "Login" :field-type "button" :onclick "on_dns_login_get_clicked()"))))))))
+
+(defun handle-dns-login-post (username pwd keypath)
+  (declare (special username pwd keypath))
+  (with-service (instance dns-search-service)
+    (loop for param in (sb-introspect:function-lambda-list 'handle-dns-login-post) do
+         (when (symbol-value param)
+           (setf (session-value (intern (symbol-name param) :keyword)) (symbol-value param))))
+    (setf (message instance) "Credentials accepted.")))
+
+(defun handle-dns-headers (recordtype)
+  (with-service (instance dns-headers-service)
+    (with-dns (dns)
+      (let ((dns-record (make-dns-record dns recordtype)))
+        (setf (headers instance) (mapcar (lambda (slot)
+                                           (slot-to-param dns-record slot))
+                                         (map-slot-names dns-record)))))))
+
+(defun handle-dns-api-search-get (recordtype)
+  (with-service (instance dns-search-service)
+    (setf (title instance) (format nil "Filter ~a Records" (string-upcase recordtype)))
+    (setf (form instance) (make-dns-form "dns-api-search-get-form"
+                                         "on_dns_api_search_get_clicked()"
+                                         "Search"
+                                         :recordtype recordtype))))
+
+(defun handle-dns-api-search-post (recordtype ref name ipv4addr ipv6addr canonical ptrdname)
+  (with-service (instance dns-search-service)
+    (with-dns (dns)
+      (let ((results (get-dns-records dns recordtype ref name ipv4addr ipv6addr canonical ptrdname)))
+        (cond ((eq results 'unauth-error)
+               (setf (authmsg instance) "Authentication failed"))
+              ((not (listp results))
+               (setf (errormsg instance) results))
+              (t
+               (setf (results instance) results)))))))
+
+(defun handle-dns-api-add-get (recordtype)
+  (with-service (instance dns-add-service)
+    (setf (title instance) (format nil "DNS - Add a(n) ~a Record" (string-upcase recordtype)))
+    (setf (form instance) (make-dns-form "dns-api-add-get-form"
+                                         "on_dns_api_add_get_clicked()"
+                                         "Add"
+                                         :required-p t
+                                         :recordtype recordtype))))
+
+(defun handle-dns-api-add-post (recordtype name ipv4addr ipv6addr canonical ptrdname)
+  (declare (special recordtype name ipv4addr ipv6addr canonical ptrdname))
+  (with-service (instance dns-add-service)
+    (with-dns (dns)
+      (let ((dns-record (make-dns-record dns recordtype)))
+        (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-add-post) do
+             (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param))))
+        (let ((results (add-dns-record dns dns-record)))
+          (if results
+              (setf (message instance) (format nil "Record added successfully. _ref: ~a" results))
+              (setf (errormsg instance) (format nil "Error while adding record."))))))))
+
+(defun handle-dns-api-modify-get (recordtype ref name ipv4addr ipv6addr canonical ptrdname)
+  (with-service (instance dns-add-service)
+    (setf (title instance) (format nil "DNS - Modify a(n) ~a Record" (string-upcase recordtype)))
+    (setf (form instance) (make-dns-form "dns-api-modify-get-form"
+                                         "on_dns_api_modify_get_clicked()"
+                                         "Modify"
+                                         :required-p t
+                                         :recordtype recordtype
+                                         :ref ref
+                                         :name name
+                                         :ipv4addr ipv4addr
+                                         :ipv6addr ipv6addr
+                                         :canonical canonical
+                                         :ptrdname ptrdname))))
+
+(defun handle-dns-api-modify-post (recordtype ref name ipv4addr ipv6addr canonical ptrdname)
+  (declare (special recordtype ref name ipv4addr ipv6addr canonical ptrdname))
+  (with-service (instance dns-modify-service)
+    (with-dns (dns)
+      (let ((dns-record (make-dns-record dns recordtype)))
+        (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-modify-post) do
+             (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param))))
+        (let ((results (modify-dns-record dns dns-record)))
+          (if results
+              (setf (message instance) (format nil "Record modified successfully. _ref: ~a" results))
+              (setf (errormsg instance) (format nil "Error while modifying record."))))))))
+
+(defun handle-dns-api-delete-post (recordtype ref)
+  (declare (special recordtype ref))
+  (with-service (instance dns-add-service)
+    (with-dns (dns)
+      (let ((dns-record (make-dns-record dns recordtype)))
+        (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-delete-post) do
+             (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param))))
+        (let ((results (delete-dns-record dns dns-record)))
+          (if results
+              (setf (message instance) "Record deleted successfully.")
+              (setf (errormsg instance) (format nil "Error while deleting record."))))))))
+
+(defun handle-dns-api-ttl-get (recordtype ref name)
+  (with-service (instance dns-ttl-service)
+    (setf (title instance) (format nil "DNS - Set the TTL on ~a" name))
+    (setf (form instance) (make-ttl-form "dns-api-ttl-get-form"
+                                         "on_dns_api_ttl_get_clicked()"
+                                         "Modify TTL"
+                                         :required-p t
+                                         :ref ref))))
+
+(defun handle-dns-api-ttl-post (recordtype ref ttl)
+  (declare (special recordtype ref ttl))
+  (with-service (instance dns-ttl-service)
+    (with-dns (dns)
+      (let ((dns-record (make-dns-record dns recordtype)))
+        (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-ttl-post) do
+             (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param))))
+        (let ((results (modify-dns-record-ttl dns dns-record)))
+          (if results
+              (setf (message instance) "Record modified successfully.")
+              (setf (errormsg instance) (format nil "Error while TTLing record."))))))))
diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp
new file mode 100644
index 0000000..a3eeec4
--- /dev/null
+++ b/lisp/service/generic-form.lisp
@@ -0,0 +1,87 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:dns-admin)
+
+(defclass generic-form (base-service)
+  ((name :initarg :name
+         :initform nil
+         :accessor name)
+   (http-method :initarg :http-method
+                :initform "POST"
+                :accessor http-method)
+   (action :initarg :action
+           :initform nil
+           :accessor action)
+   (required-p :initarg :required-p
+               :initform nil
+               :accessor required-p)
+   (form-fields :initarg :form-fields
+                :initform nil
+                :accessor form-fields))
+  (:documentation ""))
+
+(defclass form-field (base-service)
+  ((name :initarg :name
+         :initform nil
+         :accessor name)
+   (label :initarg :label
+          :initform nil
+          :accessor label)
+   (value :initarg :value
+          :initform nil
+          :accessor value)
+   (checked :initarg :checked
+            :initform nil
+            :accessor checked)
+   (field-type :initarg :field-type
+               :initform nil
+               :accessor field-type)
+   (required :initarg :required
+             :initform nil
+             :accessor required)
+   (dismiss :initarg :dismiss
+            :initform nil
+            :accessor dismiss)
+   (options :initarg :options
+            :initform nil
+            :accessor options)
+   (onclick :initarg :onclick
+            :initform nil
+            :accessor onclick)
+   (onchange :initarg :onchange
+             :initform nil
+             :accessor onchange))
+  (:documentation ""))
+
+(defclass option (base-service)
+  ((label :initarg :label
+          :initform nil
+          :accessor label)
+   (value :initarg :value
+          :initform nil
+          :accessor value))
+  (:documentation ""))
+
+(defun make-form (name action required-p fields)
+  (make-instance 'generic-form
+                 :name name
+                 :action action
+                 :required-p required-p
+                 :form-fields (mapcar (lambda (field)
+                                        (make-instance 'form-field
+                                                       :name (getf field :name)
+                                                       :label (getf field :label)
+                                                       :value (getf field :value)
+                                                       :checked (getf field :checked)
+                                                       :field-type (getf field :field-type)
+                                                       :required (getf field :required)
+                                                       :dismiss (getf field :dismiss)
+                                                       :options (mapcar (lambda (option)
+                                                                          (make-instance 'option
+                                                                                         :label (getf option :label)
+                                                                                         :value (getf option :value)))
+                                                                        (getf field :options))
+                                                       :onclick (getf field :onclick)
+                                                       :onchange (getf field :onchange)))
+                                      fields)))
diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp
new file mode 100644
index 0000000..251f899
--- /dev/null
+++ b/lisp/service/login-service.lisp
@@ -0,0 +1,48 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:dns-admin)
+
+(defclass login-service (rest-service)
+  ((form :initarg :form
+         :initform nil
+         :accessor form)
+   (title :initarg :title
+          :initform nil
+          :accessor title))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((login-service login-service) &key)
+  (cond ((string= (backend (dns *webapp*)) "infoblox")
+         (setf (title login-service) "Supply the Infoblox username, password and domain.")
+         (setf (form login-service) (make-form "login-form"
+                                               nil
+                                               t
+                                               '((:name "username" :label "Username *" :field-type "text" :required "required")
+                                                 (:name "pwd" :label "Password *" :field-type "password" :required "required")
+                                                 (:name "domain" :label "Domain *" :field-type "text" :required "required")
+                                                 (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()")))))
+
+(defun login-json ()
+  (objects-to-json `(,(make-instance 'login-service))))
+
+(defclass login-authenticate-service (rest-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((login-authenticate-service login-authenticate-service) &key auth-result)
+  (if auth-result
+      (setf (message login-authenticate-service) "Successfully logged in.")
+      (setf (errormsg login-authenticate-service) "Login failed.")))
+
+(defun login-authenticate-json (username password domain)
+  (let ((auth-result nil))
+    (when (and (intersection `(,username) (valid-users *webapp*) :test 'string=)
+               (check-ldap-password (ldap *webapp*) username password))
+      (setf (session-value :username) username)
+      (setf (session-value :pwd) pwd)
+      (setf (session-value :domain) domain)
+      (setf auth-result t))
+    (objects-to-json `(,(make-instance 'login-authenticate-service :auth-result auth-result)))))
diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp
new file mode 100644
index 0000000..ea374b8
--- /dev/null
+++ b/lisp/service/rest-service.lisp
@@ -0,0 +1,37 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:dns-admin)
+
+(defclass rest-service (base-service)
+  ((location :initarg :location
+             :initform nil
+             :accessor location)
+   (location-p :initarg :location-p
+               :initform t
+               :accessor location-p)
+   (authmsg :initarg :authmsg
+            :initform nil
+            :accessor authmsg)
+   (errormsg :initarg :errormsg
+             :initform nil
+             :accessor errormsg)
+   (message :initarg :message
+            :initform nil
+            :accessor message))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((rest-service rest-service) &key)
+  (when (and (location-p rest-service) (null (location rest-service)))
+    (setf (location rest-service) (type-to-path rest-service))))
+
+(defun handle-location (&optional (location "/home"))
+  (format nil "{\"location\":\"~a\"}" location))
+
+(defun type-to-path (rest-type)
+  (concatenate 'string "/" (ppcre:regex-replace-all "-" (ppcre:regex-replace "-service$" (string-downcase (type-of rest-type)) "") "/")))
+
+(defmacro with-service ((instance rest-service) &body body)
+  `(let ((,instance (make-instance ',rest-service)))
+     ,@body
+     (objects-to-json `(,,instance))))