diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/pronouns/config.clj | 29 | ||||
| -rw-r--r-- | src/pronouns/pages.clj | 242 | ||||
| -rw-r--r-- | src/pronouns/util.clj | 120 | ||||
| -rw-r--r-- | src/pronouns/web.clj | 73 |
4 files changed, 347 insertions, 117 deletions
diff --git a/src/pronouns/config.clj b/src/pronouns/config.clj new file mode 100644 index 0000000..e35ac7e --- /dev/null +++ b/src/pronouns/config.clj @@ -0,0 +1,29 @@ +;; pronoun.is - a website for pronoun usage examples +;; Copyright (C) 2014 - 2018 Morgan Astra + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/> + +(ns pronouns.config + (:require [pronouns.util :as u])) + +(def pronouns-table + (atom (u/slurp-tabfile "resources/pronouns.tab"))) + +(defn replace-value [old new] new) + +(defn reload-table! [] + (swap! pronouns-table + replace-value + (u/slurp-tabfile "resources/pronouns.tab"))) + diff --git a/src/pronouns/pages.clj b/src/pronouns/pages.clj index 8aed689..e629329 100644 --- a/src/pronouns/pages.clj +++ b/src/pronouns/pages.clj @@ -1,10 +1,42 @@ +;; pronoun.is - a website for pronoun usage examples +;; Copyright (C) 2014 - 2018 Morgan Astra + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/> + (ns pronouns.pages - (:require [clojure.string :as s] - [clojure.data.json :as json] + (:require [clojure.data.json :as json] + [clojure.string :as s] + [pronouns.config :refer [pronouns-table]] [pronouns.util :as u] [hiccup.core :refer :all] + [hiccup.element :as e] [hiccup.util :refer [escape-html]])) +(defn prose-comma-list + [items] + (let [c (count items)] + (cond + (<= c 1) (or (first items) "") + (= c 2) (s/join " and " items) + :else (str (s/join ", " (butlast items)) ", and " (last items))))) + +(defn href + [url text] + [:a {:href url} text]) + +;; FIXME morgan.astra <2018-11-14 Wed> +;; use a div for this instead of a plain bold tag (defn wrap-pronoun [pronoun] [:b pronoun]) @@ -29,7 +61,9 @@ (defn possessive-pronoun-example [possessive-pronoun] - (render-sentence "At least I think it was " (wrap-pronoun possessive-pronoun) ".")) + (render-sentence "At least I think it was " + (wrap-pronoun possessive-pronoun) + ".")) (defn reflexive-example [subject reflexive] @@ -38,73 +72,92 @@ (wrap-pronoun reflexive) ".")) -(defn title-block [title] - [:div {:class "title"} - [:h1 title]]) +(defn header-block [header] + [:div {:class "section title"} + (href "/" [:h1 header])]) (defn examples-block [subject object possessive-determiner possessive-pronoun reflexive] - [:div {:class "examples"} - [:p [:h2 "Here are some usage examples for my pronouns:"]] - (subject-example subject) - (object-example object) - (posessive-determiner-example subject possessive-determiner) - (possessive-pronoun-example possessive-pronoun) - (reflexive-example subject reflexive)]) - -(defn about-block [] - [:div {:class "about"} + (let [sub-obj (s/join "/" [subject object]) + header-str (str "Here are some example sentences using my " + sub-obj + " pronouns:")] + [:div {:class "section examples"} + [:h2 header-str] + [:p (subject-example subject) + (object-example object) + (posessive-determiner-example subject possessive-determiner) + (possessive-pronoun-example possessive-pronoun) + (reflexive-example subject reflexive)]])) + +(defn usage-block [] + [:div {:class "section usage"} [:p "Full usage: " - [:tt "http://pronoun.is/subject-pronoun/object-pronoun/possessive-determiner/possessive-pronoun/reflexive"] - " displays examples of your pronouns."] - [:p "This is a bit unwieldy. If we have a good guess we'll let you use just the first one or two."]]) + ;; FIXME morgan.astra <2018-11-14 Wed> + ;; This looks really ugly in the browser + [:tt "https://pronoun.is/subject-pronoun/object-pronoun/possessive-determiner/possessive-pronoun/reflexive"] + " displays examples of your pronouns."] + [:p "This is a bit unwieldy. If we have a good guess we'll let you use" + " just the first one or two."]]) (defn contact-block [] - (let [twitter-name (fn [handle] [:a {:href (str "https://www.twitter.com/" handle)} (str "@" handle)])] - [:div {:class "contact"} - [:p - "Written by " - (twitter-name "morganastra") - ", whose " - [:a {:href "http://pronoun.is/ze/zir"} "pronoun.is/ze/zir"] - ". " - "Visit the project on " [:a {:href "https://github.com/witch-house/pronoun.is"} "github!"]]])) - + (let [twitter-name (fn [handle] (href (str "https://www.twitter.com/" handle) + (str "@" handle)))] + [:div {:class "section contact"} + [:p "Written by " + (twitter-name "morganastra") + ", whose " + (href "https://pronoun.is/she" "pronoun.is/she")] + [:p "pronoun.is is free software under the " + (href "https://www.gnu.org/licenses/agpl.html" "AGPLv3") + "! visit the project on " + (href "https://github.com/witch-house/pronoun.is" "github")] + [:p "<3"]])) + +(defn footer-block [] + [:footer (usage-block) (contact-block)]) (defn format-pronoun-examples - [subject object possessive-determiner possessive-pronoun reflexive] - (let [title "Pronoun Island: English Language Examples"] - (html - [:html - [:head - [:title title] - [:meta {:name "viewport" :content "width=device-width"}] - [:link {:rel "stylesheet" :href "/pronouns.css"}]] - [:body - (title-block title) - (examples-block subject object possessive-determiner possessive-pronoun reflexive) - (about-block) - (contact-block)]]))) - - -(defn format-pronoun-json [& pronouns] - (json/write-str pronouns)) - + [pronoun-declensions] + (let [sub-objs (map #(s/join "/" (take 2 %)) pronoun-declensions) + title (str "Pronoun Island: " (prose-comma-list sub-objs) " examples") + examples (map #(apply examples-block %) pronoun-declensions)] + (html + [:html + [:head + [:title title] + [:meta {:name "viewport" :content "width=device-width"}] + [:meta {:name "description" :content (u/strip-markup examples)}] + [:meta {:name "twitter:card" :content "summary"}] + [:meta {:name "twitter:title" :content title}] + [:meta {:name "twitter:description" :content (u/strip-markup examples)}] + [:link {:rel "stylesheet" :href "/pronouns.css"}]] + [:body + (header-block title) + examples + (footer-block)]]))) -(defn parse-pronouns-with-lookup [pronouns-string pronouns-table] +(defn table-lookup* [pronouns-string] (let [inputs (s/split pronouns-string #"/") n (count inputs)] (if (>= n 5) (take 5 inputs) - (u/table-lookup inputs pronouns-table)))) + (u/table-lookup inputs @pronouns-table)))) + +(defn lookup-pronouns + "Given a seq of pronoun sets, look up each set in the pronouns table" + [pronoun-sets] + (->> pronoun-sets + (map (comp table-lookup* escape-html)) + (filter some?))) (defn make-link [path] (let [link (str "/" path) label path] - [:li [:a {:href link} label]])) + [:li (href link label)])) -(defn front [pronouns-table] - (let [abbreviations (u/abbreviate pronouns-table) +(defn front [] + (let [abbreviations (take 6 (u/abbreviate @pronouns-table)) links (map make-link abbreviations) title "Pronoun Island"] (html @@ -114,29 +167,72 @@ [:meta {:name "viewport" :content "width=device-width"}] [:link {:rel "stylesheet" :href "/pronouns.css"}]] [:body - (title-block title) - [:div {:class "table"} - [:p "pronoun.is is a www site for showing people how to use pronouns in English."] - [:p "here are some pronouns the site knows about:"] - [:ul links]]] - (contact-block)]))) - -(defn not-found [] - (str "We couldn't find those pronouns in our database, please ask us to " - "add them, or issue a pull request at " - "https://github.com/witch-house/pronoun.is/blob/master/resources/pronouns.tab")) + (header-block title) + [:div {:class "section table"} + [:p "pronoun.is is a website for personal pronoun usage examples"] + [:p "here are some pronouns the site knows about:"] + [:ul links] + [:p [:small (href "all-pronouns" "see all pronouns in the database")]]]] + (footer-block)]))) + +(defn all-pronouns [] + (let [abbreviations (u/abbreviate @pronouns-table) + links (map make-link abbreviations) + title "Pronoun Island"] + (html + [:html + [:head + [:title title] + [:meta {:name "viewport" :content "width=device-width"}] + [:link {:rel "stylesheet" :href "/pronouns.css"}]] + [:body + (header-block title) + [:div {:class "section table"} + [:p "All pronouns the site knows about:"] + [:ul links]]] + (footer-block)]))) + +(defn not-found [path] + (let [title "Pronoun Island: English Language Examples" + or-re #"/[oO][rR]/"] + (html + [:html + [:head + [:title title] + [:meta {:name "viewport" :content "width=device-width"}] + [:link {:rel "stylesheet" :href "/pronouns.css"}]] + [:body + (header-block title) + [:div {:class "section examples"} + [:p [:h2 "We couldn't find those pronouns in our database :("] + "If you think we should have them, please reach out!"] + (when (re-find or-re path) + (let [alts (s/split path or-re) + new-path (str "/" (s/join "/:OR/" alts))] + [:div + "Did you mean: " + (href new-path + (str "pronoun.is" + new-path))]))] + (footer-block)]]))) + +(defn pronouns [params format-fn not-found-fn] + (let [path (params :*) + param-alts (u/vec-coerce (or (params "or") [])) + path-alts (s/split path #"/:[oO][rR]/") + pronouns (lookup-pronouns (concat path-alts param-alts))] + (if (seq pronouns) + (format-fn pronouns) + (not-found-fn path)))) + +(defn format-pronoun-json [& pronouns] + (json/write-str pronouns)) (defn not-found-json [] (json/write-str {:error "Not found"})) -(defn pronouns-page [path pronouns-table format-pronouns not-found] - (let [pronouns (parse-pronouns-with-lookup (escape-html path) pronouns-table)] - (if pronouns - (apply format-pronouns pronouns) - (not-found)))) - -(defn pronouns [path pronouns-table] - (pronouns-page path pronouns-table format-pronoun-examples not-found)) - (defn pronouns-json [path pronouns-table] - (pronouns-page path pronouns-table format-pronoun-json not-found-json)) + (pronouns params format-pronoun-json not-found-json)) + +(defn pronouns-html [path pronouns-table] + (pronouns params format-pronoun-examples not-found)) diff --git a/src/pronouns/util.clj b/src/pronouns/util.clj index 4d4f928..7469dcf 100644 --- a/src/pronouns/util.clj +++ b/src/pronouns/util.clj @@ -1,31 +1,109 @@ +;; pronoun.is - a website for pronoun usage examples +;; Copyright (C) 2014 - 2018 Morgan Astra + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/> + (ns pronouns.util (:require [clojure.string :as s])) -(defn slurp-tabfile [path] +(defn slurp-tabfile + "Read a tabfile from a filesystem <path> as a table" + [path] (let [lines (s/split (slurp path) #"\n")] (map #(s/split % #"\t") lines))) +(defn table-front-filter + "filter a <table> to the rows which begin with <query-key>" + [query-key table] + (let [arity (count query-key)] + (filter #(= query-key (take arity %)) table))) + +(defn table-end-filter + "filter a <table> to the rows which end with <query-key>" + [query-key table] + (let [table-arity (count (first table)) + query-arity (count query-key)] + (filter #(= query-key (drop (- table-arity query-arity) %)) table))) + (defn table-lookup + "find the row corresponding to <query-key> in <table>" [query-key table] - (let [arity (count query-key) - filtered-table (filter #(= query-key (take arity %)) table)] - (first filtered-table))) - -(defn tabfile-lookup - [query-key tabfile] - (table-lookup query-key (slurp-tabfile tabfile))) - -(defn minimum-unambiguous-path - ([pronouns-table sections] (minimum-unambiguous-path pronouns-table sections 1)) - ([pronouns-table sections number-of-sections] - (let [sections-subset (take number-of-sections sections) - results (filter #(= (take number-of-sections %) sections-subset) pronouns-table)] - (case (count results) - 0 nil - 1 (clojure.string/join "/" sections-subset) - (recur pronouns-table sections (+ number-of-sections 1)))))) + (if (some #(= "..." %) query-key) + (let [[query-front query-end-] (split-with #(not= "..." %) query-key) + query-end (drop 1 query-end-) + front-matches (table-front-filter query-front table)] + (first (table-end-filter query-end front-matches))) + (first (table-front-filter query-key table)))) + +(defn shortest-unambiguous-forward-path + "Compute the shortest (in number of path elements) forward path which + unambiguously refers to a specific <row> in a <table>. The behavior of + this function is undefined if given a <row> that is not in the <table>. + + See also: shortest-unambiguous-path" + [table row] + (loop [n 1] + (let [row-front (take n row)] + (if (>= 1 (count (table-front-filter row-front table))) + row-front + (recur (inc n)))))) + +(defn shortest-unambiguous-ellipses-path + "Compute the shortest (in number of path elements) ellipses path which + unambiguously refers to a specific <row> in a <table>. The behavior of + this function is undefined if given a <row> that is not in the <table>. + + See also: shortest-unambiguous-path" + [table row] + (let [row-end (last row) + filtered-table (table-end-filter [row-end] table)] + (loop [n 1] + (let [row-front (take n row)] + (if (>= 1 (count (table-front-filter row-front filtered-table))) + (concat row-front ["..." row-end]) + (recur (inc n))))))) + +(defn shortest-unambiguous-path + "Compute the shortest (in number of path elements) path which unambiguously + refers to a specific <row> in a <table>. The behavior of this function is + undefined if given a <row> that is not in the <table>. + + A path can either be a 'forward path', in which it specifies the row with + elements from the front (e.g. ze/zir), or an 'ellipses path', which elides + unnecessary elements from the middle (e.g. they/.../themselves). If the + shortest forward and ellipses paths are the same length, prefer the forward + path" + [table row] + (let [forward-path (shortest-unambiguous-forward-path table row) + ellipses-path (shortest-unambiguous-ellipses-path table row)] + (s/join "/" + (if (> (count forward-path) (count ellipses-path)) + ellipses-path + forward-path)))) (defn abbreviate - "given a list of pronoun rows, return a list of minimum unabiguous paths" - [pronouns-table] - (map (partial minimum-unambiguous-path pronouns-table) pronouns-table)) + "return the list of minimum unabiguous paths from a <table>" + [table] + (map (partial shortest-unambiguous-path table) table)) + +(defn vec-coerce + "wrap a value <x> in a vector if it is not already in one. note that if + <x> is already in a sequence for which vector? is false, this will add + another layer of nesting." + [x] + (if (vector? x) x [x])) + +(defn strip-markup [form] + (s/join " " (filter string? (flatten form)))) + diff --git a/src/pronouns/web.clj b/src/pronouns/web.clj index 5af441f..6321198 100644 --- a/src/pronouns/web.clj +++ b/src/pronouns/web.clj @@ -1,64 +1,91 @@ +;; pronoun.is - a website for pronoun usage examples +;; Copyright (C) 2014 - 2018 Morgan Astra + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/> + (ns pronouns.web (:require [compojure.core :refer [defroutes GET PUT POST DELETE ANY]] [compojure.handler :refer [site]] [compojure.route :as route] - [clojure.java.io :as io] [clojure.string :as s] + [clojure.java.io :as io] + [ring.adapter.jetty :as jetty] [ring.middleware.logger :as logger] [ring.middleware.stacktrace :as trace] - [ring.middleware.session :as session] - [ring.middleware.session.cookie :as cookie] - [ring.adapter.jetty :as jetty] + [ring.middleware.params :as params] + [ring.middleware.resource :refer [wrap-resource]] + [ring.middleware.content-type :refer [wrap-content-type]] + [ring.middleware.not-modified :refer [wrap-not-modified]] [environ.core :refer [env]] [pronouns.util :as u] [pronouns.pages :as pages])) -(def config {:default-server-port 5000 - :pronoun-table-path "resources/pronouns.tab"}) -(def pronouns-table (u/slurp-tabfile (:pronoun-table-path config))) - (defroutes app-routes (GET "/" [] {:status 200 :headers {"Content-Type" "text/html"} - :body (pages/front pronouns-table)}) + :body (pages/front)}) + + (GET "/all-pronouns" [] + {:status 200 + :headers {"Content-Type" "text/html"} + :body (pages/all-pronouns)}) - (GET "/pronouns.css" {params :params} + (GET "/pronouns.css" [] {:status 200 :headers {"Content-Type" "text/css"} :body (slurp (io/resource "pronouns.css"))}) (GET "/*" {params :params headers :headers} - (if (= "application/json" (.toLowerCase (get headers "accept"))) + (if (= "application/json" (s/lower-case (get headers "accept"))) {:status 200 :headers {"Content-Type" "application/json"} - :body (pages/pronouns-json (:* params) pronouns-table)} + :body (pages/pronouns-json params pronouns-table)} {:status 200 :headers {"Content-Type" "text/html"} - :body (pages/pronouns (:* params) pronouns-table)})) + :body (pages/pronouns params pronouns-table)})) (ANY "*" [] (route/not-found (slurp (io/resource "404.html"))))) +(defn wrap-gnu-natalie-nguyen [handler] + (fn [req] + (when-let [resp (handler req)] + (assoc-in resp [:headers "X-Clacks-Overhead"] "GNU Natalie Nguyen")))) + (defn wrap-error-page [handler] (fn [req] (try (handler req) (catch Exception e - {:status 500 - :headers {"Content-Type" "text/html"} - :body (slurp (io/resource "500.html"))})))) + (binding [*out* *err*] + {:status 500 + :headers {"Content-Type" "text/html"} + :body (slurp (io/resource "500.html"))}))))) (def app (-> app-routes + ;; FIXME morgan.astra <2018-11-14 Wed> + ;; use this resource or delete it + ;; (wrap-resource "images") + wrap-content-type + wrap-not-modified logger/wrap-with-logger wrap-error-page - trace/wrap-stacktrace)) + wrap-gnu-natalie-nguyen + trace/wrap-stacktrace + params/wrap-params)) (defn -main [] - (let [port (Integer. (:port env - (:default-server-port config)))] + (let [port (Integer. (:port env))] (jetty/run-jetty app {:port port}))) - -;; For interactive development: -;; (.stop server) -;; (def server (-main)) |