Style and formatting improvements

aqua.lisp

@@ -31,7 +31,6 @@
   (let ((pdoc (plump:parse doc))
 	(tests-fail (list))
 	(tests-pass (list)))
-    (format t "AQUA PARSER!~%")
     (lquery:$ pdoc "#cves > tbody > tr > tr > td:nth-child(1) > a"
      	      (combine (attr :href) (text))
      	      (map-apply #'(lambda (url text)

junit.lisp

@@ -36,22 +36,18 @@
       (remove nil
 	      (mapcar
 	       (lambda (child)
-		 (if (listp child)
-		     (if (string= (car child) "testcase")
-			 (progn
-			   (let ((classname nil)
-				 (result nil))
-			     (dolist (a (car (cdr child)))
-			       (cond
-				 ((string= (car a) "classname")
-				  (setf classname (car (cdr a))))
-				 ((string= (car a) "name")
-				  (setf result (car (cdr a))))))
-			     (json:decode-json-from-string
-			      (format nil "{ \"report\": \"junit\", \"result\": \"~A\", \"id\": \"~A\" }"
-				      result classname))))
-			 nil)
+		 (if (and (listp child)
+			  (string= (car child) "testcase"))
+		     (let ((classname nil)
+			   (result nil))
+		       (dolist (a (car (cdr child)))
+			 (cond
+			   ((string= (car a) "classname")
+			    (setf classname (car (cdr a))))
+			   ((string= (car a) "name")
+			    (setf result (car (cdr a))))))
+		       (json:decode-json-from-string
+			(format nil "{ \"report\": \"junit\", \"result\": \"~A\", \"id\": \"~A\" }"
+				result classname)))
 		     nil))
 	       children)))))
-
-

policy.lisp

@@ -63,7 +63,7 @@ based on URL."
 						 :sha1 (flexi-streams:string-to-octets url)))
 					       0 8))))
 
