Jaidyn Lev authored on 2018-09-24 02:58:22
Showing 8 changed files
1 1
new file mode 100644
... ...
@@ -0,0 +1,18 @@
1
+:Date 2018-09-23
2
+
3
+"Don't despair that others don't know you--
4
+despair that you don't know them."
5
+	-- Master Kung
6
+
7
+%
8
+:Date 2018-09-24
9
+
10
+"Death to the bourgeousie class!"
11
+	-- Some comrade
12
+
13
+%
14
+:Date 2018-09-25
15
+
16
+"I don't have a quote for today!"
17
+	-- Lazy sysadmin
18
+%
0 19
new file mode 100755
... ...
@@ -0,0 +1,16 @@
1
+(defsystem "qotdd"
2
+           :version "0.1"
3
+           :author "Jaidyn Ann <jadedctrl@teknik.io>"
4
+           :license "AGPLv3"
5
+           :depends-on ("cl-strings" "usocket")
6
+           :components ((:module "src"
7
+                                 :components
8
+                                 ((:file "package")
9
+                                  (:file "misc")
10
+                                  (:file "string")
11
+                                  (:file "stream")
12
+                                  (:file "quote")
13
+                                  (:file "server"))))
14
+
15
+           :description
16
+           "Question of the Day server (RFC 865-compliant)")
0 17
new file mode 100644
... ...
@@ -0,0 +1,36 @@
1
+(in-package :qotdd)
2
+
3
+;; EXPRESSION BACKUP --> EXPRESSION_OR_BACKUP
4
+(defun value-or (expression backup)
5
+  "If an expression is non-NIL, return it. Otherwise,
6
+  return a backup."
7
+
8
+  (if expression
9
+    expression
10
+    backup))
11
+
12
+
13
+
14
+;; UNIVERSAL_TIME --> ISO8601-FORMATTED_STRING
15
+(defun iso8601 (universal-time)
16
+  "Return `universal-time` in ISO 8601 format. :)"
17
+
18
+  (multiple-value-bind
19
+    (second minute hour date month year)
20
+    (decode-universal-time universal-time)
21
+
22
+    (format nil "~A-~A-~A"
23
+            year
24
+            (min-string-length month 2 "0")
25
+            (min-string-length date 2 "0"))))
26
+
27
+
28
+
29
+;; LIST --> RANDOM_ITEM
30
+(defun random-item (list)
31
+  "Get a random item from a list."
32
+
33
+  (let* ((length (length list))
34
+         (n (random length)))
35
+
36
+    (nth n list)))
0 37
new file mode 100644
... ...
@@ -0,0 +1,7 @@
1
+(defpackage :qotdd
2
+  (:export
3
+
4
+    :server))
5
+
6
+(in-package :qotdd) 
7
+
0 8
new file mode 100644
... ...
@@ -0,0 +1,56 @@
1
+(in-package :qotdd)
2
+
3
+;; QUOTE_FILE_PATH --> LIST_OF_LISTS
4
+(defun get-quotes (path)
5
+  "Read quotes into a list of quotes by path.
6
+  The list'll look like this:
7
+
8
+      ((DATE QUOTE)
9
+       (DATE QUOTE)
10
+       (DATE QUOTE))"
11
+
12
+  (mapcar
13
+    (lambda (quote)
14
+      (list
15
+        (get-quote-date quote)
16
+        (remove-quote-date quote)))
17
+    (read-line-chunked (open path) "%")))
18
+
19
+
20
+
21
+;; QUOTE_STRING --> DATE_IN_STRING
22
+(defun get-quote-date (quote)
23
+  "Get the date of a set quote."
24
+
25
+  (let ((date (get-colon-value quote "Date")))
26
+    (if date
27
+      date
28
+      nil)))
29
+
30
+
31
+
32
+;; QUOTE_STRING --> QUOTE_STRING_WITHOUT_DATE
33
+(defun remove-quote-date (quote)
34
+  "Remove the date from a set quote."
35
+
36
+  (if (get-quote-date quote)
37
+    (remove-colon-value quote "Date")
38
+    quote))
39
+
40
+
41
+
42
+;; PATH_TO_QOTD_FILE [UNIVERSAL_TIME] --> DATED_OR_RANDOM_QUOTE
43
+(defun get-quote (path &optional universal-time)
44
+  "Return a quote of the day.
45
+  If you pass `universal-time`, then it'll try to get a quote
46
+  specific to that day.
47
+  If a quote doesn't exist for that day (or you don't pass
48
+  `universal-time`), it'll return a random quote."
49
+
50
+  (let* ((quotes (get-quotes path))
51
+        (date (ignore-errors (iso8601 universal-time)))
52
+        (dated-quote (ignore-errors (cadr (getf-string quotes date)))))
53
+
54
+    (if dated-quote
55
+      dated-quote
56
+      (random-item quotes))))
0 57
new file mode 100644
... ...
@@ -0,0 +1,53 @@
1
+(in-package :qotdd)
2
+
3
+;; [HOST] [PORT]
4
+(defun server (&optional
5
+                (host "127.0.0.1")
6
+                (port 1117)
7
+                (qotd-path "/usr/share/games/qotdd/qotd2018"))
8
+  "Start the QOTD server."
9
+
10
+  (let ((socket (usocket:socket-listen host port)))
11
+
12
+    (unwind-protect
13
+      (loop
14
+        :do
15
+        (let ((connection (connection-get socket)))
16
+          (main connection qotd-path)
17
+          (connection-kill connection)))
18
+
19
+      (progn
20
+        (format t "Dying...")
21
+        (usocket:socket-close socket)))))
22
+
23
+
24
+
25
+;; SOCKET --> CONNECTION_ON_SOCKET
26
+(defun connection-get (socket)
27
+  "Return a Connection from a Socket; until Connection recieved,
28
+  wait patiently."
29
+
30
+  (usocket:socket-accept socket :element-type 'character))
31
+
32
+
33
+
34
+;; CONNECTION
35
+(defun connection-kill (connection)
36
+  "Close a connection."
37
+
38
+  (usocket:socket-close connection))
39
+
40
+
41
+
42
+(defun main (connection qotd-path)
43
+  "Main function on a connection-- send the QOTD to them."
44
+
45
+  (connection-msg connection
46
+                  (get-quote qotd-path (get-universal-time))))
47
+
48
+
49
+;; CONNECTION
50
+(defun connection-msg (connection message)
51
+  "Send a message to a connection."
52
+
53
+  (format (usocket:socket-stream connection) "~A" message))
0 54
new file mode 100644
... ...
@@ -0,0 +1,37 @@
1
+(in-package :qotdd)
2
+
3
+;; STREAM [FOOTER-STRING] --> DATA_FROM_STREAM_UNTIL_FOOTER
4
+(defun read-line-until (stream seperator-line)
5
+  "Read lines from a stream until a certain line is reached."
6
+
7
+  (let ((cur-line
8
+          (ignore-errors (read-line stream))))
9
+
10
+    (cond
11
+      ((and cur-line (not (equal cur-line (string seperator-line))))
12
+       (format nil "~A~%~A"
13
+               cur-line 
14
+               (value-or
15
+                 (read-line-until stream seperator-line)
16
+                 "")))
17
+
18
+      ('T nil))))
19
+
20
+
21
+
22
+;; STREAM SEPERATOR --> LIST_OF_STRINGS
23
+(defun read-line-chunked (stream seperator-line)
24
+  "read-line over a stream until EOF into a single string--
25
+  but, whenver the `seperator-line` is reached, start a
26
+  brand new string.
27
+  Returns a list of (multi-lined) strings."
28
+
29
+  (let ((chunk
30
+          (read-line-until stream seperator-line)))
31
+
32
+    (if chunk
33
+      (concatenate 'list
34
+                   (list chunk)
35
+                   (read-line-chunked
36
+                     stream
37
+                     seperator-line)))))
0 38
new file mode 100644
... ...
@@ -0,0 +1,182 @@
1
+(in-package :qotdd)
2
+
3
+;; MULTI-LINE_STRING --> LIST_OF_LINES
4
+(defun string-line-list (string)
5
+  "Return a list of lines from a multi-line string."
6
+
7
+  (cl-strings:split string (format nil "~%")))
8
+
9
+
10
+
11
+;; LIST_OF_STRINGS --> MULTI-LINE_STRING
12
+(defun line-list-string (line-list)
13
+  "Turn a list of lines (string) into a multi-line string."
14
+
15
+  (reduce
16
+    (lambda (x y)
17
+      (format nil "~A~%~A" x y))
18
+    line-list))
19
+
20
+
21
+
22
+;; SINGLE-LINE_STRING PREFIX_SUBSTRING --> POST-PREFIX_SUBSTRING
23
+(defun string-after-prefix (string prefix)
24
+  "Return substring after a `prefix` substring at the start of a string."
25
+
26
+  (cl-strings:clean
27
+    (cadr (cl-strings:split string prefix))))
28
+
29
+
30
+
31
+;; MULTI-LINE_STRING QUERY --> LINE_CONTAINING_QUERY
32
+(defun get-line (string query)
33
+  "Return a single line that query starts from a multi-line string."
34
+
35
+  (let ((line-number (position-line string query)))
36
+
37
+    (if line-number
38
+      (nth line-number (string-line-list string))
39
+      nil)))
40
+
41
+
42
+
43
+;; MULTI-LINE_STRING QUERY --> LINE_NUMBER
44
+(defun position-line (string query)
45
+  "Return the line number that the string `query` starts off--
46
+  from a multi-line string."
47
+
48
+  (position 'T
49
+            (mapcar
50
+              (lambda (line)
51
+                (cl-strings:starts-with line query))
52
+              (string-line-list string))))
53
+
54
+
55
+
56
+;; NUMBER MULTI-LINE_STRING --> SINGLE-LINE_STRING
57
+(defun nth-string (n string)
58
+  "Return line of number `n` from a multi-line string."
59
+
60
+  (nth n (string-line-list string)))
61
+
62
+
63
+
64
+;; STRING COLON_VARIABLE_NAME --> COLON_VALUE
65
+(defun get-colon-value (string variable)
66
+  "Return a the value of a `colon variable`; I.E.,
67
+  a line of a string starting with `:` followed by a variable
68
+  name, a space, then the value of said `colon variable`.
69
+
70
+  Here's an example:
71
+      (setq *example-string*
72
+      \"Blah blah blah
73
+      :Date 1999
74
+      Blah blah blah\")
75
+
76
+  If you ran
77
+      (get-colon-value *example-string* \"Date\")
78
+
79
+  you would get
80
+      \"1999\" in return.
81
+
82
+  Mainly useful for multi-line strings, but your use-case might
83
+  involve a `colon variable` in a single-lined string."
84
+
85
+  (let ((variable-string (format nil ":~A " variable)))
86
+
87
+    (values
88
+      (ignore-errors
89
+        (string-after-prefix
90
+          (get-line string variable-string)
91
+          variable-string)))))
92
+
93
+
94
+
95
+;; STRING COLON_VARIABLE_NAME --> STRING_WITHOUT_COLON_VARIABLE
96
+(defun remove-colon-value (string variable)
97
+  "Remove the colon-variable declaration from a string."
98
+
99
+  (let ((variable-string (format nil ":~A " variable)))
100
+
101
+    (line-list-string
102
+      (remove
103
+        (get-line string variable-string)
104
+        (string-line-list string)
105
+        :test 'equal))))
106
+
107
+
108
+
109
+;; STRING DESIRED_LENGTH [PREFIX] [SUFFIX] --> STRING_OF_DESIRED_LENGTH
110
+(defun min-string-length (string target-length
111
+                                &optional (prefix-substitute "0")
112
+                                           (suffix-substitute ""))
113
+  "If a string *must* be a certain length (formatting reasons), use
114
+  this function.
115
+
116
+  Returns a string of `length`, using the `prefix-substitutor` or
117
+  `suffix-substitutor` to beef up the character-count if it's too short.
118
+
119
+  If both `prefix` and `suffix` are defined, `prefix` is used.
120
+
121
+  Example:
122
+      (min-string-length \"9\" 3 \"0\")
123
+
124
+      \"009\""
125
+
126
+  (let* ((string (format nil "~A" string))
127
+         (cur-length (length string)))
128
+      
129
+    (if (eq cur-length target-length)
130
+      string
131
+
132
+      (min-string-length
133
+        (pad-string string prefix-substitute suffix-substitute)
134
+        target-length
135
+        prefix-substitute
136
+        suffix-substitute))))
137
+
138
+
139
+
140
+
141
+;; STRING PREFIX SUFFIX --> STRING_ONE_OR_TWO_CHARS_LARGER
142
+(defun pad-string (string prefix-substitute suffix-substitute)
143
+  "Increase the character-count of a string by 1; either by
144
+  adding a prefix-substitutor or a suffix-substitutor.
145
+
146
+  Set the substitutor you don't want to use to \"\".
147
+  If you set both to a value, then the count will increase by 2."
148
+
149
+  (format nil "~A~A~A" prefix-substitute string suffix-substitute))
150
+
151
+
152
+
153
+;; LIST_OF_SUBLISTS STRING --> SUBLIST_WITH_STRING_AS_CAR
154
+(defun getf-string (list string)
155
+  "Get an item from a list by an identifying string in `car`.
156
+  I.E., if the string is 'apple', the first sublist like this:
157
+  ('apple' 1 2 3)
158
+  will be returned."
159
+
160
+  (car (getf-strings list string)))
161
+
162
+
163
+
164
+;; LIST_OF_SUBLISTS STRING --> LIST_OF_SUBLISTS_WITH_STRING_AS_CAR
165
+(defun getf-strings (list string &optional (stack '()))
166
+  "Get items from list by an identifying string in `car`.
167
+  I.E., if the string is 'apple', any sublists like this:
168
+  ('apple' 1 2 3)
169
+  will be returned."
170
+
171
+  ;; just recurse through the list, adding each new matching
172
+  ;; item to the `stack`
173
+
174
+  (if (and (< 0 (length list)) (listp list))
175
+    (if (ignore-errors
176
+          ;; the item might not be a list; for our purposes, let's ignore that.
177
+          (equal
178
+            (car (car list))    ;; '( ( here ) )
179
+            string))
180
+      (getf-strings (cdr list) string (concatenate 'list stack (list (car list))))
181
+      (getf-strings (cdr list) string stack))
182
+    stack))