jadedctrl/ qotdd
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Init

This commit is contained in:
Jaidyn Lev 2018-09-23 21:58:22 -05:00
commit 8cf1683903
8 changed files with 405 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
qotd_sets/qotd2018-WIP Normal file
View File

@ -0,0 +1,18 @@
:Date 2018-09-23
"Don't despair that others don't know you--
despair that you don't know them."
-- Master Kung
%
:Date 2018-09-24
"Death to the bourgeousie class!"
-- Some comrade
%
:Date 2018-09-25
"I don't have a quote for today!"
-- Lazy sysadmin
%

16
qotdd.asd Executable file
View File

@ -0,0 +1,16 @@
(defsystem "qotdd"
:version "0.1"
:author "Jaidyn Ann <jadedctrl@teknik.io>"
:license "AGPLv3"
:depends-on ("cl-strings" "usocket")
:components ((:module "src"
:components
((:file "package")
(:file "misc")
(:file "string")
(:file "stream")
(:file "quote")
(:file "server"))))
:description
"Question of the Day server (RFC 865-compliant)")

36
src/misc.lisp Normal file
View File

@ -0,0 +1,36 @@
(in-package :qotdd)
;; EXPRESSION BACKUP --> EXPRESSION_OR_BACKUP
(defun value-or (expression backup)
"If an expression is non-NIL, return it. Otherwise,
return a backup."
(if expression
expression
backup))
;; UNIVERSAL_TIME --> ISO8601-FORMATTED_STRING
(defun iso8601 (universal-time)
"Return `universal-time` in ISO 8601 format. :)"
(multiple-value-bind
(second minute hour date month year)
(decode-universal-time universal-time)
(format nil "~A-~A-~A"
year
(min-string-length month 2 "0")
(min-string-length date 2 "0"))))
;; LIST --> RANDOM_ITEM
(defun random-item (list)
"Get a random item from a list."
(let* ((length (length list))
(n (random length)))
(nth n list)))

7
src/package.lisp Normal file
View File

@ -0,0 +1,7 @@
(defpackage :qotdd
(:export
:server))
(in-package :qotdd)

56
src/quote.lisp Normal file
View File

@ -0,0 +1,56 @@
(in-package :qotdd)
;; QUOTE_FILE_PATH --> LIST_OF_LISTS
(defun get-quotes (path)
"Read quotes into a list of quotes by path.
The list'll look like this:
((DATE QUOTE)
(DATE QUOTE)
(DATE QUOTE))"
(mapcar
(lambda (quote)
(list
(get-quote-date quote)
(remove-quote-date quote)))
(read-line-chunked (open path) "%")))
;; QUOTE_STRING --> DATE_IN_STRING
(defun get-quote-date (quote)
"Get the date of a set quote."
(let ((date (get-colon-value quote "Date")))
(if date
date
nil)))
;; QUOTE_STRING --> QUOTE_STRING_WITHOUT_DATE
(defun remove-quote-date (quote)
"Remove the date from a set quote."
(if (get-quote-date quote)
(remove-colon-value quote "Date")
quote))
;; PATH_TO_QOTD_FILE [UNIVERSAL_TIME] --> DATED_OR_RANDOM_QUOTE
(defun get-quote (path &optional universal-time)
"Return a quote of the day.
If you pass `universal-time`, then it'll try to get a quote
specific to that day.
If a quote doesn't exist for that day (or you don't pass
`universal-time`), it'll return a random quote."
(let* ((quotes (get-quotes path))
(date (ignore-errors (iso8601 universal-time)))
(dated-quote (ignore-errors (cadr (getf-string quotes date)))))
(if dated-quote
dated-quote
(random-item quotes))))

53
src/server.lisp Normal file
View File