-      (if (fad:directory-exists-p policy-dirname)
+      (when (fad:directory-exists-p policy-dirname)
 	  (sb-ext:delete-directory policy-dirname :recursive t))
 
       (let ((output (inferior-shell:run
@@ -81,8 +81,8 @@ based on URL."
 	      (fail-file (merge-pathnames-as-file policy-pathname #p"FAIL")))
 
 	  (mapc (lambda (file)
-		  (if (not (file-exists-p (namestring file)))
-		      (error (format nil "Policy file \"~A\" missing." file))))
+		  (unless (file-exists-p (namestring file))
+		    (error (format nil "Policy file \"~A\" missing." file))))
 		(list xfail-file pass-file fail-file))
 
 	  (let ((p (make-instance 'policy)))
@@ -100,6 +100,19 @@ based on URL."
 (defparameter *number-matcher*
   (cl-ppcre:create-scanner "^[0-9]+(|\.[0-9]*)"))
 
+(defparameter *numeric-range*
+  (cl-ppcre:create-scanner "^(.+)\.\.(.+)$"))
+
+(defun parse-numeric-range (value)
+  "Extract the numeric values for a double-dotted range."
+  (multiple-value-bind (x y start-array end-array) 
+      (cl-ppcre:scan *numeric-range* value)
+    (values
+     (read-from-string
+      (subseq value (aref start-array 0) (aref end-array 0)))
+     (read-from-string
+      (subseq value (aref start-array 1) (aref end-array 1))))))
+
 (defun compile-scanners (matcher)
   "Given an alist, MATCHER, replace that CDR of each pair with the
 pre-compiled scanner of that regexp string.  The regexp string is
@@ -109,7 +122,9 @@ RANGE-MATCHER."
   (mapcar (lambda (pair)
 	    (cons (car pair)
 		  (if (cl-ppcre:scan *range-matcher* (cdr pair))
-		      ;; TODO Extract the min and max number from the range.
+		      ;; (multiple-value-bind (start end)
+		      ;; 	  (parse-numeric-range (cdr pair))
+		      ;; 	(XXXXXXXXX
 		      (eval `(lambda (s)
 			       (if (cl-ppcre:scan *number-matcher* s)
 				   (let ((num (read-from-string s)))
@@ -135,8 +150,8 @@ RANGE-MATCHER."
 		    (read-from-string (subseq matcher-line 40))
 		  (let ((line (string-trim '(#\Space #\Tab)
 					   (subseq matcher-line (+ 41 location)))))
-		    (if (and (> (length line) 0)
-			     (null (find (char line 0) "#;-")))
+		    (when (and (> (length line) 0)
+			       (null (find (char line 0) "#;-")))
 			(let ((json
 			       (compile-scanners
 				(json:decode-json-from-string line))))
@@ -151,14 +166,14 @@ RANGE-MATCHER."
       (mapc (lambda (matcher)
 	      (let* ((githash (githash matcher))
 		     (log-entry (gethash githash *git-log-table*)))
-		(if (and (null log-entry)
-			 (not (string= githash ; check for local change
-				       "0000000000000000000000000000000000000000")))
-		    (progn
-		      (setf log-entry (inferior-shell:run/lines
-				       (format nil "bash -c \"(cd $(dirname ~A); git log -n 1 -r ~A $(basename ~A))\""
-					       filename githash filename)))
-		      (setf (gethash githash *git-log-table*) log-entry)))
+		(when (and (null log-entry)
+			   (not (string= githash ; check for local change
+					 "0000000000000000000000000000000000000000")))
+		  (progn
+		    (setf log-entry (inferior-shell:run/lines
+				     (format nil "bash -c \"(cd $(dirname ~A); git log -n 1 -r ~A $(basename ~A))\""
+					     filename githash filename)))
+		    (setf (gethash githash *git-log-table*) log-entry)))
 		(setf (slot-value matcher 'log-entry) log-entry)))
 	    patterns)
 
@@ -173,31 +188,32 @@ RANGE-MATCHER."
 
   (let ((red-or-green :GREEN))
     (let ((result (mapcar (lambda (result)
-			   (cons
-			    (or
-			     ;; Check for exceptions
-			     (find-if (lambda (matcher)
-					(match-candidate-pattern
-					 result (matcher matcher)))
-				      (xfail-matchers policy))
-			     ;; Now check for failures
-			     (let ((red-match
-				    (find-if (lambda (matcher)
-					       (match-candidate-pattern
-						result (matcher matcher)))
-					     (fail-matchers policy))))
-			       (if red-match
-				   (setf red-or-green :RED))
-			       red-match)
-			     ;; No check for passes
-			     (find-if (lambda (matcher)
-					(match-candidate-pattern
-					 result (matcher matcher)))
-				      (pass-matchers policy))
-			     ;; We don't have a match. Let's fail.
-			     (progn
-			       (setf red-or-green :RED)
-			       nil))
-			    result))
+			    (cons
+			     (or
+			      ;; Check for exceptions
+			      (find-if (lambda (matcher)
+					 (match-candidate-pattern
+					  result (matcher matcher)))
+				       (xfail-matchers policy))
+			      ;; Now check for failures
+			      (let ((red-match
+				     (find-if (lambda (matcher)
+						(match-candidate-pattern
+						 result (matcher matcher)))
+					      (fail-matchers policy))))
+				(when red-match
+				  (setf red-or-green :RED))
+				red-match)
+			      ;; No check for passes
+			      (find-if (lambda (matcher)
+					 (match-candidate-pattern
+					  result (matcher matcher)))
+				       (pass-matchers policy))
+			      ;; We don't have a match. Let's fail.
+			      (progn
+				(setf red-or-green :RED)
+				nil))
+			     result))
 			  candidate-result-list)))
       (values red-or-green result))))
+

rlgl-server.lisp

@@ -158,7 +158,8 @@ policy-dir = \"/tmp/policy5/\"
 	(:link :attrs (list :rel "stylesheet"
 			    :href "https://stackpath.bootstrapcdn.com/bootstrap/4.2.1/css/bootstrap.min.css"
 			    :integrity "sha384-GJzZqFGwb1QTTN6wy59ffF1BuGJpLSa9DkKMp0DgiMDm4iYMj70gZWKYbI706tWS"
-			    :crossorigin "anonymous")))
+			    :crossorigin "anonymous"))
+	(:script :src "https://cdnjs.cloudflare.com/ajax/libs/prefixfree/1.0.7/prefixfree.min.js"))
        (:body
 	(:header
 	 (:nav :class "navbar navbar-expand-md navbar-dark fixed-top bg-dark"
@@ -183,15 +184,15 @@ policy-dir = \"/tmp/policy5/\"
 			   (:tr :class "fold"
 				(:td :colspan "2")
 				(:div :class "fold-content"
-				      (if (and matcher
-					       (not (eq (kind matcher) :unknown)))
-					  (let ((log-lines (log-entry matcher)))
-					    (:div :id "border"
-						  (:a :href (format nil commit-url-format (githash matcher))
-						      :target "_blank"
-						      (:pre (str:trim (car log-lines))))
-						  (:pre (str:trim (format nil "~{~A~%~}" (cdr log-lines)))))
-					    (:br)))
+				      (when (and matcher
+						 (not (eq (kind matcher) :unknown)))
+					(let ((log-lines (log-entry matcher)))
+					  (:div :id "border"
+						(:a :href (format nil commit-url-format (githash matcher))
+						    :target "_blank"
+						    (:pre (str:trim (car log-lines))))
+						(:pre (str:trim (format nil "~{~A~%~}" (cdr log-lines)))))
+					  (:br)))
 				      (:div :id "border"
 					    (:pre (cl-json-util:pretty-json (json:encode-json-to-string alist)))))))))))))
 	(:footer :class "fixed-bottom bg-light"
@@ -287,18 +288,18 @@ policy-dir = \"/tmp/policy5/\"
   ;;
   (setf policy:*policy-dir* (pathname
 			     (str:concat (gethash "policy-dir" *config*) "/")))
-  (if (not (initialize-policy-dir *policy-dir*))
-      (sb-ext:quit))
+  (unless (initialize-policy-dir *policy-dir*)
+    (sb-ext:quit))
 
   (setf *policy* (make-policy
 		  "https://gogs-labdroid.apps.home.labdroid.net/green/test-policy.git"))
 
   (let ((srvr (start-server)))
     ;; If ARG is NIL, then exit right away.  This is used by the
     ;; testsuite.
-    (if arg
-	(loop
-	   (sleep 3000)))
+    (when arg
+      (loop
+	 (sleep 3000)))
     srvr))
 
 (defun stop-rlgl-server ()

util.lisp

@@ -30,6 +30,9 @@
     (coerce (loop repeat length collect (aref chars (random (length chars))))
             'string)))
 
+(defvar *url-scanner*
+    (cl-ppcre:create-scanner "((([A-Za-z]{3,9}:(?:\\/\\/)?)(?:[\\-;:&=\\+\\$,\\w]+@)?[A-Za-z0-9\\.\\-]+|(?:www\\.|[\\-;:&=\\+\\$,\\w]+@)[A-Za-z0-9\\.\\-]+)((?:\\/[\\+~%\\/\\.\\w\\-_]*)?\\??(?:[\\-\\+=&;%@\\.\\w_]*)#?(?:[\\.\\!\\/\\\\\\w]*))?)"))
+
 (defun valid-url? (string)
   "Returns T if STRING is a valid url."
-  (not (null (ppcre:scan "((([A-Za-z]{3,9}:(?:\\/\\/)?)(?:[\\-;:&=\\+\\$,\\w]+@)?[A-Za-z0-9\\.\\-]+|(?:www\\.|[\\-;:&=\\+\\$,\\w]+@)[A-Za-z0-9\\.\\-]+)((?:\\/[\\+~%\\/\\.\\w\\-_]*)?\\??(?:[\\-\\+=&;%@\\.\\w_]*)#?(?:[\\.\\!\\/\\\\\\w]*))?)" string))))
+  (not (null (ppcre:scan *url-scanner* string))))