Permalink
Browse files

Reorganized the source a little bit.

  • Loading branch information...
1 parent 51591aa commit a861a97fe77a65201f3344eae67517a6c496b758 @blitz committed Oct 26, 2008
Showing with 157 additions and 133 deletions.
  1. +13 −0 anonymous-auth.lisp
  2. +4 −1 cl-dbus.asd
  3. +90 −0 cookie-sha1-auth.lisp
  4. +0 −132 network.lisp
  5. +50 −0 utilities.lisp
View
@@ -0,0 +1,13 @@
+;;; -*- Mode: Lisp -*-
+;;; Copyright (c) 2008 Julian Stecklina
+;;;
+;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
+
+(in-package :blitz.desktop.dbus)
+
+(defun try-anonymous-auth (stream)
+ ;; XXX
+ nil
+ )
+
+;;; EOF
View
@@ -2,7 +2,10 @@
(defsystem cl-dbus
:components ((:file "packages")
- (:file "network" :depends-on ("packages")))
+ (:file "utilities" :depends-on ("packages"))
+ (:file "cookie-sha1-auth" :depends-on ("packages" "utilities"))
+ (:file "anonymous-auth" :depends-on ("packages" "utilities"))
+ (:file "network" :depends-on ("packages" "cookie-sha1-auth" "anonymous-auth")))
:depends-on (iterate flexi-streams defclass-star usocket cl-ppcre
ironclad))
View
@@ -0,0 +1,90 @@
+;;; -*- Mode: Lisp -*-
+;;; Copyright (c) 2008 Julian Stecklina
+;;;
+;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
+
+(in-package :blitz.desktop.dbus)
+
+(defun map-user-cookie-file (context fn)
+ "Call fn with all cookies in the given DBUS context. `fn' is given
+the cookie ID, the cookie creation time in seconds since the UNIX
+epoch and the cookie itself (as string of hex digits)."
+ (with-open-file (cookie-stream (merge-pathnames (make-pathname :directory '(:relative ".dbus-keyrings")
+ :name context)
+ (user-homedir-pathname)))
+ (loop
+ for line = (read-line cookie-stream nil nil)
+ while line
+ do (destructuring-bind (cookie-id-str cookie-creation-str cookie-hex-str)
+ (cl-ppcre:split "\\s" line)
+ (funcall fn
+ (parse-integer cookie-id-str)
+ (parse-integer cookie-creation-str)
+ cookie-hex-str)))))
+
+(defun random-challenge (&optional (length 16))
+ (loop with array = (make-array length :element-type '(unsigned-byte 8))
+ for i from 0 below length
+ do (setf (aref array i) (random 256))
+ finally (return array)))
+
+(defun try-cookie-sha1-auth (stream)
+ ;; Send the username we want to authenticate as.
+ (let ((user (sb-ext:posix-getenv "USER")))
+ (assert (stringp user) (user) "Couldn't find out username?! USER is not set.")
+ (format-crlf stream "AUTH DBUS_COOKIE_SHA1 ~A"
+ (string-to-hex-string user)))
+ (force-output stream)
+ ;; The server sends the name of its "cookie context", a
+ ;; space character; the integer ID of the secret cookie the client
+ ;; must demonstrate knowledge of; a space character; then a
+ ;; hex-encoded randomly-generated challenge string.
+ (destructuring-bind (response &optional data)
+ (read-line-and-split stream)
+ (when (string/= response "DATA")
+ (error "Got unexpected result: ~A ~A" response data))
+ (destructuring-bind (context secret-cookie-id-str hex-challenge-str)
+ (cl-ppcre:split "\\s" (sb-ext:octets-to-string (parse-hex-string data)
+ :external-format :ascii))
+ (format t "Got: ~A ~A ~A~%" context secret-cookie-id-str hex-challenge-str)
+ (let ((secret-cookie-id (parse-integer secret-cookie-id-str)))
+ ;; Try to find the requested cookie.
+ (let ((cookie-data-str (block data
+ (map-user-cookie-file
+ context
+ (lambda (cookie-id creation-time cookie-data-str)
+ (declare (ignore creation-time))
+ (when (= cookie-id secret-cookie-id)
+ (return-from data cookie-data-str))))
+ (error "Invalid cookie id from server."))))
+ ;; We've found our cookie. Now
+ ;; digest and and be done with
+ ;; it. :)
+ (let ((my-challenge-str (octets-to-hex-string (random-challenge))))
+ (let* ((hashed-str (format nil "~A:~A:~A"
+ hex-challenge-str
+ my-challenge-str
+ cookie-data-str))
+ (digest (octets-to-hex-string (ironclad:digest-sequence 'ironclad:sha1
+ (sb-ext:string-to-octets
+ hashed-str)))))
+ ;; Format our answer
+ (format-crlf stream "DATA ~A20~A"
+ (to-hex-string my-challenge-str)
+ (string-to-hex-string digest)))
+ (force-output stream))))))
+ ;; Now check if we get a positive reply.
+ (destructuring-bind (response . rest)
+ (read-line-and-split stream)
+ (cond
+ ((string= response "OK")
+ ;; Yay, we are authenticated. REST containts the hex-encoded
+ ;; server GUID, but I guess we don't need that.
+ t)
+ ((string= response "REJECTED")
+ (format t "~&DBUS_COOKIE_SHA1 authentication failed:~{ ~A~}" rest)
+ nil)
+ (t
+ (error "Unexpected reply from DBUS server: ~A~{ ~A~}" response rest)))))
+
+;;; EOF
View
@@ -8,22 +8,6 @@
(defclass* dbus-connection ()
(stream))
-(defun read-line-crlf (stream)
- "Read a line terminated with a CR/LF pair."
- (let ((line (read-line stream)))
- (assert (char= #\Return
- (char line (1- (length line)))))
- ;; Using displaced arrays instead of subseq does not seem to offer
- ;; any advantages on SBCL.
- (subseq line 0 (1- (length line)))))
-
-(defun format-crlf (stream fmt &rest args)
- (format t "~?~%" fmt args)
- (format stream "~?~C~C" fmt args #\Return #\Newline))
-
-(defun read-line-and-split (stream)
- (cl-ppcre:split "\\s" (read-line-crlf stream)))
-
(defun accepted-methods (stream)
(format-crlf stream "AUTH")
(force-output stream)
@@ -32,122 +16,6 @@
(assert (string= "REJECTED" response))
rest))
-;;; Hex string handling
-
-(defun octets-to-hex-string (octets)
- (string-downcase (format nil "~{~2,'0X~}" (coerce octets 'list))))
-
-(defun string-to-hex-string (string)
- (octets-to-hex-string (sb-ext:string-to-octets string :external-format :ascii)))
-
-(defun parse-hex-string (string)
- (declare (type string string))
- (assert (evenp (length string)))
- (iter (with output = (make-array (truncate (length string) 2)
- :element-type '(unsigned-byte 8)))
- (for out-pos from 0 below (truncate (length string) 2))
- (declare (type fixnum out-pos))
- (flet ((dc (index)
- (let ((c (digit-char-p (char string index) 16)))
- (or c
- (error "Bogus string")))))
- (declare (inline dc))
- (setf (aref output out-pos)
- (logand #xFF
- (logior (ash (dc (* out-pos 2)) 4)
- (dc (1+ (* out-pos 2)))))))
- (finally (return output)) ))
-
-;;; SHA1 cookie auth
-
-(defun map-user-cookie-file (context fn)
- "Call fn with all cookies in the given DBUS context. `fn' is given
-the cookie ID, the cookie creation time in seconds since the UNIX
-epoch and the cookie itself (as string of hex digits)."
- (with-open-file (cookie-stream (merge-pathnames (make-pathname :directory '(:relative ".dbus-keyrings")
- :name context)
- (user-homedir-pathname)))
- (loop
- for line = (read-line cookie-stream nil nil)
- while line
- do (destructuring-bind (cookie-id-str cookie-creation-str cookie-hex-str)
- (cl-ppcre:split "\\s" line)
- (funcall fn
- (parse-integer cookie-id-str)
- (parse-integer cookie-creation-str)
- cookie-hex-str)))))
-
-(defun random-challenge (&optional (length 16))
- (loop with array = (make-array length :element-type '(unsigned-byte 8))
- for i from 0 below length
- do (setf (aref array i) (random 256))
- finally (return array)))
-
-(defun try-cookie-sha1-auth (stream)
- ;; Send the username we want to authenticate as.
- (let ((user (sb-ext:posix-getenv "USER")))
- (assert (stringp user) (user) "Couldn't find out username?! USER is not set.")
- (format-crlf stream "AUTH DBUS_COOKIE_SHA1 ~A"
- (string-to-hex-string user)))
- (force-output stream)
- ;; The server sends the name of its "cookie context", a
- ;; space character; the integer ID of the secret cookie the client
- ;; must demonstrate knowledge of; a space character; then a
- ;; hex-encoded randomly-generated challenge string.
- (destructuring-bind (response &optional data)
- (read-line-and-split stream)
- (when (string/= response "DATA")
- (error "Got unexpected result: ~A ~A" response data))
- (destructuring-bind (context secret-cookie-id-str hex-challenge-str)
- (cl-ppcre:split "\\s" (sb-ext:octets-to-string (parse-hex-string data)
- :external-format :ascii))
- (format t "Got: ~A ~A ~A~%" context secret-cookie-id-str hex-challenge-str)
- (let ((secret-cookie-id (parse-integer secret-cookie-id-str)))
- ;; Try to find the requested cookie.
- (let ((cookie-data-str (block data
- (map-user-cookie-file
- context
- (lambda (cookie-id creation-time cookie-data-str)
- (declare (ignore creation-time))
- (when (= cookie-id secret-cookie-id)
- (return-from data cookie-data-str))))
- (error "Invalid cookie id from server."))))
- ;; We've found our cookie. Now
- ;; digest and and be done with
- ;; it. :)
- (let ((my-challenge-str (octets-to-hex-string (random-challenge))))
- (let* ((hashed-str (format nil "~A:~A:~A"
- hex-challenge-str
- my-challenge-str
- cookie-data-str))
- (digest (octets-to-hex-string (ironclad:digest-sequence 'ironclad:sha1
- (sb-ext:string-to-octets
- hashed-str)))))
- ;; Format our answer
- (format-crlf stream "DATA ~A20~A"
- (to-hex-string my-challenge-str)
- (string-to-hex-string digest)))
- (force-output stream))))))
- ;; Now check if we get a positive reply.
- (destructuring-bind (response . rest)
- (read-line-and-split stream)
- (cond
- ((string= response "OK")
- ;; Yay, we are authenticated. REST containts the hex-encoded
- ;; server GUID, but I guess we don't need that.
- t)
- ((string= response "REJECTED")
- (format t "~&DBUS_COOKIE_SHA1 authentication failed:~{ ~A~}" rest)
- nil)
- (t
- (error "Unexpected reply from DBUS server: ~A~{ ~A~}" response rest)))))
-
-;;; Anonymous auth
-
-(defun try-anonymous-auth (stream)
- ;; XXX
- nil
- )
(defun dbus-connect (host port)
"Returns an connection to the given `host' and `port'"
View
@@ -0,0 +1,50 @@
+;;; -*- Mode: Lisp -*-
+;;; Copyright (c) 2008 Julian Stecklina
+;;;
+;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
+
+(in-package :blitz.desktop.dbus)
+
+(defun read-line-crlf (stream)
+ "Read a line terminated with a CR/LF pair."
+ (let ((line (read-line stream)))
+ (assert (char= #\Return
+ (char line (1- (length line)))))
+ ;; Using displaced arrays instead of subseq does not seem to offer
+ ;; any advantages on SBCL.
+ (subseq line 0 (1- (length line)))))
+
+(defun format-crlf (stream fmt &rest args)
+ (format t "~?~%" fmt args)
+ (format stream "~?~C~C" fmt args #\Return #\Newline))
+
+(defun octets-to-hex-string (octets)
+ (string-downcase (format nil "~{~2,'0X~}" (coerce octets 'list))))
+
+(defun string-to-hex-string (string)
+ (octets-to-hex-string (sb-ext:string-to-octets string :external-format :ascii)))
+
+;;; Hex string handling
+
+(defun read-line-and-split (stream)
+ (cl-ppcre:split "\\s" (read-line-crlf stream)))
+
+(defun parse-hex-string (string)
+ (declare (type string string))
+ (assert (evenp (length string)))
+ (iter (with output = (make-array (truncate (length string) 2)
+ :element-type '(unsigned-byte 8)))
+ (for out-pos from 0 below (truncate (length string) 2))
+ (declare (type fixnum out-pos))
+ (flet ((dc (index)
+ (let ((c (digit-char-p (char string index) 16)))
+ (or c
+ (error "Bogus string")))))
+ (declare (inline dc))
+ (setf (aref output out-pos)
+ (logand #xFF
+ (logior (ash (dc (* out-pos 2)) 4)
+ (dc (1+ (* out-pos 2)))))))
+ (finally (return output)) ))
+
+;;; EOF

0 comments on commit a861a97

Please sign in to comment.