├── .gitattributes ├── LICENSE ├── README.md ├── css.lisp ├── date.lisp ├── docs └── index.html ├── email.lisp ├── html.lisp ├── package.lisp ├── parsing.lisp ├── ratify.asd ├── testing.lisp ├── toolkit.lisp ├── types.lisp ├── uri.lisp └── url.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | 2 | doc/ linguist-vendored 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | About Ratify 2 | ------------ 3 | Ratify is a collection of utilities to perform validation checks and parsing. The main intention of usage for this is in web-applications in order to check form inputs for correctness and automatically parse them into their proper representations or return meaningful errors. 4 | 5 | How To 6 | ------ 7 | Ratify has a load of `TEST-*` functions, each accompanied by a predicate equivalent. The `TEST-*` functions will signal errors of type `RATIFICATION-ERROR` if the test fails, whereas the predicates will simply return `NIL`. Both will return the passed argument unmodified on success. Some of the tests have an equivalent `PARSE-*` function in order to turn the string into a more useful representation. 8 | 9 | The main interaction with Ratify is not supposed to be directly with the `TEST-*` and `PARSE-*` functions however, but rather through the `TEST` and `PARSE` wrapper functions. Both also have a macro shorthand to perform many tests and parsings at once, `PERFORM-COMBINED-TESTS` and `WITH-PARSED-FORMS`. These macros will perform as many tests as possible and only signal an error right after all tests have been made. This error is of type `COMBINED-ERROR`, which contains all the errors that occurred during the testing. 10 | 11 | ``` 12 | (ratify:perform-combined-tests 13 | (:integer "45") 14 | (:date "2014-08-01") 15 | (:ratio "566/21")) 16 | 17 | (ratify:perform-combined-tests 18 | (:integer "4.5" "e") 19 | (:date "2014-08-01" "2014" "2014-55-99") 20 | (:ratio "566/21" "5.6/21")) 21 | ; Evaluation aborted on #<RATIFY-TESTING:COMBINED-ERROR {10074E51D3}>. 22 | ``` 23 | Or to perform parsing: 24 | 25 | ``` 26 | (let ((int "45") 27 | (url "http://foo.bar/baz.jp?what=ever#hashtag") 28 | (uri "things-are://sometimes:complicated@with-all.these/damn?protocols=i'm#telling+you!") 29 | (dt "2014-08-01T21:23:01")) 30 | (ratify:with-parsed-forms ((:integer int) (:url url) (:uri uri) (:datetime dt)) 31 | (list int url uri dt))) 32 | ``` 33 | 34 | If an error occurs, the `ERRORS` function gives access to the list of errors that the `COMBINED-ERROR` contains. For a complete list of testing and parsing functions, please see the [symbol index](http://shinmera.github.io/ratify). The syntax grammar used to describe the valid values in the docstrings of each test is regex with the addition of `` to refer to other tests, sometimes accompanied with a second line that describes limits of the values. 35 | -------------------------------------------------------------------------------- /css.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.css) 2 | 3 | (defvar *css-color-names* '(AliceBlue AntiqueWhite Aqua Aquamarine Azure Beige Bisque Black BlanchedAlmond Blue BlueViolet Brown BurlyWood CadetBlue Chartreuse Chocolate Coral CornflowerBlue Cornsilk Crimson Cyan DarkBlue DarkCyan DarkGoldenrod DarkGray DarkGreen DarkKhaki DarkMagenta DarkOliveGreen DarkOrange DarkOrchid DarkRed DarkSalmon DarkSeaGreen DarkSlateBlue DarkSlateGray DarkTurquoise DarkViolet DeepPink DeepSkyBlue DimGray DodgerBlue FireBrick FloralWhite ForestGreen Fuchsia Gainsboro GhostWhite Gold Goldenrod Gray Green GreenYellow Honeydew HotPink IndianRed Indigo Ivory Khaki Lavender LavenderBlush LawnGreen LemonChiffon LightBlue LightCoral LightCyan LightGoldenrodYellow LightGreen LightGrey LightPink LightSalmon LightSeaGreen LightSkyBlue LightSlateGray LightSteelBlue LightYellow Lime LimeGreen Linen Magenta Maroon MediumAquamarine MediumBlue MediumOrchid MediumPurple MediumSeaGreen MediumSlateBlue MediumSpringGreen MediumTurquoise MediumVioletRed MidnightBlue MintCream MistyRose Moccasin NavajoWhite Navy OldLace Olive OliveDrab Orange OrangeRed Orchid PaleGoldenrod PaleGreen PaleTurquoise PaleVioletRed PapayaWhip PeachPuff Peru Pink Plum PowderBlue Purple Red RosyBrown RoyalBlue SaddleBrown Salmon SandyBrown SeaGreen Seashell Sienna Silver SkyBlue SlateBlue SlateGray Snow SpringGreen SteelBlue Tan Teal Thistle Tomato Turquoise Violet Wheat White WhiteSmoke Yellow YellowGreen)) 4 | 5 | (defun css-argslist (argslist start end) 6 | (unless (and (<= 2 (- end start)) 7 | (char= (aref argslist start) #\() 8 | (char= (aref argslist (1- end)) #\))) 9 | (ratification-error argslist "Invalid arguments list.")) 10 | (cl-ppcre:split "\\s*,\\s*" (subseq argslist (1+ start) (1- end)))) 11 | 12 | (defun test-rgb (vals) 13 | (loop for val in vals 14 | do (unless (<= 0 (parse-integer val) 255) 15 | (ratification-error val "RGB values must be an integer between 0 and 255.")))) 16 | 17 | (defun test-percentage (p) 18 | (unless (char= (aref p (1- (length p))) #\%) 19 | (ratification-error p "Percentage sign missing.")) 20 | (unless (<= 0 (parse-integer p :end (1- (length p))) 100) 21 | (ratification-error p "Percentage must be an integer between 0 and 100."))) 22 | 23 | (defun test-hsl (vals) 24 | (destructuring-bind (h s l) vals 25 | (unless (<= 0 (parse-integer h) 360) 26 | (ratification-error h "Hue must be an integer between 0 and 360.")) 27 | (test-percentage s) 28 | (test-percentage l))) 29 | 30 | (define-test color (color start end) 31 | (unless (<= 4 (- end start)) 32 | (ratification-error color "Color must be at least four characters long.")) 33 | (cond ((string= color "#" :start1 start :end1 (1+ start)) 34 | (unless (or (= 4 (length color)) 35 | (= 7 (length color))) 36 | (ratification-error color "A HEX colour must be either 3 or 6 ciphers.")) 37 | (parse-integer color :radix 16 :start (1+ start) :end end)) 38 | 39 | ((string= color "rgba" :start1 start :end1 (+ start 4)) 40 | (let ((args (css-argslist color (+ start 4) end))) 41 | (unless (= 4 (length args)) 42 | (ratification-error color "RGBA requires 4 arguments.")) 43 | (test-rgb (subseq args 0 3)) 44 | (unless (<= 0 (parse-float:parse-float (fourth args)) 1) 45 | (ratification-error color "Alpha value must be between 0.0 and 1.0")))) 46 | 47 | ((string= color "rgb" :start1 start :end1 (+ start 3)) 48 | (let ((args (css-argslist color (+ start 3) end))) 49 | (unless (= 3 (length args)) 50 | (ratification-error color "RGB requires 3 arguments.")) 51 | (test-rgb args))) 52 | 53 | ((string= color "hsla" :end1 4) 54 | (let ((args (css-argslist color (+ start 4) end))) 55 | (unless (= 4 (length args)) 56 | (ratification-error color "RGBA requires 4 arguments.")) 57 | (test-hsl (subseq args 0 3)) 58 | (unless (<= 0 (parse-float:parse-float (fourth args)) 1) 59 | (ratification-error color "Alpha value must be between 0.0 and 1.0")))) 60 | 61 | ((string= color "hsl" :end1 3) 62 | (let ((args (css-argslist color (+ start 3) end))) 63 | (unless (= 3 (length args)) 64 | (ratification-error color "RGB requires 3 arguments.")) 65 | (test-hsl args))) 66 | 67 | (T 68 | (unless (find color *css-color-names* :test #'string-equal) 69 | (ratification-error color "Color ~s is not a known colour name or scheme." color))))) 70 | 71 | (define-test property (property start end) 72 | (loop with in-paren = 0 73 | with in-string = NIL 74 | for prev = #\Space then char 75 | for i from start below end 76 | for char = (char property i) 77 | do (unless (char= #\\ prev) 78 | (case char 79 | (#\( (incf in-paren)) 80 | (#\) (decf in-paren)) 81 | (#\" (setf in-string (not in-string))) 82 | (T (when (and (not in-string) (= in-paren 0) (find char "{}[];:/*\\")) 83 | (ratification-error property "Character ~a is not allowed outside of strings." char))))) 84 | finally (when (or in-string (/= in-paren 0)) 85 | (ratification-error property "Property ~s contains unbalanced delimiters." property)))) 86 | -------------------------------------------------------------------------------- /date.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.date) 2 | 3 | ;; According to http://tools.ietf.org/html/rfc3339 4 | ;; We make the special exception that the date/time numbers 5 | ;; do not have to contain a leading zero, and the T/Z 6 | ;; splitters need to be in uppercase. 7 | 8 | (define-test year (year start end) 9 | "Tests for a valid year. 10 | 11 | [0-9]{4}" 12 | (unless (= 4 (- end start)) 13 | (ratification-error year "Year must be a 4-digit integer.")) 14 | (loop for i from start below end 15 | for char = (char year i) 16 | do (unless (char<= #\0 char #\9) 17 | (ratification-error year "Character ~a is not a digit." char)))) 18 | 19 | (define-parser year (year start end) 20 | "Parses the year into an integer." 21 | (parse-integer year :start start :end end)) 22 | 23 | (define-test month (month start end) 24 | "Tests for a valid month. 25 | 26 | [0-9]{1,2} 27 | 1<=val<=12" 28 | (let ((month (ignore-errors (parse-integer month :start start :end end)))) 29 | (unless month 30 | (ratification-error month "Month must be an integer.")) 31 | (unless (<= 1 month 12) 32 | (ratification-error month "Month must be an integer between 1 and 12.")))) 33 | 34 | (define-parser month (month start end) 35 | "Parses the month into an integer." 36 | (parse-integer month :start start :end end)) 37 | 38 | (define-test day (day start end) 39 | "Tests for a valid day. 40 | 41 | [0-9]{1,2} 42 | 1<=val<=31" 43 | (let ((day (ignore-errors (parse-integer day :start start :end end)))) 44 | (unless day 45 | (ratification-error day "Day must be an integer.")) 46 | (unless (<= 1 day 31) 47 | (ratification-error day "Day must be an integer between 1 and 31.")))) 48 | 49 | (define-parser day (day start end) 50 | "Parses the day into an integer" 51 | (parse-integer day :start start :end end)) 52 | 53 | (define-test hour (hour start end) 54 | "Tests for a valid hour. 55 | 56 | [0-9]{1,2} 57 | 0<=val<=23" 58 | (let ((hour (ignore-errors (parse-integer hour :start start :end end)))) 59 | (unless hour 60 | (ratification-error hour "Hour must be an integer.")) 61 | (unless (<= 0 hour 23) 62 | (ratification-error hour "Hour must be an integer between 0 and 23.")))) 63 | 64 | (define-parser hour (hour start end) 65 | "Parses the hour into an integer" 66 | (parse-integer hour :start start :end end)) 67 | 68 | (define-test minute (minute start end) 69 | "Tests for a valid minute. 70 | 71 | [0-9]{1,2} 72 | 0<=val<=59" 73 | (let ((minute (ignore-errors (parse-integer minute :start start :end end)))) 74 | (unless minute 75 | (ratification-error minute "Minute must be an integer.")) 76 | (unless (<= 0 minute 59) 77 | (ratification-error minute "Minute must be an integer between 0 and 59.")))) 78 | 79 | (define-parser minute (minute start end) 80 | "Parses the minute into an integer" 81 | (parse-integer minute :start start :end end)) 82 | 83 | (define-test second (second start end) 84 | "Tests for a valid second. 85 | 86 | [0-9]{1,2} 87 | 0<=val<=59" 88 | (let ((second (ignore-errors (parse-integer second :start start :end end)))) 89 | (unless second 90 | (ratification-error second "Second must be an integer.")) 91 | (unless (<= 0 second 59) 92 | (ratification-error second "Second must be an integer between 0 and 59.")))) 93 | 94 | (define-parser second (second start end) 95 | "Parses the second into an integer" 96 | (parse-integer second :start start :end end)) 97 | 98 | (define-test offset (offset start end) 99 | "Tests for a valid offset. 100 | 101 | [-+]hour:minute" 102 | (when (= 0 (- end start)) 103 | (ratification-error offset "Offset must be composed of +/-hours:minutes .")) 104 | (unless (or (char= #\- (aref offset start)) 105 | (char= #\+ (aref offset start))) 106 | (ratification-error offset "Offset must begin with either + or - .")) 107 | (or (cl-ppcre:register-groups-bind (hour minute) ("^[-+]([^:]+):([^:]+)$" offset :start start :end end) 108 | (test-hour hour) 109 | (test-minute minute)) 110 | (ratification-error offset "Offset must specify hours and minutes."))) 111 | 112 | (define-parser offset (offset start end) 113 | "Parses the offset into a list of (DIR HOUR MINUTE), wherein DIR is 114 | a string of either \"+\" or \"-\", denoting the direction of the offset. " 115 | (cl-ppcre:register-groups-bind (dir hour minute) ("^([-+])([^:]+):([^:]+)$" offset :start start :end end) 116 | (list 117 | dir 118 | (parse-integer (or hour "")) 119 | (parse-integer (or minute ""))))) 120 | 121 | (define-test time (time start end) 122 | "Tests for a valid time. 123 | 124 | ::Z" 125 | (or (cl-ppcre:register-groups-bind (hour minute second NIL offset) ("^([^:]+):([^:]+):([^Z]+)(Z(.+))?$" time :start start :end end) 126 | (when offset 127 | (test-offset offset)) 128 | (test-hour hour) 129 | (test-minute minute) 130 | (test-second second)) 131 | (ratification-error time "Time must be made up of hour:minute:second followed by an optional offset: Z+hours:minutes ."))) 132 | 133 | (define-parser time (time start end) 134 | "Parses the given time into a LOCAL-TIME:TIMESTAMP object." 135 | (local-time:parse-timestring time :start start :end end :allow-missing-date-part T :allow-missing-time-part NIL :allow-missing-timezone-part T)) 136 | 137 | (define-test date (date start end) 138 | "Tests for a valid date. 139 | 140 | --" 141 | (let ((parts (cl-ppcre:split "-" date :start start :end end))) 142 | (unless (= 3 (length parts)) 143 | (ratification-error date "Date must be made up of year-month-day .")) 144 | (destructuring-bind (year month day) parts 145 | (test-year year) 146 | (test-month month) 147 | (test-day day)))) 148 | 149 | (define-parser date (date start end) 150 | "Parses the given date into a LOCAL-TIME:TIMESTAMP object." 151 | (local-time:parse-timestring date :start start :end end :allow-missing-date-part NIL :allow-missing-time-part T :allow-missing-timezone-part T)) 152 | 153 | (define-test datetime (datetime start end) 154 | "Tests for a valid datetime. 155 | 156 | --T::Z" 157 | (let ((parts (cl-ppcre:split "T" datetime :start start :end end))) 158 | (unless (<= 1 (length parts) 2) 159 | (ratification-error datetime "Datetime must specify at least the date and at most date and time separated by T.")) 160 | (test-date (first parts)) 161 | (when (second parts) 162 | (test-time (second parts))))) 163 | 164 | (define-parser datetime (datetime start end) 165 | "Parses the given datetime into a LOCAL-TIME:TIMESTAMP object. 166 | The only part that is allowed to be omitted is the timezone offset specification." 167 | (local-time:parse-timestring datetime :start start :end end :allow-missing-date-part NIL :allow-missing-time-part NIL :allow-missing-timezone-part T)) 168 | -------------------------------------------------------------------------------- /email.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.email) 2 | 3 | (defun email-atpos (email start end) 4 | (let ((atpos (position #\@ email :start start :end end))) 5 | (unless atpos (ratification-error email "No @ found.")) 6 | atpos)) 7 | 8 | (define-test local-part (local-part start end) 9 | "Tests for a valid email local-part. 10 | 11 | [!#$%&'*+-/=?^_`{|}~a-zA-Z0-9][!#$%&'*+-/=?^_`{|}~.a-zA-Z0-9]{0,63}" 12 | (let ((length (- end start))) 13 | (unless (<= 1 length 64) 14 | (ratification-error local-part "Local-part of an email must be between 1 and 64 characters long.")) 15 | (loop for i from start below end 16 | for char = (char local-part i) 17 | ;; Caveat: We hope the implementation uses ascii or unicode. 18 | ;; We cannot use alpha-char-p since depending on implementation characters like ü pass as well. 19 | do (unless (or (true-alphanumeric-p char) 20 | ;; dot, but not at start or end 21 | (and (char= char #\.) 22 | (/= i start) 23 | (/= i (1- end))) 24 | ;; Special characters 25 | (find char "!#$%&'*+-/=?^_`{|}~" :test #'char=) 26 | #+(or sb-unicode unicode) 27 | (char> char #\Rubout)) 28 | (ratification-error local-part 29 | #+(or sb-unicode unicode) "~a is not a valid character. Permitted are a-z A-Z 0-9 . ! # $ % & ' * + - / = ? ^ _ ` { | } ~~ or unicode characters." 30 | #-(or sb-unicode unicode) "~a is not a valid character. Permitted are a-z A-Z 0-9 . ! # $ % & ' * + - / = ? ^ _ ` { | } ~~" 31 | char))))) 32 | 33 | (define-test email (email start end) 34 | "Test an e-mail address for validity according to http://en.wikipedia.org/wiki/Email_address#Syntax 35 | 36 | @" 37 | (let ((atpos (email-atpos email start end))) 38 | (test-local-part email 0 atpos) 39 | (unless (< (1+ atpos) end) 40 | (ratification-error email "No domain found.")) 41 | (test-domain email (1+ atpos) end))) 42 | -------------------------------------------------------------------------------- /html.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.html) 2 | 3 | (define-test checkbox (input start end) 4 | (unless (or (not input) (stringp input)) 5 | (ratification-error input "Must be a string or NIL."))) 6 | 7 | ;; color 8 | 9 | ;; date 10 | 11 | ;; datetime 12 | 13 | (define-test datetime-local (datetime start end) 14 | (test-datetime datetime start end)) 15 | 16 | ;; email 17 | 18 | (define-test file (file start end) 19 | (unless (pathnamep file) 20 | (ratification-error file "Not a file."))) 21 | 22 | ;; month 23 | 24 | ;; number 25 | 26 | (define-test password (pw start end) 27 | (test-text pw start end)) 28 | 29 | (define-test radio (radio start end) 30 | (test-checkbox radio start end)) 31 | 32 | (define-test range (range start end) 33 | (test-float range start end)) 34 | 35 | (define-test search (search start end) 36 | (test-text search start end)) 37 | 38 | (define-test tel (tel start end) 39 | ;; We can't do better than this. Curse internationality. 40 | (test-text tel start end)) 41 | 42 | (define-test text (text start end) 43 | (when (find #\Newline text :start start :end end) 44 | (ratification-error text "Text must be a single line."))) 45 | 46 | (define-test textarea (text start end) 47 | text) 48 | 49 | ;; time 50 | 51 | ;; url 52 | 53 | ;; week 54 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:ratify-toolkit 4 | (:nicknames #:org.tymoonnext.ratify.toolkit) 5 | (:use #:cl) 6 | (:export 7 | #:ratification-error 8 | #:message 9 | #:test-object 10 | #:ratification-error 11 | #:make-keyword 12 | #:true-alpha-p 13 | #:true-alphanumeric-p)) 14 | 15 | (defpackage #:ratify-testing 16 | (:nicknames #:org.tymoonnext.ratify.testing) 17 | (:use #:cl #:ratify-toolkit) 18 | (:export 19 | #:test-failed 20 | #:test-name 21 | #:test-object 22 | #:cause 23 | #:combined-error 24 | #:errors 25 | #:test 26 | #:define-test 27 | #:with-skipping 28 | #:skip-error 29 | #:skippable-error 30 | #:with-errors-combined 31 | #:perform-test 32 | #:perform-tests 33 | #:perform-combined-tests)) 34 | 35 | (defpackage #:ratify-parsing 36 | (:nicknames #:org.tymoonnext.ratify.parsing) 37 | (:use #:cl #:ratify-testing #:ratify-toolkit) 38 | (:export 39 | #:parser 40 | #:define-parser 41 | #:parse 42 | #:with-parsed-forms)) 43 | 44 | (defpackage #:ratify-uri 45 | (:nicknames #:org.tymoonnext.ratify.uri) 46 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-parsing) 47 | (:export 48 | #:test-ipv4 49 | #:test-ipv6 50 | #:test-ip 51 | #:test-host 52 | #:test-scheme 53 | #:test-user 54 | #:test-port 55 | #:test-authority 56 | #:test-path-segment 57 | #:test-rootless-path 58 | #:test-absolute-path 59 | #:test-hierarchical-part 60 | #:test-query 61 | #:test-fragment 62 | #:test-uri 63 | #:ipv4-p 64 | #:ipv6-p 65 | #:ip-p 66 | #:host-p 67 | #:scheme-p 68 | #:user-p 69 | #:port-p 70 | #:authority-p 71 | #:path-segment-p 72 | #:rootless-path-p 73 | #:absolute-path-p 74 | #:hierarchical-part-p 75 | #:query-p 76 | #:fragment-p 77 | #:uri-p)) 78 | 79 | (defpackage #:ratify-url 80 | (:nicknames #:org.tymoonnext.ratify.url) 81 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-uri) 82 | (:export 83 | #:*permitted-protocols* 84 | #:test-hostname 85 | #:test-domain 86 | #:test-protocol 87 | #:test-url 88 | #:hostname-p 89 | #:domain-p 90 | #:protocol-p 91 | #:url-p)) 92 | 93 | (defpackage #:ratify-email 94 | (:nicknames #:org.tymoonnext.ratify.email) 95 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-url) 96 | (:export 97 | #:test-email 98 | #:email-p)) 99 | 100 | (defpackage #:ratify-css 101 | (:nicknames #:org.tymoonnext.ratify.css) 102 | (:use #:cl #:ratify-toolkit #:ratify-testing) 103 | (:export 104 | #:test-color 105 | #:test-property 106 | #:color-p 107 | #:property-p)) 108 | 109 | (defpackage #:ratify-date 110 | (:nicknames #:org.tymoonnext.ratify.date #:org.tymoonnext.ratify.time #:ratify-time) 111 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-parsing) 112 | (:export 113 | #:test-year 114 | #:test-month 115 | #:test-day 116 | #:test-hour 117 | #:test-minute 118 | #:test-second 119 | #:test-offset 120 | #:test-time 121 | #:test-date 122 | #:test-datetime 123 | #:parse-year 124 | #:parse-month 125 | #:parse-day 126 | #:parse-hour 127 | #:parse-minute 128 | #:parse-second 129 | #:parse-offset 130 | #:parse-time 131 | #:parse-date 132 | #:parse-datetime 133 | #:year-p 134 | #:month-p 135 | #:day-p 136 | #:hour-p 137 | #:minute-p 138 | #:second-p 139 | #:offset-p 140 | #:time-p 141 | #:date-p 142 | #:datetime-p)) 143 | 144 | (defpackage #:ratify-types 145 | (:nicknames #:org.tymoonnext.ratify.types) 146 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-parsing) 147 | (:export 148 | #:test-bit 149 | #:test-unsigned-integer 150 | #:test-integer 151 | #:test-ratio 152 | #:test-rational 153 | #:test-float 154 | #:test-real 155 | #:test-complex 156 | #:test-number 157 | #:test-boolean 158 | #:test-character 159 | #:test-string 160 | #:test-alphabetic 161 | #:test-numeric 162 | #:test-alphanumeric 163 | #:parse-bit 164 | #:parse-unsigned-integer 165 | #:parse-integer 166 | #:parse-ratio 167 | #:parse-rational 168 | #:parse-float 169 | #:parse-real 170 | #:parse-complex 171 | #:parse-number 172 | #:parse-boolean 173 | #:parse-character 174 | #:parse-string 175 | #:bit-p 176 | #:unsigned-integer-p 177 | #:integer-p 178 | #:ratio-p 179 | #:rational-p 180 | #:float-p 181 | #:real-p 182 | #:complex-p 183 | #:number-p 184 | #:boolean-p 185 | #:character-p 186 | #:string-p 187 | #:alphabetic-p 188 | #:numeric-p 189 | #:alphanumeric-p)) 190 | 191 | (defpackage #:ratify-html 192 | (:nicknames #:org.tymoonnext.ratify.html) 193 | (:use #:cl #:ratify-toolkit #:ratify-testing #:ratify-url #:ratify-email #:ratify-date #:ratify-css #:ratify-types) 194 | (:export 195 | #:test-checkbox 196 | #:test-color 197 | #:test-date 198 | #:test-datetime 199 | #:test-datetime-local 200 | #:test-email 201 | #:test-file 202 | #:test-month 203 | #:test-number 204 | #:test-password 205 | #:test-radio 206 | #:test-range 207 | #:test-search 208 | #:test-tel 209 | #:test-text 210 | #:test-textarea 211 | #:test-time 212 | #:test-url 213 | #:test-week 214 | #:checkbox-p 215 | #:color-p 216 | #:date-p 217 | #:datetime-p 218 | #:datetime-local-p 219 | #:email-p 220 | #:file-p 221 | #:month-p 222 | #:number-p 223 | #:password-p 224 | #:radio-p 225 | #:range-p 226 | #:search-p 227 | #:tel-p 228 | #:text-p 229 | #:textarea-p 230 | #:time-p 231 | #:url-p 232 | #:week-p)) 233 | 234 | (defpackage #:ratify 235 | (:nicknames #:org.tymoonnext.ratify) 236 | (:use #:cl)) 237 | 238 | (let ((ratify (find-package '#:ratify))) 239 | (dolist (pkg '(#:ratify-toolkit #:ratify-testing #:ratify-parsing #:ratify-email #:ratify-css #:ratify-uri #:ratify-url #:ratify-date #:ratify-types #:ratify-html)) 240 | (do-external-symbols (symb (find-package pkg)) 241 | (import symb ratify) 242 | (export symb ratify)))) 243 | -------------------------------------------------------------------------------- /parsing.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.parsing) 2 | 3 | (defvar *parsers* (make-hash-table) 4 | "Hash map mapping keywords to parsing functions. 5 | A parse function should take one argument.") 6 | 7 | (defun parser (name) 8 | "Returns the function associated with the NAME. 9 | If no such parser can be found, #'IDENTITY is returned. 10 | The name is converted to a keyword. 11 | 12 | SETF-able." 13 | (or (gethash (make-keyword name) *parsers*) 14 | #'identity)) 15 | 16 | (defun (setf parser) (function name) 17 | "Sets a function to be used for a certain parser. 18 | The name is converted to a keyword." 19 | (setf (gethash (make-keyword name) *parsers*) function)) 20 | 21 | (defmacro define-parser (name (param start end) &body body) 22 | "Defines a new parse function with NAME. 23 | PARAM will be bound to the object to parse, which is a string unless otherwise 24 | specified, START to the starting index (inc) and END to the ending index (exc). 25 | 26 | This function creates two other functions automatically: 27 | PARSE-name This is the main test function. If the test fails, an error of 28 | type RATIFICATION-ERROR should be returned. If the test succeeds 29 | the argument passed to it is always returned." 30 | (let* ((*print-case* (readtable-case *readtable*)) 31 | (func-name (intern (format NIL "~a-~a" 'parse name)))) 32 | `(setf 33 | (parser ,(string name)) 34 | (defun ,func-name (,param &optional (,start 0) (,end (length ,param))) 35 | (declare (ignorable ,start ,end)) 36 | ,@body)))) 37 | 38 | (defun parse (parser-name object) 39 | "Attempts to parse OBJECT using the parser named by PARSER-NAME. 40 | 41 | Automatically establishes a SKIP-ERROR restart as per WITH-SKIPPING. 42 | Performs exactly two operations: 43 | 1) Call the test function of name PARSER-NAME on the object 44 | 2) Call the parse function of name PARSER-NAME on the object" 45 | (with-skipping 46 | (ratify-testing::perform-test-no-skip parser-name object) 47 | (funcall (parser parser-name) object))) 48 | 49 | (defmacro with-parsed-forms (parse-forms &body body) 50 | "Performs a series of parsing operations on objects and rebinds their symbols to the results. 51 | 52 | PARSE-FORMS ::= PARSE-FORM* 53 | PARSE-FORM ::= (parser-name object*) 54 | See PARSE. 55 | 56 | The parse operations are performed within WITH-ERRORS-COMBINED. 57 | As such all parse operations are always performed and only one or no 58 | conditions are signalled as part of the parsing. 59 | See WITH-ERRORS-COMBINED." 60 | `(destructuring-bind ,(loop with vars = () 61 | for (test . objects) in parse-forms 62 | do (loop for object in objects 63 | do (push object vars)) 64 | finally (return (nreverse vars))) 65 | (with-errors-combined 66 | (list 67 | ,@(loop with forms = () 68 | for (test . objects) in parse-forms 69 | do (dolist (object objects) 70 | (push `(parse ,(make-keyword test) ,object) forms)) 71 | finally (return (nreverse forms))))) 72 | ,@body)) 73 | -------------------------------------------------------------------------------- /ratify.asd: -------------------------------------------------------------------------------- 1 | (defsystem ratify 2 | :name "Ratify" 3 | :version "0.1.0" 4 | :license "zlib" 5 | :author "Yukari Hafner " 6 | :maintainer "Yukari Hafner " 7 | :description "A collection of utilities to ratify, validate and parse inputs." 8 | :homepage "https://Shinmera.github.io/ratify/" 9 | :bug-tracker "https://github.com/Shinmera/ratify/issues" 10 | :source-control (:git "https://github.com/Shinmera/ratify.git") 11 | :serial T 12 | :components ((:file "package") 13 | (:file "toolkit") 14 | (:file "testing") 15 | (:file "parsing") 16 | (:file "uri") 17 | (:file "url") 18 | (:file "email") 19 | (:file "css") 20 | (:file "date") 21 | (:file "types") 22 | (:file "html")) 23 | :depends-on (:cl-ppcre 24 | :local-time 25 | :parse-float)) 26 | -------------------------------------------------------------------------------- /testing.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.testing) 2 | 3 | (define-condition test-failed (error) 4 | ((%test-name :initarg :test-name :initform (error "Test-name required") :accessor test-name) 5 | (%test-object :initarg :test-object :initform (error "Test-object required") :accessor test-object) 6 | (%cause :initarg :cause :initform NIL :accessor cause)) 7 | (:report (lambda (c s) (format s "Testing ~s for ~a failed~:[.~;:~%~:*~a~]" 8 | (test-object c) (test-name c) (cause c)))) 9 | (:documentation "Condition signalled when a test fails. 10 | The TEST-NAME slot specifies the name of the test that was run. 11 | The TEST-OBJECT slot contains the object that failed the test. 12 | The CAUSE slot contains the original error object, usually of type RATIFICATION-ERROR.")) 13 | 14 | (define-condition combined-error (error) 15 | ((errors :initarg :errors :initform () :accessor errors)) 16 | (:report (lambda (c s) (format s "~:[No errors occurred.~;~:*Errors occurred: ~{~%> ~a~}~]" 17 | (errors c)))) 18 | (:documentation "An error object that holds a combination of other errors. 19 | Used to test multiple things before unwinding the stack.")) 20 | 21 | (defvar *tests* (make-hash-table) 22 | "Hash map mapping keywords to testing functions. 23 | A test function should take one argument.") 24 | 25 | (defun test (name) 26 | "Returns the function associated with the NAME. 27 | If no such test can be found, an error is signalled. 28 | The name is converted to a keyword. 29 | 30 | SETF-able." 31 | (or (gethash (make-keyword name) *tests*) 32 | (error "No such test ~s." name))) 33 | 34 | (defun (setf test) (function name) 35 | "Sets a function to be used for a certain test. 36 | The name is converted to a keyword." 37 | (setf (gethash (make-keyword name) *tests*) function)) 38 | 39 | (defmacro define-test (name (param start end) &body body) 40 | "Defines a new test function with NAME. 41 | PARAM will be bound to the object to test, which is a string unless otherwise 42 | specified, START to the starting index (inc) and END to the ending index (exc). 43 | 44 | This function creates two other functions automatically: 45 | TEST-name This is the main test function. If the test fails, an error of 46 | type RATIFICATION-ERROR should be returned. If the test succeeds 47 | the argument passed to it is always returned. 48 | name-P Equivalent to the TEST- function, except that it simply returns 49 | NIL on failure instead of signalling an error." 50 | (let* ((*print-case* (readtable-case *readtable*)) 51 | (func-name (intern (format NIL "~a-~a" 'test name))) 52 | (pred-name (intern (format NIL "~a-~a" name 'p)))) 53 | `(progn 54 | (setf (test ,(string name)) 55 | (defun ,func-name (,param &optional (,start 0) (,end (length ,param))) 56 | (declare (ignorable ,start ,end)) 57 | ,@(when (stringp (car body)) 58 | (list (pop body))) 59 | (let ((,param ,param)) 60 | ,@body) 61 | ,param)) 62 | (defun ,pred-name (,param &optional (,start 0) (,end (length ,param))) 63 | ,(format NIL "Predicate version of ~a, returns the passed value on success, NIL on error." func-name) 64 | (ignore-errors 65 | (,func-name ,param ,start ,end)))))) 66 | 67 | (defmacro with-skipping (&body body) 68 | "Marks the body as being skippable if an error occurs within. 69 | This establishes the restart SKIP-ERROR." 70 | `(with-simple-restart (skip-error "Skip the error and continue.") 71 | ,@body)) 72 | 73 | (defun skippable-error (datum &rest arguments) 74 | "Signals a skippable error as per WITH-SKIPPING." 75 | (with-skipping 76 | (apply #'error datum arguments))) 77 | 78 | (defmacro with-errors-combined (&body body) 79 | "Executes the body with special error handling. 80 | Errors are gathered in a COMBINED-ERROR, which is finally signalled once 81 | the body finishes or an error occurs and no SKIP-ERROR restart can be found. 82 | 83 | If no errors occur within the body, the last value of the body is returned 84 | as per PROGN." 85 | (let ((combined-error (gensym "COMBINED-ERROR"))) 86 | `(let ((,combined-error (make-instance 'combined-error))) 87 | (prog1 88 | (handler-bind ((error #'(lambda (err) 89 | (push err (errors ,combined-error)) 90 | (if (find-restart 'skip-error) 91 | (invoke-restart 'skip-error) 92 | (error ,combined-error))))) 93 | ,@body) 94 | (when (errors ,combined-error) 95 | (error ,combined-error)))))) 96 | 97 | (defun perform-test-no-skip (test-name test-object) 98 | (handler-bind ((error #'(lambda (err) 99 | (error 'test-failed :cause err :test-object test-object :test-name test-name)))) 100 | (funcall (test test-name) test-object))) 101 | 102 | (defun perform-test (test-name test-object) 103 | "Performs the test named by TEST-NAME on TEST-OBJECT. 104 | 105 | Automatically establishes a SKIP-ERROR restart and resignals any error 106 | as a new error of type TEST-FAILED." 107 | (with-skipping 108 | (perform-test-no-skip test-name test-object))) 109 | 110 | (defmacro perform-tests (&body test-forms) 111 | "Performs a series of tests. 112 | 113 | TEST-FORMS ::= TEST-FORM* 114 | TEST-FORM ::= (test-name test-object*) 115 | See TEST." 116 | `(progn 117 | ,@(loop with forms = () 118 | for (test . objects) in test-forms 119 | do (dolist (object objects) 120 | (push `(perform-test ,(make-keyword test) ,object) forms)) 121 | finally (return (nreverse forms))) 122 | T)) 123 | 124 | (defmacro perform-combined-tests (&body test-forms) 125 | "Same as PERFORM-TESTS, except with WITH-ERRORS-COMBINED in effect." 126 | `(with-errors-combined 127 | (perform-tests ,@test-forms))) 128 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.toolkit) 2 | 3 | (define-condition ratification-error (error) 4 | ((%message :initarg :message :initform NIL :accessor message) 5 | (%test-object :initarg :test-object :initform (error "Test-object required") :accessor test-object)) 6 | (:report (lambda (c s) (format s "Error during ratification of ~s.~@[~%~a~]" 7 | (test-object c) (message c)))) 8 | (:documentation "Error signalled if a test function hit an error in the format. 9 | The TEST-OBJECT slot contains the object that failed to pass the test. 10 | The MESSAGE slot contains a verbal explanation of what went wrong.")) 11 | 12 | (defun ratification-error (test-object &optional message &rest format-args) 13 | "Shorthand function to signal a RATIFICATION-ERROR." 14 | (error 'ratification-error 15 | :test-object test-object 16 | :message (when message (apply #'format NIL message format-args)))) 17 | 18 | (defun make-keyword (name) 19 | "Returns the keyword equivalent of the passed NAME." 20 | (let ((name (string name))) 21 | (or (find-symbol name "KEYWORD") 22 | (intern name "KEYWORD")))) 23 | 24 | (defun true-alpha-p (char) 25 | "Returns T if the character is one of a-Z. 26 | 27 | ALPHA-CHAR-P as per CLHS is not strictly limited to just a-Z and returns T 28 | for undesired characters like ü on some implementations like SBCL." 29 | (or (char<= #\a char #\z) 30 | (char<= #\A char #\Z))) 31 | 32 | (defun true-alphanumeric-p (char) 33 | "Returns T if the character is one of a-Z 0-9. 34 | 35 | ALPHANUMERICP as per CLHS is not strictly limited to just a-Z 0-9 and returns T 36 | for undesired characters like ü on some implementations like SBCL." 37 | (or (true-alpha-p char) 38 | (char<= #\0 char #\9))) 39 | -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.types) 2 | 3 | (define-test bit (bit start end) 4 | "Tests for a valid bit. 5 | 6 | [01]" 7 | (unless (or (string= bit "1" :start1 start :end1 end) 8 | (string= bit "0" :start1 start :end1 end)) 9 | (ratification-error bit "A bit must be either 0 or 1."))) 10 | 11 | (define-parser bit (bit start end) 12 | "Parses into a bit of either 1 or 0." 13 | (if (string= bit "1" :start1 start :end1 end) 1 0)) 14 | 15 | (define-test unsigned-integer (integer start end) 16 | "Tests for a valid unsigned integer. 17 | 18 | " 19 | (when (= 0 (- end start)) 20 | (ratification-error integer "An integer must be at least one digit.")) 21 | (test-numeric integer start end)) 22 | 23 | (define-parser unsigned-integer (integer start end) 24 | "Parses into an integer." 25 | (parse-integer integer :start start :end end)) 26 | 27 | (define-test integer (integer start end) 28 | "Tests for a valid signed integer. 29 | 30 | [+-]?" 31 | (or (cl-ppcre:register-groups-bind (integer) ("^[+-]?(.+)$" integer :start start :end end) 32 | (test-unsigned-integer integer)) 33 | (ratification-error integer "An integer must be a number optionally preceded by + or -."))) 34 | 35 | (setf (parser 'integer) #'parse-unsigned-integer) 36 | 37 | (define-test ratio (ratio start end) 38 | "Tests for a valid ratio. 39 | 40 | [+-]?/" 41 | (or (cl-ppcre:register-groups-bind (numerator denominator) ("^[+-]?(.+)/(.+)$" ratio :start start :end end) 42 | (test-unsigned-integer numerator) 43 | (test-unsigned-integer denominator)) 44 | (ratification-error ratio "A ratio must optionally start with + or -, followed by two integers separated by a forward slash."))) 45 | 46 | (define-parser ratio (ratio start end) 47 | "Parses into a ratio." 48 | (cl-ppcre:register-groups-bind (numerator denominator) ("^(.+)/(.+)$" ratio :start start :end end) 49 | (/ (parse-integer (or numerator "")) ; It can't be NIL, but SBCL throws gross warnings otherwise. 50 | (parse-integer (or denominator ""))))) 51 | 52 | (define-test rational (rational start end) 53 | "Tests for a valid rational. 54 | 55 | [+-]?(/)?" 56 | (or (cl-ppcre:register-groups-bind (numerator NIL denominator) ("^[+-]?(.+?)(/(.+))?$" rational :start start :end end) 57 | (when denominator 58 | (test-unsigned-integer denominator)) 59 | (test-unsigned-integer numerator)) 60 | (ratification-error rational "A rational must optionally start with + or -, followed by one or two integers separated by a forward slash."))) 61 | 62 | (define-parser rational (rational start end) 63 | "Parses into a rational." 64 | (cl-ppcre:register-groups-bind (numerator NIL denominator) ("^(.+?)(/(.+))?$" rational :start start :end end) 65 | (/ (parse-integer (or numerator "")) 66 | (if denominator (parse-integer denominator) 1)))) 67 | 68 | (define-test float (float start end) 69 | "Tests for a valid float. 70 | 71 | [+-]?(\\.)?(e)?" 72 | (or (cl-ppcre:register-groups-bind (base NIL fraction NIL exponent) ("^[+-]?(.+?)(\\.(.+))?(e(.+))?$" float :start start :end end) 73 | (when fraction 74 | (test-unsigned-integer fraction)) 75 | (when exponent 76 | (test-unsigned-integer exponent)) 77 | (test-unsigned-integer base)) 78 | (ratification-error float "A float must optionally start with + or - followed by an integer a dot and an integer for the fraction and optionally an 'e' and an integer for the exponent."))) 79 | 80 | (define-parser float (float start end) 81 | "Parses into a float." 82 | (parse-float:parse-float float :start start :end end)) 83 | 84 | (define-test real (real start end) 85 | "Tests for a valid real. 86 | 87 | |" 88 | (or (rational-p real start end) 89 | (float-p real start end) 90 | (ratification-error real "A real must be either a rational or a float."))) 91 | 92 | (define-parser real (real start end) 93 | "Parses into a real." 94 | (if (find #\. real :start start :end end) 95 | (parse-float real start end) 96 | (parse-rational real start end))) 97 | 98 | (define-test complex (complex start end) 99 | "Tests for a valid complex number. 100 | 101 | [cC]" 102 | (or (cl-ppcre:register-groups-bind (real imag) ("^(.+)[cC](.+)$" complex :start start :end end) 103 | (test-real real) 104 | (test-real imag)) 105 | (ratification-error complex "A complex number must be composed of two reals separated by a 'C'."))) 106 | 107 | (define-parser complex (complex start end) 108 | "Parses into a complex number." 109 | (or (cl-ppcre:register-groups-bind (real imag) ("^(.+)[cC](.+)$" complex :start start :end end) 110 | (complex (parse-real real) 111 | (parse-real imag))) 112 | (error "Failed to parse, not a valid complex."))) 113 | 114 | (define-test number (number start end) 115 | "Tests for a valid number. 116 | 117 | |" 118 | (or (real-p number) 119 | (complex-p number) 120 | (ratification-error number "A number must be either a real or a complex."))) 121 | 122 | (define-parser number (number start end) 123 | "Parses into a number." 124 | (or (cl-ppcre:register-groups-bind (real NIL imag) ("^(.+?)([cC](.+))?$" number :start start :end end) 125 | (if imag 126 | (complex (parse-real real) (parse-real imag)) 127 | (parse-real real))) 128 | (error "Failed to parse, not a valid number."))) 129 | 130 | (define-test boolean (boolean start end) 131 | "Tests for a valid boolean. 132 | 133 | 1|0|true|false|T|NIL 134 | case-insensitive" 135 | (unless (or (eql boolean NIL) 136 | (eql boolean T) 137 | (find boolean '("1" "0" "true" "false" "T" "NIL") :test (lambda (a b) (string-equal a b :start1 start :end1 end)))) 138 | (ratification-error boolean "A boolean must be one of 1 0 true false T NIL."))) 139 | 140 | (define-parser boolean (boolean start end) 141 | "Parses into a boolean. 142 | 143 | Returns T if one of (\"1\" \"true\" \"T\"), NIL otherwise." 144 | (if (find boolean '("1" "true" "T") :test #'(lambda (a b) (string-equal a b :start1 start :end1 end))) 145 | T 146 | NIL)) 147 | 148 | (define-test character (character start end) 149 | "Tests for a valid character. 150 | 151 | .{1}" 152 | (unless (= 1 (- end start)) 153 | (ratification-error character "A character must be exactly one character long."))) 154 | 155 | (define-parser character (character start end) 156 | "Parses into a character." 157 | (char character start)) 158 | 159 | (define-test string (string start end) 160 | "Tests for a valid string. 161 | 162 | .+" 163 | (when (= 0 (- end start)) 164 | (ratification-error string "A string must be made up of one character or more."))) 165 | 166 | (define-parser string (string start end) 167 | "Parses into a string (simply returns its argument)." 168 | string) 169 | 170 | (define-test alphabetic (alpha start end) 171 | "Tests for an alphabetic string. 172 | 173 | [a-zA-Z]*" 174 | (loop for i from start below end 175 | for char = (char alpha i) 176 | do (unless (true-alpha-p char) 177 | (ratification-error alpha "Invalid character ~a. Only alphabetic characters (a-z A-Z) are allowed." char)))) 178 | 179 | (define-test numeric (number start end) 180 | "Tests for a numeric string. 181 | 182 | [0-9]*" 183 | (loop for i from start below end 184 | for char = (char number i) 185 | do (unless (char<= #\0 char #\9) 186 | (ratification-error number "Invalid character ~a. Only numeric characters (0-9) are allowed." char)))) 187 | 188 | (define-test alphanumeric (alpha start end) 189 | "Tests for an alphanumeric string. 190 | 191 | [a-zA-Z0-9]*" 192 | (loop for i from start below end 193 | for char = (char alpha i) 194 | do (unless (true-alphanumeric-p char) 195 | (ratification-error alpha "Invalid character ~a. Only alphanumeric characters (a-z A-Z 0-9) are allowed." char)))) 196 | -------------------------------------------------------------------------------- /uri.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.uri) 2 | 3 | ;; According to http://tools.ietf.org/html/rfc3986 4 | 5 | (defun general-delimiter-p (char) 6 | (find char ":/?#[]@" :test #'char=)) 7 | 8 | (defun sub-delimiter-p (char) 9 | (find char "!$&'()*+,;=" :test #'char=)) 10 | 11 | (defun reserved-character-p (char) 12 | (or (general-delimiter-p char) 13 | (sub-delimiter-p char))) 14 | 15 | (defun unreserved-character-p (char) 16 | (or (true-alphanumeric-p char) 17 | (find char "-._~" :test #'char=))) 18 | 19 | (defun percent-encoded-p (char) 20 | ;; I know this isn't right, but the alternative is oh so much more painful. 21 | ;; we'll delegate the proper resolving of urlencoded chars to another lib. 22 | (char= char #\%)) 23 | 24 | (defun pchar-p (char) 25 | (or (unreserved-character-p char) 26 | (sub-delimiter-p char) 27 | (percent-encoded-p char) 28 | (find char ":@" :test #'char=))) 29 | 30 | (define-test ipv4 (ip start end) 31 | "Tests for a valid IPv4 32 | 33 | \\.\\.\\. 34 | 0<=unsigned-integer<=255" 35 | (let ((parts (cl-ppcre:split "\\." ip :limit 5 :start start :end end))) 36 | (unless (= (length parts) 4) 37 | (ratification-error ip "IPv4 addresses must consist of four parts.")) 38 | (loop for part in parts 39 | for num = (ignore-errors (parse-integer part)) 40 | do (unless (and num (<= 0 num 255)) 41 | (ratification-error ip "~s is not a decimal integer between 0 and 255." part))))) 42 | 43 | (define-test ipv6 (ip start end) 44 | "Tests for a valid IPv6 45 | 46 | [0-9A-F]:(:|[0-9A-F]:){1,6})[0-9A-F]? 47 | 0000<=val<=FFFF" 48 | (let ((parts (cl-ppcre:split ":" ip :limit 9 :start start :end end))) 49 | (unless (<= (length parts) 8) 50 | (ratification-error ip "IPv6 must consist of 8 or less parts.")) 51 | (loop for part in parts 52 | for num = (ignore-errors (parse-integer part :radix 16)) 53 | for i from 0 54 | do (unless (or (not num) (<= #x0000 num #xFFFF)) 55 | (ratification-error ip "~s is not a hexadecimal integer between 0 and FFFF." part))))) 56 | 57 | (define-test ip (ip start end) 58 | "Tests for a valid IP address. 59 | 60 | |" 61 | (cond ((find #\: ip :start start :end end) 62 | (test-ipv6 ip start end)) 63 | ((find #\. ip :start start :end end) 64 | (test-ipv4 ip start end)) 65 | (T (ratification-error ip "This is neither an IPv4 nor an IPv6.")))) 66 | 67 | (define-test host (host start end) 68 | "Tests for a valid host name. 69 | 70 | \[\]|[a-zA-Z0-9-._~%!$&'()*+,;=]+" 71 | (when (= 0 (- end start)) 72 | (ratification-error host "Host must be at least one character long.")) 73 | (when (and (char= (aref host start) #\[) 74 | (char= (aref host (1- end)) #\])) 75 | (test-ip host (1+ start) (- end 2))) 76 | (loop for i from start below end 77 | for char = (char host i) 78 | do (unless (or (unreserved-character-p char) 79 | (percent-encoded-p char) 80 | (sub-delimiter-p char)) 81 | (ratification-error host "Invalid character ~a. Host can only contain alphanumerics or - . _ ~~ % ! $ & ' ( ) * + , ; =" char)))) 82 | 83 | (define-test scheme (scheme start end) 84 | "Tests for a valid scheme. 85 | 86 | [a-zA-Z][a-zA-Z0-9-.+]*" 87 | (unless (< 0 (- end start)) 88 | (ratification-error scheme "A scheme must be at least one character long.")) 89 | (unless (true-alpha-p (char scheme start)) 90 | (ratification-error scheme "Scheme must start with an alphabetic character.")) 91 | (loop for i from (1+ start) below end 92 | for char = (char scheme i) 93 | do (unless (or (true-alphanumeric-p char) 94 | (find char "-.+" :test #'char=)) 95 | (ratification-error scheme "Invalid character ~a. Scheme can only contain alphanumerics or - . +" char)))) 96 | 97 | (define-test user (user start end) 98 | "Tests for a valid user. 99 | 100 | [a-zA-Z0-9%!$&'()*+,;=-._~:]+" 101 | (when (= 0 (- end start)) 102 | (ratification-error user "User must be at least one character long.")) 103 | (loop for i from start below end 104 | for char = (char user i) 105 | do (unless (or (unreserved-character-p char) 106 | (sub-delimiter-p char) 107 | (percent-encoded-p char) 108 | (char= char #\:)) 109 | (ratification-error user "Invalid character ~a. Username can only contain alphanumerics or % ! $ & ' ( ) * + , ; = - . _ ~~ :" char)))) 110 | 111 | (define-test port (port start end) 112 | "Tests for a valid port. 113 | 114 | 115 | 0<=val<=65535" 116 | (let ((num (ignore-errors (parse-integer port :start start :end end)))) 117 | (unless num 118 | (ratification-error port "Port must be a decimal integer.")) 119 | (unless (<= 0 num 65535) 120 | (ratification-error port "Port must be between 0 and 65535.")))) 121 | 122 | (define-parser port (port start end) 123 | (let ((num (ignore-errors (parse-integer port :start start :end end)))) 124 | (unless num 125 | (ratification-error port "Port must be a decimal integer.")) 126 | (unless (<= 0 num 65535) 127 | (ratification-error port "Port must be between 0 and 65535.")) 128 | num)) 129 | 130 | (define-test authority (authority start end) 131 | "Tests for a valid authority. 132 | 133 | (@)?(:)?" 134 | (let ((atpos (position #\@ authority :start start :end end))) 135 | (when atpos 136 | (test-user authority start atpos) 137 | (setf start (1+ atpos)))) 138 | (let ((colonpos (position #\: authority :start start :end end))) 139 | (when colonpos 140 | (test-port authority (1+ colonpos)) 141 | (setf end colonpos))) 142 | (test-host authority start end)) 143 | 144 | (define-test path-segment (segment start end) 145 | "Tests for a valid path segment. 146 | 147 | [a-zA-Z0-9!$&'()*+,;=-._~:@]+" 148 | (loop for i from start below end 149 | for char = (char segment i) 150 | do (unless (pchar-p char) 151 | (ratification-error segment "Invalid character ~a. Path segment can only contain alphanumerics or ! $ & ' ( ) * + , ; = - . _ ~~ : @" char)))) 152 | 153 | (define-test rootless-path (path start end) 154 | "Tests for a valid rootless path. 155 | 156 | (/)?" 157 | (when (= 0 (- end start)) 158 | (ratification-error path "Path must be at least one character long.")) 159 | (loop with begin = start 160 | for i from start below end 161 | for char = (char path i) 162 | do (when (char= char #\/) 163 | (test-path-segment path begin i) 164 | (setf begin (1+ i))) 165 | finally (test-path-segment path begin i))) 166 | 167 | (define-test absolute-path (path start end) 168 | "Tests for a valid absolute path. 169 | 170 | /" 171 | (unless (< 0 (- end start)) 172 | (ratification-error path "Path must be at least one character long.")) 173 | (unless (char= (char path start) #\/) 174 | (ratification-error path "An absolute path must start with a forward slash.")) 175 | (when (< 1 (- end start)) 176 | (when (char= (char path (1+ start)) #\/) 177 | (ratification-error path "Beginning slash must be followed by a non-slash character.")) 178 | (test-rootless-path path (1+ start) end))) 179 | 180 | (define-test hierarchical-part (hierarchical start end) 181 | "Tests for a valid hierarchical part. 182 | 183 | |//" 184 | (let ((length (- end start))) 185 | (when (and (= length 1) (string/= hierarchical "/" :start1 start :end1 end)) 186 | (ratification-error hierarchical "Hierarchical part must be either a path or begin with //.")) 187 | (if (and (< 1 length) 188 | (string= hierarchical "//" :start1 (1+ start) :end1 (+ start 2))) 189 | (let ((slashpos (position #\/ hierarchical :start (+ start 2) :end end))) 190 | (cond (slashpos 191 | (test-authority hierarchical (+ start 2) slashpos) 192 | (test-absolute-path hierarchical slashpos end)) 193 | (T 194 | (test-authority hierarchical (+ start 2) end)))) 195 | (test-absolute-path hierarchical start end)))) 196 | 197 | (define-test query (query start end) 198 | "Tests for a valid query part. 199 | 200 | [a-zA-Z0-9!$&'()*+,;=-._~:@?/]+" 201 | (unless (< 0 (- end start)) 202 | (ratification-error query "Query must be at least one character long.")) 203 | (loop for i from start below end 204 | for char = (char query i) 205 | do (unless (or (pchar-p char) 206 | (find char "?/" :test #'char=)) 207 | (ratification-error query "Invalid character ~a. Query can only contain alphanumercs or ! $ & ' ( ) * + , ; = - . _ ~~ : @ ? /" char)))) 208 | 209 | (define-test fragment (fragment start end) 210 | "Tests for a valid fragment part. 211 | 212 | [a-zA-Z0-9!$&'()*+,;=-._~:@?/]+" 213 | (unless (< 0 (- end start)) 214 | (ratification-error fragment "Fragment must be at least one character long.")) 215 | (loop for i from start below end 216 | for char = (char fragment i) 217 | do (unless (or (pchar-p char) 218 | (find char "?/" :test #'char=)) 219 | (ratification-error fragment "Invalid character ~a. Fragment can only contain alphanumercs or ! $ & ' ( ) * + , ; = - . _ ~~ : @ ? /" char)))) 220 | 221 | (define-test uri (uri start end) 222 | "Tests for a valid URI according to http://tools.ietf.org/html/rfc3986 223 | 224 | :(\?)?(#)?" 225 | (or 226 | (cl-ppcre:register-groups-bind (scheme hierarchical NIL query NIL fragment) ("^([^:]+):([^\\?]+)(\\?([^#]*))?(\\#(.*))?$" uri :start start :end end) 227 | (when scheme (test-scheme scheme)) 228 | (when hierarchical (test-hierarchical-part hierarchical)) 229 | (when query (test-query query)) 230 | (when fragment (test-fragment fragment)) 231 | T) 232 | (ratification-error uri "Uri must consist of at least a scheme followed by a colon and a path."))) 233 | -------------------------------------------------------------------------------- /url.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.ratify.url) 2 | 3 | (define-test hostname (hostname start end) 4 | "Test a hostname for validity according to http://en.wikipedia.org/wiki/Hostname 5 | 6 | [a-zA-Z0-9-]{1,63}(\\.[a-zA-Z0-9-]{1,63})* 7 | 1<=length<=255" 8 | (unless (<= 1 (- end start) 255) 9 | (ratification-error hostname "Hostname must be between 1 and 255 characters long.")) 10 | (loop with lastdot = start 11 | for i from start below end 12 | for char = (char hostname i) 13 | do (unless (or (true-alphanumeric-p char) 14 | (find char "-." :test #'char=)) 15 | (ratification-error hostname "Invalid character ~a. Hostname parts must consist of either alphanumerics or - ." char)) 16 | (when (char= char #\.) 17 | (unless (<= 1 (- i lastdot) 63) 18 | (ratification-error hostname "Hostname parts must be between 1 and 63 characters long.")) 19 | (setf lastdot i)) 20 | finally (unless (<= 1 (- i lastdot) 63) 21 | (ratification-error hostname "Hostname parts must be between 1 and 63 characters long.")))) 22 | 23 | (define-test domain (domain start end) 24 | "Tests for a valid domain. 25 | 26 | \[\]|" 27 | (or (and (char= (aref domain start) #\[) 28 | (char= (aref domain (1- end)) #\]) 29 | (test-ip (subseq domain (1+ start) (1- end)))) 30 | (test-hostname domain start end))) 31 | 32 | (defvar *permitted-protocols* '("ftp" "http" "https") 33 | "List of permitted protocols in a URL.") 34 | 35 | (define-test protocol (protocol start end) 36 | "Tests for a valid protocol according to *PERMITTED-PROTOCOLS*" 37 | (find protocol *permitted-protocols* :test (lambda (a b) (string-equal a b :start1 start :end1 end)))) 38 | 39 | (define-test url (url start end) 40 | "Tests for a valid URL. 41 | 42 | (://)?()?(\?)?(#)?" 43 | (or 44 | (cl-ppcre:register-groups-bind 45 | (NIL protocol domain NIL port path NIL query NIL fragment) 46 | ("^(([^:]+):\\/\\/)?([^/:]+)?(:(\\d+))?(\\/[^\\?]*)(\\?([^#]*))?(#(.*))?$" 47 | url :start start :end end) 48 | (when protocol (test-protocol protocol)) 49 | (when domain (test-domain domain)) 50 | (when port (test-port port)) 51 | (when path (test-absolute-path path)) 52 | (when query (test-query query)) 53 | (when fragment (test-fragment fragment)) 54 | T) 55 | (ratification-error url "An URL must at the very least consist of a path."))) 56 | --------------------------------------------------------------------------------