@ -0,0 +1,53 @@
(in-package :qotdd)
;; [HOST] [PORT]
(defun server (&optional
(host "127.0.0.1")
(port 1117)
(qotd-path "/usr/share/games/qotdd/qotd2018"))
"Start the QOTD server."
(let ((socket (usocket:socket-listen host port)))
(unwind-protect
(loop
:do
(let ((connection (connection-get socket)))
(main connection qotd-path)
(connection-kill connection)))
(progn
(format t "Dying...")
(usocket:socket-close socket)))))
;; SOCKET --> CONNECTION_ON_SOCKET
(defun connection-get (socket)
"Return a Connection from a Socket; until Connection recieved,
wait patiently."
(usocket:socket-accept socket :element-type 'character))
;; CONNECTION
(defun connection-kill (connection)
"Close a connection."
(usocket:socket-close connection))
(defun main (connection qotd-path)
"Main function on a connection-- send the QOTD to them."
(connection-msg connection
(get-quote qotd-path (get-universal-time))))
;; CONNECTION
(defun connection-msg (connection message)
"Send a message to a connection."
(format (usocket:socket-stream connection) "~A" message))

37
src/stream.lisp Normal file
View File

@ -0,0 +1,37 @@
(in-package :qotdd)
;; STREAM [FOOTER-STRING] --> DATA_FROM_STREAM_UNTIL_FOOTER
(defun read-line-until (stream seperator-line)
"Read lines from a stream until a certain line is reached."
(let ((cur-line
(ignore-errors (read-line stream))))
(cond
((and cur-line (not (equal cur-line (string seperator-line))))
(format nil "~A~%~A"
cur-line
(value-or
(read-line-until stream seperator-line)
"")))
('T nil))))
;; STREAM SEPERATOR --> LIST_OF_STRINGS
(defun read-line-chunked (stream seperator-line)
"read-line over a stream until EOF into a single string--
but, whenver the `seperator-line` is reached, start a
brand new string.
Returns a list of (multi-lined) strings."
(let ((chunk
(read-line-until stream seperator-line)))
(if chunk
(concatenate 'list
(list chunk)
(read-line-chunked
stream
seperator-line)))))

182
src/string.lisp Normal file
View File

@ -0,0 +1,182 @@
(in-package :qotdd)
;; MULTI-LINE_STRING --> LIST_OF_LINES
(defun string-line-list (string)
"Return a list of lines from a multi-line string."
(cl-strings:split string (format nil "~%")))
;; LIST_OF_STRINGS --> MULTI-LINE_STRING
(defun line-list-string (line-list)
"Turn a list of lines (string) into a multi-line string."
(reduce
(lambda (x y)
(format nil "~A~%~A" x y))
line-list))
;; SINGLE-LINE_STRING PREFIX_SUBSTRING --> POST-PREFIX_SUBSTRING
(defun string-after-prefix (string prefix)
"Return substring after a `prefix` substring at the start of a string."
(cl-strings:clean
(cadr (cl-strings:split string prefix))))
;; MULTI-LINE_STRING QUERY --> LINE_CONTAINING_QUERY
(defun get-line (string query)
"Return a single line that query starts from a multi-line string."
(let ((line-number (position-line string query)))
(if line-number
(nth line-number (string-line-list string))
nil)))
;; MULTI-LINE_STRING QUERY --> LINE_NUMBER
(defun position-line (string query)
"Return the line number that the string `query` starts off--
from a multi-line string."
(position 'T
(mapcar
(lambda (line)
(cl-strings:starts-with line query))
(string-line-list string))))
;; NUMBER MULTI-LINE_STRING --> SINGLE-LINE_STRING
(defun nth-string (n string)
"Return line of number `n` from a multi-line string."
(nth n (string-line-list string)))
;; STRING COLON_VARIABLE_NAME --> COLON_VALUE
(defun get-colon-value (string variable)
"Return a the value of a `colon variable`; I.E.,
a line of a string starting with `:` followed by a variable
name, a space, then the value of said `colon variable`.
Here's an example:
(setq *example-string*
\"Blah blah blah
:Date 1999
Blah blah blah\")
If you ran
(get-colon-value *example-string* \"Date\")
you would get
\"1999\" in return.
Mainly useful for multi-line strings, but your use-case might
involve a `colon variable` in a single-lined string."
(let ((variable-string (format nil ":~A " variable)))
(values
(ignore-errors
(string-after-prefix
(get-line string variable-string)
variable-string)))))
;; STRING COLON_VARIABLE_NAME --> STRING_WITHOUT_COLON_VARIABLE
(defun remove-colon-value (string variable)
"Remove the colon-variable declaration from a string."
(let ((variable-string (format nil ":~A " variable)))
(line-list-string
(remove
(get-line string variable-string)
(string-line-list string)
:test 'equal))))
;; STRING DESIRED_LENGTH [PREFIX] [SUFFIX] --> STRING_OF_DESIRED_LENGTH
(defun min-string-length (string target-length
&optional (prefix-substitute "0")
(suffix-substitute ""))
"If a string *must* be a certain length (formatting reasons), use
this function.
Returns a string of `length`, using the `prefix-substitutor` or
`suffix-substitutor` to beef up the character-count if it's too short.
If both `prefix` and `suffix` are defined, `prefix` is used.
Example:
(min-string-length \"9\" 3 \"0\")
\"009\""
(let* ((string (format nil "~A" string))
(cur-length (length string)))
(if (eq cur-length target-length)
string
(min-string-length
(pad-string string prefix-substitute suffix-substitute)
target-length
prefix-substitute
suffix-substitute))))
;; STRING PREFIX SUFFIX --> STRING_ONE_OR_TWO_CHARS_LARGER
(defun pad-string (string prefix-substitute suffix-substitute)
"Increase the character-count of a string by 1; either by
adding a prefix-substitutor or a suffix-substitutor.
Set the substitutor you don't want to use to \"\".
If you set both to a value, then the count will increase by 2."
(format nil "~A~A~A" prefix-substitute string suffix-substitute))
;; LIST_OF_SUBLISTS STRING --> SUBLIST_WITH_STRING_AS_CAR
(defun getf-string (list string)
"Get an item from a list by an identifying string in `car`.
I.E., if the string is 'apple', the first sublist like this:
('apple' 1 2 3)
will be returned."
(car (getf-strings list string)))
;; LIST_OF_SUBLISTS STRING --> LIST_OF_SUBLISTS_WITH_STRING_AS_CAR
(defun getf-strings (list string &optional (stack '()))
"Get items from list by an identifying string in `car`.
I.E., if the string is 'apple', any sublists like this:
('apple' 1 2 3)
will be returned."
;; just recurse through the list, adding each new matching
;; item to the `stack`
(if (and (< 0 (length list)) (listp list))
(if (ignore-errors
;; the item might not be a list; for our purposes, let's ignore that.
(equal
(car (car list)) ;; '( ( here ) )
string))
(getf-strings (cdr list) string (concatenate 'list stack (list (car list))))
(getf-strings (cdr list) string stack))
stack))