├── .gitignore ├── package.lisp ├── lang.lisp ├── cl-https-everywhere.asd ├── LICENSE ├── README.markdown ├── rulesets.lisp ├── rewrite.lisp └── compiler.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.tar.gz 2 | rulesets.xml 3 | .overlord 4 | https-everywhere 5 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:cl-https-everywhere 4 | (:use #:cl #:alexandria #:serapeum #:overlord 5 | #:overlord/net) 6 | (:nicknames #:https-everywhere) 7 | (:shadow :if) 8 | (:export 9 | #:rewrite-uri)) 10 | 11 | (in-package :cl-https-everywhere) 12 | 13 | (defmacro if (test then else) 14 | `(cl:if ,test ,then ,else)) 15 | -------------------------------------------------------------------------------- /lang.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-https-everywhere) 2 | 3 | (defun compile-rulesets (file) 4 | (lret ((dict (dict))) 5 | (dolist (ruleset (compile-rulesets-file file)) 6 | (unless (ruleset.disabled ruleset) 7 | (dolist (target (ruleset.targets ruleset)) 8 | (let ((target (string-downcase target))) 9 | (push ruleset (gethash target dict)))))))) 10 | 11 | (vernacular:define-loader-language :cl-https-everywhere/rulesets-file (source) 12 | (compile-rulesets source) 13 | :extension "xml") 14 | -------------------------------------------------------------------------------- /cl-https-everywhere.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-https-everywhere.asd 2 | 3 | (defsystem "cl-https-everywhere" 4 | :description "Use HTTPS Everywhere rules from Lisp." 5 | :author "Paul M. Rodriguez " 6 | :license "MIT" 7 | :depends-on ("alexandria" 8 | "serapeum" 9 | "cl-ppcre" 10 | "fxml" 11 | "uiop" 12 | "quri" 13 | "cl-tld" 14 | "overlord" 15 | "overlord/net" 16 | "vernacular") 17 | :components ((:file "package") 18 | (:file "rulesets" :depends-on ("package")) 19 | (:file "compiler" :depends-on ("rulesets")) 20 | (:file "lang" :depends-on ("compiler")) 21 | (:file "build" :depends-on ("lang")) 22 | (:file "rewrite" :depends-on ("build")))) 23 | 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Paul M. Rodriguez 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | CL-HTTPS-EVERYWHERE parses [HTTPS Everywhere][] rulesets and makes 2 | them available for use in Lisp programs. 3 | 4 | I have not included a copy of the rulesets, simply because I am not 5 | sure what license they are available under. They will be automatically 6 | fetched when first loading the system, and updated on subsequent 7 | loads. 8 | 9 | The sole exported function is `rewrite-uri`, which takes a URI as a 10 | string, rewrites it if possible, and returns three values: 11 | 12 | - The possibly rewritten URI (a string); 13 | - Whether the URI returned is HTTPS; 14 | - And whether any rewriting was done. 15 | 16 | Three values are necessary to distinguish the case where the URI 17 | passed in was *already* an HTTPS URI. 18 | 19 | (rewrite-uri "http://example.com/") 20 | => "http://example.com/", NIL, NIL 21 | 22 | (rewrite-uri "http://www.eff.org/") 23 | => "https://www.eff.org/", T, T 24 | 25 | (rewrite-uri "https://www.eff.org/") 26 | => "https://www.eff.org/", T, NIL 27 | 28 | At the moment the rulesets are fetched by shallow-cloning the HTTPS 29 | Everywhere repository. It is possible that at some point in the future 30 | there may be [a simpler API][API]. If such an API does come along, it 31 | would make keeping the rulesets up-to-date much easier. 32 | 33 | [HTTPS Everywhere]: https://www.eff.org/HTTPS-everywhere 34 | [Overlord]: https://github.com/ruricolist/overlord 35 | [API]: https://github.com/EFForg/https-everywhere/issues/6937 36 | -------------------------------------------------------------------------------- /rulesets.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-https-everywhere) 2 | 3 | (deftype parsed-rule () 4 | '(tuple string string)) 5 | 6 | (deftype scanner () 7 | '(or function null)) 8 | 9 | (defstruct-read-only (compiled-rule (:conc-name rule.)) 10 | (from :type function) 11 | (to :type string)) 12 | 13 | (defstruct-read-only (ruleset 14 | (:conc-name ruleset.) 15 | (:constructor %make-ruleset)) 16 | (name :type string) 17 | (targets :type list) 18 | (rules :type list) 19 | (exclusions :type scanner) 20 | (disabled nil :type boolean)) 21 | 22 | (defun make-ruleset (&key name targets rules exclusions disabled) 23 | (%make-ruleset :name name 24 | :targets targets 25 | :disabled disabled 26 | :rules (mapply #'compile-rule rules) 27 | :exclusions (compile-exclusions exclusions))) 28 | 29 | #+sbcl (declaim (sb-ext:freeze-type compiled-rule)) 30 | #+sbcl (declaim (sb-ext:freeze-type ruleset)) 31 | 32 | (defmethod print-object ((self ruleset) stream) 33 | (print-unreadable-object (self stream :type t) 34 | (format stream "~a" (ruleset.name self)) 35 | (when (ruleset.disabled self) 36 | (format stream " DISABLED")))) 37 | 38 | (defun excluded? (ruleset uri) 39 | (declare (type string uri)) 40 | (etypecase-of scanner (ruleset.exclusions ruleset) 41 | (null nil) 42 | (function (ppcre:scan (ruleset.exclusions ruleset) uri)))) 43 | 44 | (defun literal-target? (target) 45 | (and (stringp target) (not (find #\* target)))) 46 | 47 | (defun parse-target (target) 48 | (check-type target string) 49 | (if (not (find #\* target)) 50 | target 51 | `(:regex ,(~> target 52 | (ppcre:regex-replace "^\\*" _ "^.+") 53 | (ppcre:regex-replace "\\*$" _ "[^.]+$") 54 | (ppcre:regex-replace "\\*" _ "[^.]+"))))) 55 | 56 | (defun uri-host (uri) 57 | (nth-value 2 (quri:parse-uri uri))) 58 | 59 | (defun compile-rule (from to) 60 | (let ((scanner (ppcre:create-scanner from)) 61 | (to (ppcre:regex-replace-all "\\$(\\d+)" to "\\\\\\1"))) ;ouch 62 | (make-compiled-rule :from scanner :to to))) 63 | 64 | (defmethod apply-rule ((rule compiled-rule) string) 65 | (with-slots (from to) rule 66 | (ppcre:regex-replace from string to))) 67 | 68 | (defun compile-exclusions (patterns) 69 | (if (null patterns) nil 70 | (ppcre:create-scanner 71 | (alternation (mapcar (op `(:regex ,_)) patterns))))) 72 | 73 | (defun alternation (choices) 74 | (if (single choices) 75 | (first choices) 76 | `(:alternation ,@choices))) 77 | -------------------------------------------------------------------------------- /rewrite.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-https-everywhere) 2 | 3 | (defun permute-host (host) 4 | "The (undocumented!) logic HTTPS Everywhere uses to match 5 | wildcards." 6 | (assert (not (find #\/ host))) 7 | (let ((segments (split-sequence #\. host))) 8 | (append (loop for i from 0 below (length segments) 9 | collect (with-output-to-string (s) 10 | (loop for j from 0 11 | for (segment . more) on segments 12 | do (if (= i j) 13 | (write-char #\* s) 14 | (write-string segment s)) 15 | (when more 16 | (write-char #\. s))))) 17 | (loop for tail on (cddr segments) 18 | while (length> tail 2) 19 | collect (concat "*." (string-join tail ".")))))) 20 | 21 | (defun get-rulesets (uri) 22 | (let ((host (string-downcase (uri-host uri)))) 23 | (append (gethash host *rulesets*) 24 | (mappend (op (gethash _ *rulesets*)) 25 | (permute-host host))))) 26 | 27 | (defun rewrite-uri (uri) 28 | "Rewrite URI to use HTTPS, if possible. 29 | 30 | Returns three values: 31 | 32 | - The possibly rewritten URI (a string); 33 | - Whether the URI returned is HTTPS; 34 | - And whether any rewriting was done. 35 | 36 | Three values are necessary to distinguish the case where the URI 37 | passed in was *already* an HTTPS URI." 38 | (setf uri (coerce (trim-whitespace uri) 'simple-string)) 39 | (handler-case 40 | (let ((scheme (uri-scheme uri))) 41 | (if (equal scheme "https") 42 | (values uri t nil) 43 | (let ((uri2 (rewrite-uri-1 uri))) 44 | (if (equal uri uri2) 45 | (values uri2 nil nil) 46 | (values uri2 t t))))) 47 | (quri:uri-error () 48 | (values uri nil nil)))) 49 | 50 | (defun rewrite-uri-1 (uri) 51 | (reduce (lambda (uri ruleset) 52 | (if (excluded? ruleset uri) 53 | uri 54 | (reduce (lambda (uri rule) 55 | (apply-rule rule uri)) 56 | (ruleset.rules ruleset) 57 | :initial-value uri))) 58 | (get-rulesets uri) 59 | :initial-value uri)) 60 | 61 | (defun uri-scheme (uri) 62 | (values (quri:parse-uri uri))) 63 | 64 | (assert (equal '("http://example.com/" nil nil) 65 | (multiple-value-list 66 | (rewrite-uri "http://example.com/")))) 67 | 68 | (assert (equal '("https://www.eff.org/" t nil) 69 | (multiple-value-list 70 | (rewrite-uri "https://www.eff.org/")))) 71 | -------------------------------------------------------------------------------- /compiler.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-https-everywhere) 2 | 3 | (defclass rulesets-compiler (fxml.sax:default-handler) 4 | ((compiler :accessor compiler) 5 | (rulesets :initform nil :accessor rulesets))) 6 | 7 | (defmethods rulesets-compiler (self rulesets compiler) 8 | (:method fxml.sax:end-document (self) 9 | (nreverse rulesets)) 10 | (:method fxml.sax:start-element (self ns lname qname attrs) 11 | (string-case lname 12 | ("rulesets") 13 | ("ruleset" 14 | (let ((c (make 'ruleset-compiler))) 15 | (setf compiler c) 16 | (fxml.sax:start-element c ns lname qname attrs))) 17 | (t (fxml.sax:start-element compiler ns lname qname attrs)))) 18 | (:method fxml.sax:end-element (self ns lname qname) 19 | (declare (ignore ns qname)) 20 | (when (equal lname "ruleset") 21 | (let ((ruleset (fxml.sax:end-document compiler))) 22 | (push ruleset rulesets)) 23 | (slot-makunbound self 'compiler)))) 24 | 25 | (defclass ruleset-compiler (fxml.sax:default-handler) 26 | ((name :type string) 27 | (targets :initform nil) 28 | (rules :initform nil) 29 | (exclusions :initform nil) 30 | (disabled :initform nil))) 31 | 32 | (defmacro with-attributes (binds attrs &body body) 33 | "Given a list of (var name) bindings for attributes in ATTRS, do the 34 | bindings, iterating over the list of ATTRS only once." 35 | (let ((binds (loop for bind in binds 36 | if (symbolp bind) 37 | collect (list bind (string-downcase bind)) 38 | else collect bind))) 39 | (once-only (attrs) 40 | `(let ,(mapcar #'car binds) 41 | ;; Do the bindings. 42 | ,(with-gensyms (a) 43 | `(dolist (,a ,attrs) 44 | (string-case (fxml.sax:attribute-local-name ,a) 45 | ,@(loop for (sym name) in binds 46 | collect `(,name (setf ,sym (fxml.sax:attribute-value ,a))))))) 47 | ,@body)))) 48 | 49 | (defmethods ruleset-compiler 50 | (self name disabled targets rules exclusions) 51 | (:method fxml.sax:end-document (self) 52 | (unless rules 53 | (error "No rules")) 54 | (make-ruleset :disabled disabled 55 | :name name 56 | :targets targets 57 | :rules rules 58 | :exclusions exclusions)) 59 | (:method fxml.sax:start-element (self ns lname qname attrs) 60 | (declare (ignore ns qname)) 61 | (string-case lname 62 | ("ruleset" 63 | (with-attributes ((name "name") (off "default_off")) attrs 64 | (when off 65 | (setf disabled t)) 66 | (setf (slot-value self 'name) name))) 67 | ("target" 68 | (with-attributes (host) attrs 69 | (push host targets))) 70 | ("rule" 71 | (with-attributes (from to) attrs 72 | (push (list from to) rules))) 73 | ("exclusions" 74 | (with-attributes (pattern) attrs 75 | (push pattern exclusions)))))) 76 | 77 | (defun compile-ruleset-file (file) 78 | (fxml:parse (pathname file) (make-ruleset-compiler))) 79 | 80 | (defun compile-rulesets-file (file) 81 | (fxml:parse (pathname file) (make-rulesets-compiler))) 82 | 83 | (defun compile-rulesets-stream (stream) 84 | (check-type stream stream) 85 | (fxml:parse stream (make-rulesets-compiler))) 86 | 87 | (defun make-ruleset-compiler () 88 | (make 'ruleset-compiler)) 89 | 90 | (defun make-rulesets-compiler () 91 | (make 'rulesets-compiler)) 92 | --------------------------------------------------------------------------------