├── .gitignore
├── COPYING
├── README.md
├── bin
    └── start.lisp
├── data
    ├── attack-grammar.lisp
    ├── brag-grammar.lisp
    ├── brain.lisp
    ├── bugzilla.dtd
    ├── cursewords.txt
    ├── food-grammar.lisp
    ├── insult-grammar.lisp
    ├── manage-grammar.lisp
    ├── oracle.dat
    ├── panic-grammar.lisp
    ├── paste.css
    ├── plots-grammar.lisp
    ├── robots.lisp
    ├── slogan-grammar.lisp
    ├── solve-grammar.lisp
    └── syllable-dict.txt
├── doc
    └── manual.md
├── orcabot.asd
└── src
    ├── abbrev.lisp
    ├── admin.lisp
    ├── automsg.lisp
    ├── basic.lisp
    ├── bitcoin.lisp
    ├── bugzilla.lisp
    ├── calc.lisp
    ├── chant.lisp
    ├── chat.lisp
    ├── credit.lisp
    ├── db.lisp
    ├── defpackage.lisp
    ├── env.lisp
    ├── fifa.lisp
    ├── grammar.lisp
    ├── groups.lisp
    ├── karma.lisp
    ├── lastseen.lisp
    ├── liarsdice.lisp
    ├── logging.lisp
    ├── lojban.lisp
    ├── main.lisp
    ├── memo.lisp
    ├── module.lisp
    ├── parrot.lisp
    ├── pastebin.lisp
    ├── patches.lisp
    ├── pick.lisp
    ├── poetry.lisp
    ├── quote.lisp
    ├── reminder.lisp
    ├── respond.lisp
    ├── rt.lisp
    ├── stats.lisp
    ├── stock.lisp
    ├── strings.lisp
    ├── subversion.lisp
    ├── trivia.lisp
    ├── typist.lisp
    ├── utils.lisp
    ├── weather.lisp
    ├── web.lisp
    └── werewolf.lisp


/.gitignore:
--------------------------------------------------------------------------------
1 | *.fasl
2 | logs/*


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Orcabot - A modular IRC bot
 2 | ===========================
 3 | 
 4 | Orcabot is an IRC bot written in Common Lisp, intended to be
 5 | functional and easy to maintain.  It was developed using sbcl, so this
 6 | documentation assumes that you have sbcl installed.
 7 | 
 8 | Orcabot also depends on quicklisp to load the libraries it depends on, and
 9 | assumes that quicklisp is loaded in your .sbclrc file.
10 | 
11 | When you start orcabot, you specify a writable directory where all of
12 | its stored data goes.  This directory must have a file in it called
13 | "config.lisp".  Orcabot gets all of its initial configuration from
14 | this file.  Here is a minimal example session:
15 | 
16 |     (nick "orcabot")
17 |     (server "irc.example.com" :port 6667)
18 |     (autojoin "#orcabot" "#lisp")
19 |     (modules admin basic chant)
20 |     (access
21 |       (allow :user "me" :modules (admin))
22 |       (deny :modules (admin)))
23 | 
24 | To start orcabot, running this at the command line should be all that
25 | is required:
26 | 
27 |     sbcl --load "bin/start.lisp" <data directory>
28 | 
29 | Each module can be enabled or disabled independently of the others,
30 | and can implement a wide array of features.  A list of modules can be
31 | found within the documentation.
32 | 


--------------------------------------------------------------------------------
/bin/start.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (ql:quickload "orcabot")
16 | (orcabot::start-orcabot-session (second *posix-argv*))
17 | (sb-ext:quit)


--------------------------------------------------------------------------------
/data/attack-grammar.lisp:
--------------------------------------------------------------------------------
 1 | (sentence -> (or suggestion command))
 2 | 
 3 | (suggestion -> suggest-preamble attack "?")
 4 | (suggest-preamble -> (or "Might I suggest"
 5 |                          "Can I suggest"
 6 |                          "Should we attack immediately with"))
 7 | 
 8 | (command -> command-preamble attack "!")
 9 | (command-preamble -> (or ("We should attack" thing "now with")
10 |                          ("We must attack" thing "now with")
11 |                          ("I suggest attacking" thing "with")
12 |                          ("We should coordinate an attack with")))
13 | 
14 | (attack -> method-of-attack type-of-attack "with" (? attack-adjective) attack-object "and" attack-object-two)
15 | 
16 | (method-of-attack -> (a (or "full-frontal"
17 |                             "pincer" "surprise" "brutally excessive" "multi-pronged" "glorious"
18 |                             "violent" "devastating" "superior" "fast-paced" "fleet-wide" "stealth"
19 |                             "diversionary" "exceptional" "point-blank" "night time"
20 |                             "acid-heavy" "immediate" "overwhelming" "unstoppable" "underground" "aerial"
21 |                             "naval" "amphibious" "full-scale")))
22 | (type-of-attack -> (or "assault" "attack" "bombardment" "offensive" "barrage" "charge" "strike" "operation"
23 |                        "maneuver" "blitzkrieg" "ambush" "massacre"))
24 | 
25 | (attack-adjective -> (or "laser" "berserker" "acid" "armoured attack" "proton"
26 |                          "three kinds of" "atomic" "toxic" "explosive"
27 |                          "red-hot" "thermal" "automated fire" "cluster"
28 |                          "enhanced germ" "energy-drink-fueled" "battle ready" "Sontaran" "military"))
29 | (attack-object -> (or "bees" "chainsaws" "marmots" "acid" "monkeys" "mines" "bombs" "snakes" "spiders"
30 |                       "knives" "rockets" "sharks" "owls" "repurposed cybermats" "cannons" "alligators" "ants"
31 |                       "gorillas" "genetically enhanced cyber-elephants" "mechanoids" "KGB agents"
32 |                       "MI5 operatives" "thermonuclear missiles"))
33 | (attack-object-two -> (or "robots" "ninjas" "grenades" "a dolphin full of napalm" "dynamite"
34 |                           "xenomorphs" "lots and lots of C4" "tactical nukes" "bio-weapons"
35 |                           "rocket launchers" "an elephant" "a memory worm for afterwards" "this pencil"))
36 | 


--------------------------------------------------------------------------------
/data/brag-grammar.lisp:
--------------------------------------------------------------------------------
  1 | (sentence -> (or (frag end)
  2 |              (frag sentence)))
  3 | 
  4 | (end -> "")
  5 | 
  6 | (frag -> (or
  7 |           ("I " act "!")
  8 |           ("Pardon my language.")
  9 |           ("But " yell " let the " entities " bear witness!")
 10 |           ("Even in the belly of the Thunderbird I've been casting out the " entities "; I'm busting my " body-part " and blowing my O-ring, and ripe to throw a *loaf*!")
 11 |           ("For I speak *only* the " emphatic " *Truth*, and never in my days have I spoken other than! For my every utterance is a lie, including this very one you hear!")
 12 |           ("I say, `" slogan "'. By God, `" slogan "', I say!")
 13 |           ("I am " entity ", I am " entity "!")
 14 |           ("I'll drive a mile so as not to walk a foot; I am " entity "!")
 15 |           ("Yes, I'm " entity "!")
 16 |           ("I drank *" being "* under " number " tables, I am too " adjective " to die, I'm insured for acts o' God *and* Satan!")
 17 |           ("I was shanghaied by " entities " and " entities " from " place ", and got away with their hubcaps!")
 18 |           ("I *cannot* be tracked on radar!")
 19 |           ("I wear nothing uniform, I wear *no* " emphatic " uniform!")
 20 |           ("Yes baby, I'm " number " feet tall and have " number " rows o' " body-part-plural "; I was suckled by a " pet ", I gave " she-being " a high-protein tonsil wash!")
 21 |           ("I'm a bacteriological weapon, I am *armed* and *loaded*!")
 22 |           ("I'm a fission reactor, I fart plutonium, power plants are fueled by the " spoor " of my " body-part "; when they plug *me* in, the lights go out in " place "!")
 23 |           ("I weigh " number " pounds in zero gravity, *" attack "*!")
 24 |           ("I've sired " entities " across " place ", I cook and *eat* my dead; " yell "  I'm the Unshaven Thorn Tree of " place "!")
 25 |           ("I " act "!")
 26 |           (being "'s hands are my *ideal* playground!")
 27 |           ("I hold the " number "-Bladed Windbreaker; the wheels that turn are behind me; I think *backwards*!")
 28 |           ("I do it for *fun*!")
 29 |           ("My imagination is a *" emphatic "* cancer and I'll pork it before it porks me!")
 30 |           ("They say a godzillion is the highest number there is. Well by God! I count to a godzillion and *one*!")
 31 |           ("Yes, I'm the purple flower of " place ", give me wide berth; when I drop my drawers, " being " swoons!")
 32 |           ("I use a " pet " for a prophylactic; I'm *thicker, harder* and *meaner* than the Alaskan Pipeline, and carry more " spoor "!")
 33 |           ("I'll freeze *your* " spoor " before it hits the bathroom tile!")
 34 |           (yell)
 35 |           ("I kidnapped the future and ransomed it for the past, I made *" being "* wait up for me to bleed my " pet "!")
 36 |           ("My infernal " spoor " wilts the Tree of Life, I left my *" spoor "* on the Rock of Ages, *who'll " attack ", who'll spill their juice*?")
 37 |           ("Who'll " attack ", whose candle will I fart out?")
 38 |           ("Whoop! I'm ready!")
 39 |           ("So step aside, all you butt-lipped, neurotic, insecure bespectacled " entities "!")
 40 |           ("I'm " entity ", I am Not Insane!")
 41 |           ("I'm a screamer and a laugher, I " act ", I am a *sight*!")
 42 |           ("My physical type *cannot* be classified by science, my `familiar' is a " pet ", I feed it " entities "!")
 43 |           ("I communicate without *wires* or *strings*!")
 44 |           ("I am a Thuggee, I am feared in the Tongs, I have the Evil " body-part ", I carry the Mojo Bag; I swam *" place "* and didn't get wet!")
 45 |           ("I circumcize " entities " with my teeth and make 'em leave a tip; I change tires with my *tongue* and my *tool*!")
 46 |           ("Every night I hock up a lunger and extinguish the *Sun*!")
 47 |           ("I'm " entity ", who'll try to " attack "?")
 48 |           ("I've packed the brownies of the " entities ", I leak the Plague from my " body-part-plural ", opiates are the *mass* of my religion, *I " act "!*")
 49 |           ("Yes, I'm a rip-snorter, I cram coca leaves right into my " body-part-plural "before they're picked off the *tree*!")
 50 |           ("*" entities "* cringe at my tread!")
 51 |           ("I " act ".")
 52 |           ("I'm " adjective ", I'll live forever and remember it afterwards!")
 53 |           ("I'm " adjective "!")
 54 |           ("I'm " adjective "!")
 55 |           ("Come *on* and give me cancer, I'll spit up the tumor and butter my *bread* with the juice!")
 56 |           ("I'm " adjective ", I " act "!")
 57 |           ("My droppings bore through the earth and erupt *volcanoes* in *" place "*!")
 58 |           ("Yes, I can drink more wine and stay soberer than all the " entities " in " place "!")
 59 |           (yell "*" body-part " Blowout*!")
 60 |           ("I am a *Moray Eel*, I am a *Komodo Dragon*, I am the *Killer Whale bereft of its pup*!")
 61 |           ("I have a triple " body-part ", I was sired by " being)
 62 |           ("I told *" he-being "* I wouldn't go to church and He *shook my hand*!")
 63 |           ("I am a " emphatic " *visionary*, I see the future and the past in comic books and wine bottles; I eat *black holes* for breakfast!")
 64 |           ("I " act "!")
 65 |           ("I " act "!")
 66 |           ("I ran 'em out of Heaven and sold it to Hell for a *profit*!")
 67 |           ("I'm enlightened, I achieved `Nirvana' and took it *home* with me.")
 68 |           (yell)
 69 |           ("I'm so ugly the Speed of Light can't slow me down and Gravity won't tug at my cuffs!")
 70 |           (slogan "")
 71 |           (slogan "")))
 72 | 
 73 | (emphatic -> (or "frakking" "damned" "DAMN" "fscking"))
 74 | 
 75 | (attack -> (or "blow me down" "gouge with me" "come and get me"
 76 |                "engage me in a battle of wits"
 77 |                "tear flesh with me"))
 78 | 
 79 | (spoor -> (or "spoor" "seed" "breath" "sweat" "spew"))
 80 | 
 81 | (number -> (or "seven" "23" "13" "666" "273" "42"))
 82 | 
 83 | (entity -> (or
 84 |             "a Crime Fighting Master Criminal"
 85 |             ("a "pet)
 86 |             "the bigfooted devil of Level 14"
 87 |             "the last remaining Homo Correctus"
 88 |             ("the " emphatic " Man of the Future" )
 89 |             ("a human being of the *first* " emphatic " water")
 90 |             ("the javalina humping junkie that jumped the " entities)))
 91 | 
 92 | (pet -> (or "pterodactyl" "python" "triceratops" "giant lizard"))
 93 | 
 94 | (being -> (or she-being he-being))
 95 | 
 96 | (she-being -> (or "Mother Nature" "God" "the Anti-Virgin"))
 97 | 
 98 | (he-being -> (or "the Devil" "Father Time" "Jesus" "the Wolf Man"))
 99 | 
100 | (entities -> (or "bodiless fiends" "Men from Mars"
101 |                  "heathen *Hindoos*" "space monsters"
102 |                  "sons of God and man" "False Prophets" "gods" "dinosaurs"
103 |                  "retarded space bastards" "slabs o' wimp meat" "dipshits"))
104 | 
105 | (body-part -> (or "nose" "gut" "arm-vein" "nether part"
106 |                   "backbone" "brow" "teat"))
107 | 
108 | (body-part-plural -> (or "noses" "guts" "arm-veins" "nether parts"
109 |                   "backbones" "brows" "teats"))
110 | 
111 | (yell -> (or "YEEE HAW!" "YEE! YEEE!" "*Yip, yip, YEEEEEEE!*"
112 |              "YEEEEEHAW!" "YAH-HOOOO!"))
113 | 
114 | (slogan -> (or "Fuck 'em if they can't take a joke!" "Anything for a laugh!"
115 |                "When the Rapture comes, I'll make 'em wait!"
116 |                "They'll *never* clean *my* cage!"))
117 | 
118 | (act -> (or
119 |          ("pick the " emphatic " terror of the " emphatic entities " out of my *" body-part "*")
120 |          "pay no taxes" "take drugs"
121 |          "make a *spectacle* of myself"
122 |          "wipe the *Pyramids* off my shoes before I enter *my* house"
123 |          "bend *crowbars* with my meat ax and a thought"
124 |          "bend my genes and whittle my DNA with the sheer force of my mighty *will*"
125 |          ("steer my *own* " emphatic " evolution")))
126 | 
127 | (adjective -> (or "*fuel-injected*" "*immune*" "*radioactive*"
128 |                   "*supernatural*" "*intense*"))
129 | 
130 | (place -> (or "China" "Hong Kong" "Asia" "the Atlantis Zoo" "the Cosmos"
131 |               "a corporate galaxy" "Hell County" "the Bermuda Triangle"))
132 | 


--------------------------------------------------------------------------------
/data/bugzilla.dtd:
--------------------------------------------------------------------------------
 1 | <!ELEMENT bugzilla (bug+)>
 2 | <!ATTLIST bugzilla
 3 | 	version CDATA #REQUIRED
 4 | 	urlbase CDATA #REQUIRED
 5 | 	maintainer CDATA #REQUIRED
 6 | 	exporter CDATA #IMPLIED
 7 | >
 8 | <!ELEMENT bug (bug_id, (alias?, creation_ts, short_desc, delta_ts, reporter_accessible, cclist_accessible, classification_id, classification, product, component, version, rep_platform, op_sys, bug_status, resolution?, dup_id?, bug_file_loc?, status_whiteboard?, keywords*, priority, bug_severity, target_milestone?, dependson*, blocked*, votes?, everconfirmed, reporter, assigned_to, qa_contact?, cc*, (estimated_time, remaining_time, actual_time, deadline)?, group*, flag*, long_desc*, attachment*)?)>
 9 | <!ATTLIST bug
10 | 	error (NotFound | NotPermitted | InvalidBugId) #IMPLIED
11 | >
12 | <!ELEMENT bug_id (#PCDATA)>
13 | <!ELEMENT alias (#PCDATA)>
14 | <!ELEMENT reporter_accessible (#PCDATA)>
15 | <!ELEMENT cclist_accessible (#PCDATA)>
16 | <!ELEMENT exporter (#PCDATA)>
17 | <!ELEMENT urlbase (#PCDATA)>
18 | <!ELEMENT bug_status (#PCDATA)>
19 | <!ELEMENT classification_id (#PCDATA)>
20 | <!ELEMENT classification (#PCDATA)>
21 | <!ELEMENT product (#PCDATA)>
22 | <!ELEMENT priority (#PCDATA)>
23 | <!ELEMENT version (#PCDATA)>
24 | <!ELEMENT rep_platform (#PCDATA)>
25 | <!ELEMENT assigned_to (#PCDATA)>
26 | <!ELEMENT delta_ts (#PCDATA)>
27 | <!ELEMENT component (#PCDATA)>
28 | <!ELEMENT reporter (#PCDATA)>
29 | <!ELEMENT target_milestone (#PCDATA)>
30 | <!ELEMENT bug_severity (#PCDATA)>
31 | <!ELEMENT creation_ts (#PCDATA)>
32 | <!ELEMENT qa_contact (#PCDATA)>
33 | <!ELEMENT status_whiteboard (#PCDATA)>
34 | <!ELEMENT op_sys (#PCDATA)>
35 | <!ELEMENT resolution (#PCDATA)>
36 | <!ELEMENT dup_id (#PCDATA)>
37 | <!ELEMENT bug_file_loc (#PCDATA)>
38 | <!ELEMENT short_desc (#PCDATA)>
39 | <!ELEMENT keywords (#PCDATA)>
40 | <!ELEMENT dependson (#PCDATA)>
41 | <!ELEMENT blocked (#PCDATA)>
42 | <!ELEMENT votes (#PCDATA)>
43 | <!ELEMENT everconfirmed (#PCDATA)>
44 | <!ELEMENT cc (#PCDATA)>
45 | <!ELEMENT group (#PCDATA)>
46 | <!ELEMENT estimated_time (#PCDATA)>
47 | <!ELEMENT remaining_time (#PCDATA)>
48 | <!ELEMENT actual_time (#PCDATA)>
49 | <!ELEMENT deadline (#PCDATA)>
50 | <!ELEMENT long_desc (who, bug_when, work_time?, thetext)>
51 | <!ATTLIST long_desc
52 |           encoding (base64) #IMPLIED
53 |           isprivate (0|1) #IMPLIED
54 |  >
55 | <!ELEMENT who (#PCDATA)>
56 | <!ELEMENT bug_when (#PCDATA)>
57 | <!ELEMENT work_time (#PCDATA)>
58 | <!ELEMENT thetext (#PCDATA)>
59 | <!ELEMENT attachment (attachid, date, desc, filename?, type?, size?, data?, flag*)>
60 | <!ATTLIST attachment
61 |           isobsolete (0|1) #IMPLIED
62 |           ispatch (0|1) #IMPLIED
63 |           isprivate (0|1) #IMPLIED
64 | >
65 | <!ELEMENT attachid (#PCDATA)>
66 | <!ELEMENT date (#PCDATA)>
67 | <!ELEMENT desc (#PCDATA)>
68 | <!ELEMENT filename (#PCDATA)>
69 | <!ELEMENT type (#PCDATA)>
70 | <!ELEMENT size (#PCDATA)>
71 | <!ELEMENT data (#PCDATA)>
72 | <!ATTLIST data
73 |           encoding (base64) #IMPLIED
74 | >
75 | <!ELEMENT flag EMPTY>
76 | <!ATTLIST flag
77 |           name CDATA #REQUIRED
78 |           status CDATA #REQUIRED
79 |           setter CDATA #IMPLIED
80 |           requestee CDATA #IMPLIED
81 | >
82 | 


--------------------------------------------------------------------------------
/data/cursewords.txt:
--------------------------------------------------------------------------------
  1 | 4r5e
  2 | 5h1t
  3 | 5hit
  4 | a55
  5 | anal
  6 | anus
  7 | ar5e
  8 | arrse
  9 | arse
 10 | ass
 11 | ass-fucker
 12 | asses
 13 | assfucker
 14 | assfukka
 15 | asshole
 16 | assholes
 17 | asswhole
 18 | a_s_s
 19 | b!tch
 20 | b00bs
 21 | b17ch
 22 | b1tch
 23 | ballbag
 24 | balls
 25 | ballsack
 26 | bastard
 27 | beastial
 28 | beastiality
 29 | bellend
 30 | bestial
 31 | bestiality
 32 | bi+ch
 33 | biatch
 34 | bitch
 35 | bitcher
 36 | bitchers
 37 | bitches
 38 | bitchin
 39 | bitching
 40 | bloody
 41 | blow job
 42 | blowjob
 43 | blowjobs
 44 | boiolas
 45 | bollock
 46 | bollok
 47 | boner
 48 | boob
 49 | boobs
 50 | booobs
 51 | boooobs
 52 | booooobs
 53 | booooooobs
 54 | breasts
 55 | buceta
 56 | bugger
 57 | bum
 58 | bunny fucker
 59 | butt
 60 | butthole
 61 | buttmuch
 62 | buttplug
 63 | c0ck
 64 | c0cksucker
 65 | carpet muncher
 66 | cawk
 67 | chink
 68 | cipa
 69 | cl1t
 70 | clit
 71 | clitoris
 72 | clits
 73 | cnut
 74 | cock
 75 | cock-sucker
 76 | cockface
 77 | cockhead
 78 | cockmunch
 79 | cockmuncher
 80 | cocks
 81 | cocksuck
 82 | cocksucked
 83 | cocksucker
 84 | cocksucking
 85 | cocksucks
 86 | cocksuka
 87 | cocksukka
 88 | cok
 89 | cokmuncher
 90 | coksucka
 91 | coon
 92 | cox
 93 | crap
 94 | cum
 95 | cummer
 96 | cumming
 97 | cums
 98 | cumshot
 99 | cunilingus
100 | cunillingus
101 | cunnilingus
102 | cunt
103 | cuntlick
104 | cuntlicker
105 | cuntlicking
106 | cunts
107 | cyalis
108 | cyberfuc
109 | cyberfuck
110 | cyberfucked
111 | cyberfucker
112 | cyberfuckers
113 | cyberfucking
114 | d1ck
115 | damn
116 | dick
117 | dickhead
118 | dildo
119 | dildos
120 | dink
121 | dinks
122 | dirsa
123 | dlck
124 | dog-fucker
125 | doggin
126 | dogging
127 | donkeyribber
128 | doosh
129 | duche
130 | dyke
131 | ejaculate
132 | ejaculated
133 | ejaculates
134 | ejaculating
135 | ejaculatings
136 | ejaculation
137 | ejakulate
138 | f u c k
139 | f u c k e r
140 | f4nny
141 | fag
142 | fagging
143 | faggitt
144 | faggot
145 | faggs
146 | fagot
147 | fagots
148 | fags
149 | fanny
150 | fannyflaps
151 | fannyfucker
152 | fanyy
153 | fatass
154 | fcuk
155 | fcuker
156 | fcuking
157 | feck
158 | fecker
159 | felching
160 | fellate
161 | fellatio
162 | fingerfuck
163 | fingerfucked
164 | fingerfucker
165 | fingerfuckers
166 | fingerfucking
167 | fingerfucks
168 | fistfuck
169 | fistfucked
170 | fistfucker
171 | fistfuckers
172 | fistfucking
173 | fistfuckings
174 | fistfucks
175 | flange
176 | fook
177 | fooker
178 | fuck
179 | fucka
180 | fucked
181 | fucker
182 | fuckers
183 | fuckhead
184 | fuckheads
185 | fuckin
186 | fucking
187 | fuckings
188 | fuckingshitmotherfucker
189 | fuckme
190 | fucks
191 | fuckwhit
192 | fuckwit
193 | fudge packer
194 | fudgepacker
195 | fuk
196 | fuker
197 | fukker
198 | fukkin
199 | fuks
200 | fukwhit
201 | fukwit
202 | fux
203 | fux0r
204 | f_u_c_k
205 | gangbang
206 | gangbanged
207 | gangbangs
208 | gaylord
209 | gaysex
210 | goatse
211 | God
212 | god-dam
213 | god-damned
214 | goddamn
215 | goddamned
216 | hardcoresex
217 | hell
218 | heshe
219 | hoar
220 | hoare
221 | hoer
222 | homo
223 | hore
224 | horniest
225 | horny
226 | hotsex
227 | jack-off
228 | jackoff
229 | jap
230 | jerk-off
231 | jism
232 | jiz
233 | jizm
234 | jizz
235 | kawk
236 | knob
237 | knobead
238 | knobed
239 | knobend
240 | knobhead
241 | knobjocky
242 | knobjokey
243 | kock
244 | kondum
245 | kondums
246 | kum
247 | kummer
248 | kumming
249 | kums
250 | kunilingus
251 | l3i+ch
252 | l3itch
253 | labia
254 | lmfao
255 | lust
256 | lusting
257 | m0f0
258 | m0fo
259 | m45terbate
260 | ma5terb8
261 | ma5terbate
262 | masochist
263 | master-bate
264 | masterb8
265 | masterbat*
266 | masterbat3
267 | masterbate
268 | masterbation
269 | masterbations
270 | masturbate
271 | mo-fo
272 | mof0
273 | mofo
274 | mothafuck
275 | mothafucka
276 | mothafuckas
277 | mothafuckaz
278 | mothafucked
279 | mothafucker
280 | mothafuckers
281 | mothafuckin
282 | mothafucking
283 | mothafuckings
284 | mothafucks
285 | mother fucker
286 | motherfuck
287 | motherfucked
288 | motherfucker
289 | motherfuckers
290 | motherfuckin
291 | motherfucking
292 | motherfuckings
293 | motherfuckka
294 | motherfucks
295 | muff
296 | mutha
297 | muthafecker
298 | muthafuckker
299 | muther
300 | mutherfucker
301 | n1gga
302 | n1gger
303 | nazi
304 | nigg3r
305 | nigg4h
306 | nigga
307 | niggah
308 | niggas
309 | niggaz
310 | nigger
311 | niggers
312 | nob
313 | nob jokey
314 | nobhead
315 | nobjocky
316 | nobjokey
317 | numbnuts
318 | nutsack
319 | orgasim
320 | orgasims
321 | orgasm
322 | orgasms
323 | p0rn
324 | pawn
325 | pecker
326 | penis
327 | penisfucker
328 | phonesex
329 | phuck
330 | phuk
331 | phuked
332 | phuking
333 | phukked
334 | phukking
335 | phuks
336 | phuq
337 | pigfucker
338 | pimpis
339 | piss
340 | pissed
341 | pisser
342 | pissers
343 | pisses
344 | pissflaps
345 | pissin
346 | pissing
347 | pissoff
348 | poop
349 | porn
350 | porno
351 | pornography
352 | pornos
353 | prick
354 | pricks
355 | pron
356 | pube
357 | pusse
358 | pussi
359 | pussies
360 | pussy
361 | pussys
362 | rectum
363 | retard
364 | rimjaw
365 | rimming
366 | s hit
367 | s.o.b.
368 | sadist
369 | schlong
370 | screwing
371 | scroat
372 | scrote
373 | scrotum
374 | semen
375 | sex
376 | sh!+
377 | sh!t
378 | sh1t
379 | shag
380 | shagger
381 | shaggin
382 | shagging
383 | shemale
384 | shi+
385 | shit
386 | shitdick
387 | shite
388 | shited
389 | shitey
390 | shitfuck
391 | shitfull
392 | shithead
393 | shiting
394 | shitings
395 | shits
396 | shitted
397 | shitter
398 | shitters
399 | shitting
400 | shittings
401 | shitty
402 | skank
403 | slut
404 | sluts
405 | smegma
406 | smut
407 | snatch
408 | son-of-a-bitch
409 | spac
410 | spunk
411 | s_h_i_t
412 | t1tt1e5
413 | t1tties
414 | teets
415 | teez
416 | testical
417 | testicle
418 | tit
419 | titfuck
420 | tits
421 | titt
422 | tittie5
423 | tittiefucker
424 | titties
425 | tittyfuck
426 | tittywank
427 | titwank
428 | tosser
429 | turd
430 | tw4t
431 | twat
432 | twathead
433 | twatty
434 | twunt
435 | twunter
436 | v14gra
437 | v1gra
438 | vagina
439 | viagra
440 | vulva
441 | w00se
442 | wang
443 | wank
444 | wanker
445 | wanky
446 | whoar
447 | whore
448 | willies
449 | willy
450 | xrated
451 | xxx
452 | 


--------------------------------------------------------------------------------
/data/food-grammar.lisp:
--------------------------------------------------------------------------------
  1 | (sentence -> throws (a food-item) at target ".  " result)
  2 | (eats -> (or "eats" "consumes" "gobbles" "absorbs"
  3 |              "bolts" "devours" "feeds upon" "inhales" "puts away"
  4 |              "polishes off" "wolfs down on"))
  5 | (adverb -> (or "angrily" "apologetically" "arrogantly"
  6 |                "bitterly" "boldly" "brutally" "callously" "calmly" "carefully"
  7 |                "cautiously" "cheerfully" "contentedly" "craftily" "crazily"
  8 |                "creepily" "curiously" "defiantly" "desperately"
  9 |                "diabolically" "dismally" "disdainfully" "drunkenly"
 10 |                "dreamily" "enthusiastically" "excitedly" "fearfully"
 11 |                "fiercely" "fondly" "gently" "graciously" "gruffly"
 12 |                "grumpily" "happily" "hungrily" "impatiently"
 13 |                "inquisitively" "lazily" "loudly" "lustily"
 14 |                "passionately" "politely" "quickly" "quietly"
 15 |                "rudely" "ruthlessly" "savagely" "seductively" "sensually"
 16 |                "shamelessly" "solemnly" "stoically" "thoughtfully"
 17 |                "valiantly"))
 18 | (sentence-self -> adverb eats (a food-item))
 19 | (throws -> (or "throws" "tosses" "lobs" "casts" "chucks" "flings" "heaves" "hurls" "lets fly" "slings"))
 20 | (at -> (or "at" "towards"))
 21 | (result -> (or "It hits!" "It hits!" "It hits!" "It hits!"
 22 |                "It misses!" "It misses!" "It misses!" "It misses!" "It misses!"
 23 |                ("It misses and hits" bystander "!")))
 24 | (food-prepared -> (or "chocolate-covered"
 25 |                       "homemade"
 26 |                       "mass-produced"
 27 |                       "braised"
 28 |                       "boiled"
 29 |                       "fried"
 30 |                       "deep fried"
 31 |                       "roasted"
 32 |                       "gourmet"
 33 |                       "grilled"
 34 |                       "raw"
 35 |                       "Hungarian"
 36 |                       "Irish"))
 37 | (meat -> (or "chicken"
 38 |              "turkey"
 39 |              "pork"
 40 |              "beef"
 41 |              "duck"
 42 |              "veal"
 43 |              "venison"
 44 |              "goat"
 45 |              "tuna"
 46 |              "salmon"))
 47 | (fruit -> (or "apple"
 48 |               "banana"
 49 |               "pear"
 50 |               "peach"
 51 |               "plum"
 52 |               "mango"))
 53 | (vegetable -> (or "carrot"
 54 |                   "celery"
 55 |                   "lettuce"
 56 |                   "arugula"
 57 |                   "onion"))
 58 | (grain -> (or ("wheat"
 59 |                "oat"
 60 |                "rice")))
 61 | (protein -> (or "egg"
 62 |                 "black bean"
 63 |                 "pinto bean"))
 64 | (cheese -> (or "cheddar"
 65 |                "parmesan"
 66 |                "gouda"
 67 |                "provolone"
 68 |                "brie"
 69 |                "swiss"
 70 |                "mozzarella"
 71 |                "muenster"
 72 |                "colby"
 73 |                "goat cheese"))
 74 | (nut -> (or "cashew"
 75 |             "walnut"
 76 |             "peanut"))
 77 | (flavor -> (or "chocolate"
 78 |                "vanilla"
 79 |                "strawberry"
 80 |                "blueberry"
 81 |                "coffee"))
 82 | (ingredient -> (or meat
 83 |                    fruit
 84 |                    vegetable
 85 |                    cheese
 86 |                    protein))
 87 | (ingredients -> (or ingredient
 88 |                     (ingredient "and" ingredient)
 89 |                     (ingredient "," ingredient ", and" ingredient)))
 90 | (salad-greens -> (or "spinach"
 91 |                      "lettuce"
 92 |                      "iceburg lettuce"
 93 |                      "spring mix"
 94 |                      "arugula"))
 95 | (salad-dressing -> (or (fruit "vinegarette")
 96 |                        "balsamic vinegarette"
 97 |                        "oil and vinegar"))
 98 | (food-item -> (? food-prepared)
 99 |            (or ingredient
100 |                (ingredients "stew")
101 |                (ingredients "pasta")
102 |                (ingredients "fricasee")
103 |                (ingredients "curry")
104 |                (ingredients "chili")
105 |                (ingredients "sandwich")
106 |                (ingredients "soup")
107 |                (ingredient "on a stick")
108 |                ("filet of" meat)
109 |                (meat "pie")
110 |                (fruit "pie")
111 |                (fruit nut "bread")
112 |                (fruit nut "salad")
113 |                (fruit cheese "salad")
114 |                (salad-greens "with" salad-dressing)
115 |                (flavor "cupcake")
116 |                (flavor "candy")
117 |                "mashed potatoes"
118 |                "corn on the cob"
119 |                "meatloaf"
120 |                "brownie"
121 |                "hamburger"
122 |                "twinkie"
123 |                "corn dog"))


--------------------------------------------------------------------------------
/data/insult-grammar.lisp:
--------------------------------------------------------------------------------
  1 | (sentence -> (or command-first thou-first))
  2 | (command-first -> command "thou" adj-1 (? adj-2) noun "!")
  3 | (thou-first -> "thou art" adj-1 "and" adj-2 (? "," (? adj-1) noun) "."  (? command "!"))
  4 | 
  5 | (command -> (or "Away I say"
  6 |                 "Bathe thyself"
  7 |                 "Behold thy mirror"
  8 |                 "Beware my sting"
  9 |                 "Clean thine ears"
 10 |                 "Drink up eisel"
 11 |                 "Eat a crocodile"
 12 |                 "Eat my knickers"
 13 |                 "Fie upon thee"
 14 |                 "Forsooth say I"
 15 |                 "Get thee gone"
 16 |                 "Get thee hence"
 17 |                 "Grow unsightly warts"
 18 |                 "Hear me now"
 19 |                 "Hear this pox alert"
 20 |                 "I'll see thee hang'd"
 21 |                 "Kiss my codpiece"
 22 |                 "Lead apes in hell"
 23 |                 "Methinks you stinks"
 24 |                 "My finger in thine eye"
 25 |                 "Out of my sight"
 26 |                 "\"Phui\" I say"
 27 |                 "Remove thine ass hence"
 28 |                 "Resign not thy day gig"
 29 |                 "Sit thee on a spit"
 30 |                 "Sorrow on thee"
 31 |                 "Swim with leeches"
 32 |                 "Thou dost intrude"
 33 |                 "Thy mother wears armor"
 34 |                 "Trip on thy sword"
 35 |                 "Tune thy lute"
 36 |                 "Why, how now putz"
 37 |                 "Wipe thy ugly face"))
 38 | 
 39 | (adj-1 -> (or
 40 |            "artless"
 41 |            "bawdy"
 42 |            "beslubbering"
 43 |            "bootless"
 44 |            "cankerous"
 45 |            "churlish"
 46 |            "cockered"
 47 |            "clouted"
 48 |            "craven"
 49 |            "currish"
 50 |            "dankish"
 51 |            "dissembling"
 52 |            "droning"
 53 |            "errant"
 54 |            "fawning"
 55 |            "fobbing"
 56 |            "fool-born"
 57 |            "froward"
 58 |            "frothy"
 59 |            "gleeking"
 60 |            "goatish"
 61 |            "gorbellied"
 62 |            "ill-nurtured"
 63 |            "impertinent"
 64 |            "incestuous"
 65 |            "incurable"
 66 |            "infectious"
 67 |            "jarring"
 68 |            "loggerheaded"
 69 |            "lumpish"
 70 |            "loutish"
 71 |            "mammering"
 72 |            "mangled"
 73 |            "mewling"
 74 |            "paunchy"
 75 |            "pribbling"
 76 |            "puking"
 77 |            "puny"
 78 |            "qualling"
 79 |            "rank"
 80 |            "reeky"
 81 |            "roguish"
 82 |            "rump-fed"
 83 |            "ruttish"
 84 |            "saucy"
 85 |            "spleeny"
 86 |            "spongy"
 87 |            "surly"
 88 |            "tardy-gaited"
 89 |            "tottering"
 90 |            "unmuzzled"
 91 |            "vain"
 92 |            "venomed"
 93 |            "warped"
 94 |            "wayward"
 95 |            "weedy"
 96 |            "whoreson"
 97 |            "wretched"
 98 |            "yeasty"))
 99 | 
100 | (adj-2 -> (or "addlepated"
101 |               "base-court"
102 |               "bat-fowling"
103 |               "beef-witted"
104 |               "beetle-headed"
105 |               "boil-brained"
106 |               "clapper-clawed"
107 |               "clay-brained"
108 |               "codpiece-sniffing"
109 |               "common-kissing"
110 |               "crook-pated"
111 |               "dismal-dreaming"
112 |               "dizzy-eyed"
113 |               "doghearted"
114 |               "dread-bolted"
115 |               "earth-vexing"
116 |               "elf-skinned"
117 |               "fat-kidneyed"
118 |               "fen-sucked"
119 |               "flap-mouthed"
120 |               "fly-bitten"
121 |               "folly-fallen"
122 |               "fool-born"
123 |               "foul-practicing"
124 |               "full-gorged"
125 |               "guts-griping"
126 |               "half-faced"
127 |               "hasty-witted"
128 |               "hedge-born"
129 |               "hell-hated"
130 |               "idle-headed"
131 |               "ill-breeding"
132 |               "ill-nurtured"
133 |               "knotty-pated"
134 |               "mad-brained"
135 |               "milk-livered"
136 |               "motley-minded"
137 |               "onion-eyed"
138 |               "plume-plucked"
139 |               "pottle-deep"
140 |               "pox-marked"
141 |               "reeling-ripe"
142 |               "rough-hewn"
143 |               "rude-growing"
144 |               "rump-fed"
145 |               "shard-borne"
146 |               "sheep-biting"
147 |               "spur-galled"
148 |               "swag-bellied"
149 |               "tardy-gaited"
150 |               "tickle-brained"
151 |               "toad-spotted"
152 |               "unchin-snouted"
153 |               "weather-bitten"))
154 | 
155 | (noun -> (or "apple-john"
156 |              "baggage"
157 |              "barnacle"
158 |              "beast"
159 |              "bladder"
160 |              "boar-pig"
161 |              "bugbear"
162 |              "bum-bailey"
163 |              "canker-blossom"
164 |              "clack-dish"
165 |              "clotpole"
166 |              "coxcomb"
167 |              "codpiece"
168 |              "death-token"
169 |              "dewberry"
170 |              "dotard"
171 |              "flap-dragon"
172 |              "flax-wench"
173 |              "flea"
174 |              "flirt-gill"
175 |              "foot-licker"
176 |              "fustilarian"
177 |              "giglet"
178 |              "gudgeon"
179 |              "haggard"
180 |              "harpy"
181 |              "hedge-pig"
182 |              "horn-beast"
183 |              "hugger-mugger"
184 |              "jolthead"
185 |              "knave"
186 |              "lewdster"
187 |              "lout"
188 |              "maggot-pie"
189 |              "malt-worm"
190 |              "mammet"
191 |              "measle"
192 |              "minnow"
193 |              "miscreant"
194 |              "moldwarp"
195 |              "mumble-news"
196 |              "nit"
197 |              "nut-hook"
198 |              "pigeon-egg"
199 |              "pignut"
200 |              "polecat"
201 |              "pumpion"
202 |              "puttock"
203 |              "ratsbane"
204 |              "rudesby"
205 |              "scut"
206 |              "skainsmate"
207 |              "strumpet"
208 |              "traitor"
209 |              "varlot"
210 |              "vassal"
211 |              "wagtail"
212 |              "water-fly"
213 |              "weasel"
214 |              "whey-face"
215 |              "whore"
216 |              "winter-cricket"))
217 | 


--------------------------------------------------------------------------------
/data/panic-grammar.lisp:
--------------------------------------------------------------------------------
 1 | (sentence -> (or (panic panic)
 2 |                  (panic panic panic)
 3 |                  (panic panic panic)
 4 |                  (panic panic panic panic)))
 5 | (panic -> (or "OMG!!!!!"
 6 |               "Game over, man!"
 7 |               "Oh, God."
 8 |               "It's too late!"
 9 |               "We're all going to die!"
10 |               "Women and bots first!!"
11 |               "Whyyyy?  Ohhh, whyyyy?"
12 |               "Please, save us!!!"
13 |               "Noooooooo!!"
14 |               "Run!! Run for your lives!!"
15 |               "We've gotta get out of here!!!"
16 |               "What can we do??"
17 |               "The horror!  The horror!"
18 |               "I want to live!!!"
19 |               "We're doomed.  Doooooooomed!"
20 |               "I'm too scared to die!!!"))
21 | (panic-arg -> (or (problem "...  " problem "...")
22 |                   ("Ahhhh! " problem "!")
23 |                   ("Help!! It's" problem "!")
24 |                   ("Save yourselves from" problem "!")
25 |                   ("Run away from" problem "!")))


--------------------------------------------------------------------------------
/data/paste.css:
--------------------------------------------------------------------------------
 1 | body {
 2 |     margin: 0 0;
 3 |     background: #fff;
 4 | }
 5 | 
 6 | #header {
 7 |     border-top: none;
 8 |     background: #888;
 9 |     text-color: #eee;
10 |     text-align: right;
11 | }
12 | 
13 | #footer {
14 |     padding: 0.3em;
15 |     border-bottom: none;
16 |     background: #888;
17 |     text-color: #eee;
18 |     clear: both;
19 | }
20 | 
21 | #footer a {
22 |     background: #eee;
23 |     padding: 2px;
24 | }
25 | 
26 | .interface {
27 |     float: left;
28 |     border: 1px solid black;
29 |     margin: 1em;
30 |     padding: 0.5em;
31 | }
32 | 
33 | .interface h2 {
34 |     margin: 0 0;
35 | }
36 | 
37 | .pastebox {
38 |     border: 1px solid black;
39 |     margin: 1em;
40 |     padding: 0.5em;
41 |     width: 90%;
42 | }
43 | .pastebody {
44 |     font-family: monospace;
45 |     padding: 0.2em;
46 |     background: #ddd;
47 | }
48 | 
49 | .alert {
50 |     color: #f00;
51 | }


--------------------------------------------------------------------------------
/data/robots.lisp:
--------------------------------------------------------------------------------
  1 | (thing-adj
  2 |  "advanced"
  3 |  "artificial"
  4 |  "atomic"
  5 |  "beta"
  6 |  "biomechanical"
  7 |  "bionic"
  8 |  "binary"
  9 |  "cybernetic"
 10 |  "clockwork"
 11 |  "crystalline"
 12 |  "digital"
 13 |  "dual"
 14 |  "electronic"
 15 |  "forbidden"
 16 |  "functional"
 17 |  "global"
 18 |  "hydraulic"
 19 |  "intelligent"
 20 |  "inhuman"
 21 |  "journeying"
 22 |  "kinetic"
 23 |  "knowledgable"
 24 |  "lifelike"
 25 |  "mechanical"
 26 |  "networked"
 27 |  "obedient"
 28 |  "positronic"
 29 |  "quantum"
 30 |  "robotic"
 31 |  "synthetic"
 32 |  "transforming"
 33 |  "upgraded"
 34 |  "vigilant"
 35 |  "versatile"
 36 |  "wireless"
 37 |  "xperimental"
 38 |  "xtraterrestrial"
 39 |  "ytterbium"
 40 |  "zeta")
 41 | 
 42 | (activity-adj
 43 |  "accurate"
 44 |  "basic"
 45 |  "ceaseless"
 46 |  "dangerous"
 47 |  "efficient"
 48 |  "forbidden"
 49 |  "galactic"
 50 |  "hazardous"
 51 |  "immediate"
 52 |  "journeying"
 53 |  "justified"
 54 |  "jeopardous"
 55 |  "kamikaze"
 56 |  "lethal"
 57 |  "logical"
 58 |  "mechanical"
 59 |  "mandatory"
 60 |  "infinite"
 61 |  "intensive"
 62 |  "interstellar"
 63 |  "nocturnal"
 64 |  "online"
 65 |  "potential"
 66 |  "rational"
 67 |  "scientific"
 68 |  "solar"
 69 |  "space"
 70 |  "terran"
 71 |  "ultimate"
 72 |  "worldwide"
 73 |  "widespread"
 74 |  "xperimental"
 75 |  "xpert"
 76 |  "yearly"
 77 |  "yucky"
 78 |  "zealous")
 79 | 
 80 | (activity
 81 |  "analysis"
 82 |  "assassination"
 83 |  "acquisition"
 84 |  "battle"
 85 |  "bioscience"
 86 |  "burning"
 87 |  "calculation"
 88 |  "capture"
 89 |  "chaos"
 90 |  "destruction"
 91 |  "exploration"
 92 |  "fighting"
 93 |  "fun"
 94 |  "geophysics"
 95 |  "gratification"
 96 |  "gunfighting"
 97 |  "harm"
 98 |  "infiltration"
 99 |  "investigation"
100 |  "incineration"
101 |  "judo"
102 |  "jobs"
103 |  "jealousy"
104 |  "killing"
105 |  "kindness"
106 |  "learning"
107 |  "mathematics"
108 |  "nullification"
109 |  "obliteration"
110 |  "observation"
111 |  "peacekeeping"
112 |  "patrolling"
113 |  "questioning"
114 |  "quantification"
115 |  "repair"
116 |  "sabotage"
117 |  "troubleshooting"
118 |  "utility"
119 |  "violence"
120 |  "vengeance"
121 |  "warfare"
122 |  "wrecking"
123 |  "wayfaring"
124 |  "xenocide"
125 |  "xecution"
126 |  "yelling"
127 |  "yardwork"
128 |  "zoology"
129 |  "zymurgy"
130 | )
131 | 
132 | 
133 | (for
134 |  "assembled for"
135 |  "built for"
136 |  "calibrated for"
137 |  "designed for"
138 |  "engineered for"
139 |  "fabricated for"
140 |  "generated for"
141 |  "hardwired for"
142 |  "intended for"
143 |  "justified for"
144 |  "keen on"
145 |  "limited to"
146 |  "manufactured for"
147 |  "normally for"
148 |  "optimized for"
149 |  "programmed for"
150 |  "qualified for"
151 |  "responsible for"
152 |  "skilled in"
153 |  "trained for"
154 |  "used for"
155 |  "viable for"
156 |  "wanting"
157 |  "xperienced in"
158 |  "yearning for"
159 |  "zoned for")
160 | 
161 | (thing
162 |  "android"
163 |  "being"
164 |  "construct"
165 |  "device"
166 |  "entity"
167 |  "facsimile"
168 |  "guardian"
169 |  "humanoid"
170 |  "individual"
171 |  "judge"
172 |  "juggernaut"
173 |  "knight"
174 |  "lifeform"
175 |  "machine"
176 |  "neohuman"
177 |  "organism"
178 |  "person"
179 |  "quadruplet"
180 |  "replicant"
181 |  "soldier"
182 |  "technician"
183 |  "unit"
184 |  "varient"
185 |  "worker"
186 |  "xenomorph"
187 |  "youth"
188 |  "zombie")
189 | 
190 | ;; 1
191 | (phrase thing)
192 | 
193 | ;; 2
194 | (phrase thing-adj thing)
195 | 
196 | ;; 3
197 | (phrase activity-adj activity thing)
198 | (phrase activity "and" activity thing)
199 | 
200 | ;; 4
201 | (phrase activity "and" activity-adj activity thing)
202 | (phrase activity-adj activity-adj activity thing)
203 | (phrase activity-adj activity "and" activity thing)
204 | (phrase thing-adj thing for activity)
205 | (phrase thing for activity "and" activity)
206 | (phrase thing-adj activity-adj activity thing)
207 | (phrase thing for activity-adj activity)
208 | 
209 | ;; 5
210 | (phrase thing-adj thing-adj thing for activity)
211 | (phrase thing-adj thing for activity "and" activity)
212 | (phrase thing-adj thing for activity-adj activity)
213 | (phrase thing for activity "and" activity-adj activity)
214 | 
215 | ;; 6
216 | (phrase activity-adj activity-adj activity "and" activity-adj activity thing)
217 | (phrase thing for activity "," activity-adj activity "and" activity-adj activity)
218 | (phrase thing-adj thing for activity "and" activity-adj activity)
219 | (phrase thing-adj thing-adj activity "and" activity-adj activity thing)
220 | (phrase thing-adj thing-adj thing for activity "and" activity-adj activity)
221 | (phrase thing-adj thing-adj thing for activity-adj activity "and" activity-adj activity)
222 | 
223 | ;; 7
224 | (phrase thing-adj thing-adj thing for activity-adj activity "and" activity)
225 | (phrase thing-adj thing-adj thing for activity "and" activity-adj activity)
226 | 
227 | ;; 8
228 | (phrase thing-adj thing-adj thing for activity-adj activity "and" activity-adj activity)
229 | 
230 | ;; 9
231 | (phrase thing-adj thing-adj thing for activity-adj activity "and" thing-adj activity-adj activity)
232 | 
233 | ;; 10
234 | (phrase thing-adj thing-adj thing for activity-adj activity "," activity-adj activity "and" activity-adj activity)
235 | 
236 | ;; 11
237 | (phrase thing for activity "and" activity-adj activity "/" thing-adj thing for activity "and" activity-adj activity)
238 | (phrase thing-adj thing for activity "and" activity "/" thing-adj thing for activity-adj activity "and" activity)
239 | (phrase thing-adj thing for activity "and" activity "/" thing-adj thing for activity "and" activity-adj activity)
240 | 


--------------------------------------------------------------------------------
/data/slogan-grammar.lisp:
--------------------------------------------------------------------------------
 1 | (sentence -> (or ("You get better inside" thing ".")
 2 |                  ("Stay cool with" thing ".")
 3 |                  ("For the love of" thing ".")
 4 |                  (thing "for a professional image.")
 5 |                  (thing ", stay in touch.")
 6 |                  (thing "'s got it all!")
 7 |                  ("I quit smoking with" thing ".")
 8 |                  ("Everyone loves" thing ".")
 9 |                  ("High life with" thing ".")
10 |                  ("I believe in" thing ".")
11 |                  (thing "is a never ending story.")
12 |                  ("Don't get in the way of" thing ".")
13 |                  ("The goddess made" thing ".")
14 |                  (thing "is what the world was waiting for.")
15 |                  (thing "after a long day.")
16 |                  ("One goal, one passion -" thing ".")
17 |                  ("Enjoy" thing ".")
18 |                  (thing "- simplified!")
19 |                  ("Everything is simple with" thing ".")
20 |                  (thing "for you!")
21 |                  ("I wish I had a" thing ".")
22 |                  ("Think different, think" thing ".")
23 |                  ("The president buys" thing ".")
24 |                  ("Make the world a better place with" thing ".")
25 |                  (thing "evolution.")
26 |                  ("Feel it -" thing "!")
27 |                  (thing "... whatever you want.")
28 |                  ("The Power of" thing ".")
29 |                  (thing "innovate your world")
30 |                  ("My" thing "beats everything.")
31 |                  ("Let's" thing "!")
32 |                  ("The" thing "spirit.")
33 |                  ("I trust" thing ".")
34 |                  (thing ", one for all.")
35 |                  ("Be young, have fun, taste" thing)
36 |                  (thing ", created by nature.")
37 |                  (thing "for the masses.")
38 |                  (thing ", good.")
39 |                  (thing "wanted.")
40 |                  ("No" thing ", no kiss.")
41 |                  ("The ideal" thing)
42 |                  (thing ", pure lust.")
43 |                  ("I lost weight with" thing)
44 |                  ("Connect with" thing)
45 |                  ("The" thing "community.")
46 |                  ("Way to go," thing "!")
47 |                  (thing "Dreamteam.")
48 |                  ("Go far with" thing)
49 |                  ("Live" thing)
50 |                  ("Don't worry," thing "takes care.")
51 |                  ("It's my" thing "!")
52 |                  (thing "for your kids!")
53 |                  ("Do you know" thing "?")
54 |                  ("Go farther with" thing)
55 |                  (thing "- your game.")
56 |                  (thing "for a professional image.")))
57 | 
58 | 


--------------------------------------------------------------------------------
/data/solve-grammar.lisp:
--------------------------------------------------------------------------------
  1 | (problem -> (or "global warming"
  2 |                 "system abends"
  3 |                 "disk head crashes"
  4 |                 "shark attacks"
  5 |                 "hurricanes"
  6 |                 "boil water alerts"
  7 |                 "the Riders of Nazgul"
  8 |                 "frogs falling from the sky"
  9 |                 "artillery bombardment"
 10 |                 "build failures"
 11 |                 "performance regressions"
 12 |                 "failed deployments"
 13 |                 "Oracle Service Requests"
 14 |                 "severe packet loss"
 15 |                 "departmental miscommunications"))
 16 | (sentence -> diagnosis fix)
 17 | (bad-adjective -> (or "offline"
 18 |                       "behaving abnormally"
 19 |                       "giving strange readings"
 20 |                       "unstable"
 21 |                       "failing"
 22 |                       "disrupted"
 23 |                       "collapsing"
 24 |                       "not responding"))
 25 | (bad-thing -> (or
 26 |                "a fluctuation"
 27 |                "an error"
 28 |                "a failure"
 29 |                "a power surge"
 30 |                "an instability"
 31 |                "a disruption"
 32 |                "an anomaly"
 33 |                "a flaw"
 34 |                "an interference"
 35 |                "a malfunction"))
 36 | (bad-things -> (or
 37 |                "fluctuations"
 38 |                "power surges"
 39 |                "errors"
 40 |                "flaws"
 41 |                "stress fractures"
 42 |                "variances"
 43 |                "anomalies"
 44 |                "disturbances"
 45 |                "flaws"
 46 |                "logical inconsistencies"
 47 |                "failures"
 48 |                "malfunctions"))
 49 | (problem-sources -> bad-things "in" qualified-noun-phrase)
 50 | (are-causing -> (or "are causing"
 51 |                    "could cause"
 52 |                    "may be the source of"))
 53 | (is-caused-by -> (or "is caused by"
 54 |                      "is being caused by"
 55 |                      "could be caused by"
 56 |                      "might be caused by"
 57 |                      "could originate in"))
 58 | (diagnosis ->
 59 |            (or
 60 |             ("we have detected that" problem-sources are-causing problem)
 61 |             (tech "sensors indicate" problem-sources are-causing problem)
 62 |             ("our" scanner "indicates that" problem-sources are-causing problem)
 63 |             (problem is-caused-by bad-things "in" qualified-noun-phrase)
 64 |             (bad-things "in" qualified-noun-phrase "are causing" problem)
 65 |             (bad-thing "in" qualified-noun-phrase "is causing" problem)
 66 |             ("we have" problem "because" subject-to-be bad-adjective))
 67 |            (or "." "!"))
 68 | (fix -> directive solution ".")
 69 | (fix -> directive solution "by" method ".")
 70 | (fix -> method "should" solution ".")
 71 | (directive -> "we" (or "need to"
 72 |                        "must"
 73 |                        "can"
 74 |                        "will"
 75 |                        "could"
 76 |                        "might be able to"
 77 |                        "should probably"))
 78 | (directive -> "we'll have to")
 79 | (solution -> (or
 80 |               ("align the" part "with" qualified-noun-phrase)
 81 |               ("calibrate the" part "against" qualified-noun-phrase)
 82 |               ("overload the" part "with" qualified-noun-phrase)
 83 |               ("realign the" part "with" qualified-noun-phrase)
 84 |               ("adjust the" part "with" qualified-noun-phrase)
 85 |               ("force the" part "to" solution)
 86 |               ("equalize the" part "and the" part)
 87 |               ("destabilize the" part "with" qualified-noun-phrase)
 88 |               ("neutralize the" part "with" qualified-noun-phrase)
 89 |               ("trim the" part "with" qualified-noun-phrase)
 90 |               ("regulate the" part "with" qualified-noun-phrase)
 91 |               ("stabilize the" part "with" qualified-noun-phrase)
 92 |               ("reverse the" part "with" qualified-noun-phrase)
 93 |               ("emit" emission "from" qualified-noun-phrase)))
 94 | (method -> (or
 95 |             ("aligning" qualified-noun-phrase)
 96 |             ("calibrating" qualified-noun-phrase)
 97 |             ("overloading" qualified-noun-phrase)
 98 |             ("realigning" qualified-noun-phrase)
 99 |             ("adjusting" qualified-noun-phrase)
100 |             ("forcing" qualified-noun-phrase)
101 |             ("equalizing" qualified-noun-phrase)
102 |             ("destabilizing" qualified-noun-phrase)
103 |             ("neutralizing" qualified-noun-phrase)
104 |             ("trimming" qualified-noun-phrase)
105 |             ("regulating" qualified-noun-phrase)
106 |             ("stabilizing" qualified-noun-phrase)
107 |             ("reversing" qualified-noun-phrase)
108 |             ("firing" projectile "at" qualified-noun-phrase)
109 |             ("emitting" emission "from" qualified-noun-phrase)))
110 | 
111 | (part -> tech-kind (or n pn))
112 | (subject-to-be -> (or
113 |                    ("a" n "is")
114 |                    ("the" n "is")
115 |                    ("the" (? tech-kind) pn "are")
116 |                    ("some" (? tech-kind) pn "are")
117 |                    ("our extra" (? tech-kind) pn "are")))
118 | (qualified-noun-phrase -> (or
119 |                            ("a" n)
120 |                            ("the" n)
121 |                            ("the" (? tech-kind) pn)
122 |                            ("some of our" (? tech-kind) pn)))
123 | (class-designation -> "class" (or "A" "B" "D"))
124 | (level-designation -> "level" (or "5" "9"))
125 | (tech-kind -> (or "primary"
126 |                   "secondary"
127 |                   "main"
128 |                   "forward"
129 |                   "aft"
130 |                   "front"
131 |                   "rear"
132 |                   "gravitational"
133 |                   "fusion"
134 |                   "positronic"
135 |                   "dynamic"
136 |                   "baryonic"
137 |                   "static"
138 |                   "ionic"
139 |                   "massive"
140 |                   "unstable"
141 |                   class-designation
142 |                   level-designation))
143 | (material -> (or
144 |               "dilithum"
145 |               "aluminium"
146 |               "adamantium"
147 |               "beryllium"
148 |               "carbon"
149 |               "lead"
150 |               "thallium"
151 |               "gold"))
152 | (subatomic -> (or "tachyon"
153 |                   "neutrino"
154 |                   "proton"
155 |                   "photon"
156 |                   "antilepton"
157 |                   "positron"
158 |                   "matter"
159 |                   "electron"
160 |                   "baryonic"
161 |                   "gamma"
162 |                   "magnetic"
163 |                   "subspace"))
164 | (tech -> (or "subspace"
165 |              "warp"
166 |              "antimatter"
167 |              "impulse"
168 |              "quantum"
169 |              "nano-"
170 |              "polarity"
171 |              "metagenic"
172 |              "ionic"))
173 | (system -> (or "weapons"
174 |                "navigation"
175 |                "life-support"
176 |                "guidance"
177 |                "docking"
178 |                "warp"
179 |                (tech-kind "control"))
180 |         (or "computer"
181 |             "system"))
182 | (scanner -> (? (or "long-range"
183 |                    "short-range"))
184 |          subatomic
185 |          (or "scanner"
186 |              "locator"
187 |              "detector"
188 |              "sensor"))
189 | (n -> "space-time continuum")
190 | (n -> scanner)
191 | (n -> (? tech-kind)
192 |    (or
193 |     "battle bridge"
194 |     "holodeck"
195 |     "pattern buffer"
196 |     "recognition protocols"
197 |     "replicator"
198 |     "tractor beam"
199 |     system
200 |     (subatomic "emitter")
201 |     (subatomic "field")
202 |     (subatomic "flow")
203 |     (subatomic "flux")
204 |     (subatomic "polarity")
205 |     (subatomic "stream")
206 |     (subatomic "cannons")
207 |     (tech "array")
208 |     (tech "bubble")
209 |     (tech "coil")
210 |     (tech "compensator")
211 |     (tech "core")
212 |     (tech "deflector")
213 |     (tech "emitter")
214 |     (tech "integrator")
215 |     (tech "locator")
216 |     (tech "pad")
217 |     (tech "pattern")
218 |     (tech "polarity")
219 |     (tech "pump")
220 |     (tech "reactor")
221 |     (tech "scanner")
222 |     (tech "singularity")
223 |     (tech "resonator")
224 |     (tech "transciever")))
225 | (pn -> (or
226 |         "algorithms"
227 |         "circuits"
228 |         "sail towers"
229 |         "disruptors"
230 |         (tech "inducers")
231 |         (tech "sensors")
232 |         (tech "chambers")
233 |         (tech "nullifiers")
234 |         (tech "translators")
235 |         (tech "transponders")
236 |         (tech "conduits")
237 |         (subatomic "waves")
238 |         (subatomic "pulses")
239 |         (material "crystals")))
240 | 
241 | (projectile -> (a (? tech-kind)
242 |                   (or
243 |                    (subatomic "pulse")
244 |                    (subatomic "field")
245 |                    (subatomic "wave"))))
246 | 
247 | (emission -> (? tech-kind)
248 |           (or
249 |            (material "particles")
250 |            (subatomic "waves")
251 |            (subatomic "pulses")))
252 | 
253 | (prep-phrase -> (or
254 |                  ("around the" noun-phrase)
255 |                  ("with a" noun-phrase)))
256 | 


--------------------------------------------------------------------------------
/orcabot.asd:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (defpackage #:orcabot-system (:use #:asdf #:cl))
16 | (in-package #:orcabot-system)
17 | 
18 | #.(declaim (optimize (debug 3) (speed 0) (safety 3) (space 2)))
19 | 
20 | (defsystem orcabot
21 |   :name "Orcabot"
22 |   :version "2.0.0"
23 |   :author "Daniel Lowe <dlowe@google.com>"
24 |   :description "Orcabot IRC bot"
25 |   :depends-on (alexandria chronicity cl+ssl cl-csv cl-json cl-irc
26 |                           cl-log cl-ppcre cxml drakma esrap
27 |                           local-time iolib parse-number plump)
28 | 
29 |   :components
30 |   ((:module :src :components
31 |             ((:file "defpackage")
32 |              (:file "utils" :depends-on ("defpackage"))
33 |              (:file "strings" :depends-on ("defpackage"))
34 |              (:file "module" :depends-on ("utils" "strings"))
35 |              (:file "abbrev" :depends-on ("module"))
36 |              (:file "admin" :depends-on ("module"))
37 |              (:file "automsg" :depends-on ("module"))
38 |              (:file "basic" :depends-on ("module"))
39 |              (:file "bitcoin" :depends-on ("module"))
40 |              (:file "bugzilla" :depends-on ("module"))
41 |              (:file "calc" :depends-on ("module"))
42 |              (:file "chant" :depends-on ("module"))
43 |              (:file "credit" :depends-on ("module"))
44 |              (:file "env" :depends-on ("module"))
45 |              (:file "db" :depends-on ("module"))
46 |              (:file "grammar" :depends-on ("module"))
47 |              (:file "groups" :depends-on ("module"))
48 |              (:file "karma" :depends-on ("module"))
49 |              (:file "lastseen" :depends-on ("module"))
50 |              (:file "liarsdice" :depends-on ("module"))
51 |              (:file "logging" :depends-on ("module"))
52 |              (:file "lojban" :depends-on ("module"))
53 |              (:file "memo" :depends-on ("module"))
54 |              (:file "pick" :depends-on ("module"))
55 |              (:file "parrot" :depends-on ("module"))
56 |              (:file "poetry" :depends-on ("module"))
57 |              (:file "quote" :depends-on ("module"))
58 |              (:file "reminder" :depends-on ("module"))
59 |              (:file "respond" :depends-on ("module"))
60 |              (:file "rt" :depends-on ("module"))
61 |              (:file "stats" :depends-on ("module"))
62 |              (:file "stock" :depends-on ("module"))
63 |              (:file "subversion" :depends-on ("module"))
64 |              (:file "trivia" :depends-on ("module"))
65 |              (:file "typist" :depends-on ("module"))
66 |              (:file "web" :depends-on ("module"))
67 |              (:file "weather" :depends-on ("module"))
68 |              (:file "werewolf" :depends-on ("module"))
69 |              (:file "patches" :depends-on ("utils"))
70 |              (:file "main" :depends-on ("patches" "utils" "module"))))))
71 | 


--------------------------------------------------------------------------------
/src/abbrev.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:orcabot)
 2 | 
 3 | ;; The abbreviation db has two parts - WORDS and PHRASES
 4 | ;;   WORDS are a list of (kind . word) pairs.
 5 | ;;   PHRASES are a list of phrases, and a phrase is a list of word kinds.
 6 | 
 7 | (defclass abbrev-db ()
 8 |   (words phrases))
 9 | 
10 | (defun load-abbrev-db (path)
11 |   (let ((*package* (find-package '#:orcabot)))
12 |     (with-open-file (inf path :direction :input)
13 |       (let ((result (make-instance 'abbrev-db )))
14 |         (with-slots (words phrases) result
15 |           (setf words nil
16 |                 phrases nil)
17 |           (loop
18 |              for term = (read inf nil)
19 |              while term
20 |              do
21 |                (case (car term)
22 |                  (phrase
23 |                   (push (cdr term) phrases))
24 |                  (t
25 |                   (dolist (word (cdr term))
26 |                     (push (cons (car term) word)
27 |                           words)))))
28 |           result)))))
29 | 
30 | (defun count-syms (list)
31 |   (count-if #'symbolp list))
32 | 
33 | (defun potential-phrases (db wanted-len)
34 |   (with-slots (phrases) db
35 |     (alexandria:shuffle (remove wanted-len phrases :key #'count-syms :test-not #'=))))
36 | 
37 | (defun select-word (db kind letter used)
38 |   (let ((candidates (with-slots (words) db
39 |                       (loop
40 |                          for word in words
41 |                          when (and (eql (car word) kind)
42 |                                    (char-equal (char (cdr word) 0) letter)
43 |                                    (not (gethash (cdr word) used)))
44 |                          collect (cdr word)))))
45 |     (cond
46 |       (candidates
47 |        (alexandria:random-elt candidates))
48 |       (t
49 |        (log:log-message :error "No unused word for letter '~a' and type ~a~%" letter kind)
50 |        nil))))
51 | 
52 | (defun render-phrase-template (db template abbrev)
53 |   (let ((result nil)
54 |         (used (make-hash-table :test 'equal)))
55 |     (loop
56 |        with letter-idx = 0
57 |        for word-kind in template
58 |        for letter = (char abbrev letter-idx)
59 |        do
60 |          (etypecase word-kind
61 |            (string
62 |             (push word-kind result))
63 |            (symbol
64 |             (let ((word (select-word db word-kind letter used)))
65 |               (unless word
66 |                 (return nil))
67 |               (push (string-capitalize word :end 1) result)
68 |               (setf (gethash word used) t)
69 |               (incf letter-idx))))
70 |        finally (return (nreverse result)))))
71 | 
72 | (defun expand-abbrev (db abbrev)
73 |   (loop
74 |      for phrase-template in (potential-phrases db (length abbrev))
75 |      as phrase = (render-phrase-template db phrase-template abbrev)
76 |      until phrase
77 |      finally (return (and phrase
78 |                           (join-to-string " " phrase)))))
79 | 
80 | (defmodule abbrev abbrev-module ("robot")
81 |   (robot-db :accessor robot-db-of))
82 | 
83 | (defmethod initialize-module ((module abbrev-module) config)
84 |   (setf (robot-db-of module) (load-abbrev-db (static-path "robots.lisp"))))
85 | 
86 | (defmethod handle-command ((module abbrev-module)
87 |                            (cmd (eql 'robot))
88 |                            message args)
89 |   "robot <word> - generate robot name from word (max 11 chars)"
90 |   (cond
91 |     ((null args)
92 |      (reply-to message "Usage: .robot <word>"))
93 |     ((> (length (first args)) 11)
94 |      (reply-to message "The word must be less than 11 characters."))
95 |     (t
96 |      (reply-to message "~a: ~a~%"
97 |                (first args)
98 |                (expand-abbrev (robot-db-of module) (first args))))))
99 | 


--------------------------------------------------------------------------------
/src/admin.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule admin admin-module ("echo" "action" "sayto"
 18 |                                       "ignore" "unignore"
 19 |                                       "join" "part" "quit" "reboot" "nick"
 20 |                                       "mode"
 21 |                                       "eval"))
 22 | 
 23 | (defmethod handle-command ((self admin-module) (cmd (eql 'quit)) message args)
 24 |   "quit - make orcabot leave"
 25 |   (signal 'orcabot-exiting))
 26 | 
 27 | (defmethod handle-command ((self admin-module) (cmd (eql 'reboot)) message args)
 28 |   "reboot - restart orcabot"
 29 |   (signal 'orcabot-rebooting))
 30 | 
 31 | (defmethod handle-command ((self admin-module) (cmd (eql 'echo)) message args)
 32 |   "echo <stuff> - make orcabot say something"
 33 |   (when args
 34 |     (reply-to message "~{~a~^ ~}" args)))
 35 | 
 36 | (defmethod handle-command ((self admin-module) (cmd (eql 'action)) message args)
 37 |   "action <target> <something> - make orcabot do something to a target"
 38 |   (when (cdr args)
 39 |     (irc::action (connection message)
 40 |                  (first args)
 41 |                  (format nil "~{~a~^ ~}" (rest args)))))
 42 | 
 43 | (defmethod handle-command ((self admin-module) (cmd (eql 'sayto)) message args)
 44 |   "sayto <target> <something> - make orcabot say something to a target"
 45 |   (irc::privmsg (connection message)
 46 |                (first args)
 47 |                (format nil "~{~a~^ ~}" (rest args))))
 48 | 
 49 | (defmethod handle-command ((self admin-module) (cmd (eql 'ignore)) message args)
 50 |   "ignore <nick> - remove user from orcabot's awareness"
 51 |   (dolist (nick args)
 52 |     (pushnew (list 'deny :user (normalize-nick nick)) *access-control* :test 'equal))
 53 |   (if (cdr args)
 54 |       (reply-to message "Ok, I'm ignoring them.")
 55 |       (reply-to message "Ok, I'm ignoring ~a." (car args))))
 56 | 
 57 | (defmethod handle-command ((self admin-module) (cmd (eql 'unignore)) message args)
 58 |   "unignore <nick> - restore user to orcabot's awareness"
 59 |   (setf *access-control*
 60 |         (delete-if (lambda (nick)
 61 |                      (member (list 'deny :user (normalize-nick nick)) args :test 'equal))
 62 |                    *access-control*))
 63 |   (if (cdr args)
 64 |       (reply-to message "Ok, I'm no longer ignoring them.")
 65 |       (reply-to message "Ok, I'm no longer ignoring ~a." (car args))))
 66 | 
 67 | (defmethod handle-command ((self admin-module) (cmd (eql 'join)) message args)
 68 |   "join <channel> - have orcabot join a channel"
 69 |   (dolist (channel args)
 70 |     (irc:join (connection message) channel)))
 71 | 
 72 | (defmethod handle-command ((self admin-module) (cmd (eql 'part)) message args)
 73 |   "part <channel> - make orcabot leave a channel"
 74 |   (dolist (channel args)
 75 |     (irc:part (connection message) channel)))
 76 | 
 77 | (defmethod handle-command ((self admin-module) (cmd (eql 'mode)) message args)
 78 |   "mode <nick> <mode> - have orcabot change mode of a user or channel"
 79 |   (irc:mode (connection message) (first args) (second args))
 80 |   (reply-to message "Ok, mode changed."))
 81 | 
 82 | (defmethod handle-command ((self admin-module) (cmd (eql 'nick)) message args)
 83 |   "nick <channel> - make orcabot change its nick"
 84 |   (irc:nick (connection message) (first args)))
 85 | 
 86 | (defmethod handle-command ((self admin-module) (cmd (eql 'eval)) message args)
 87 |   "eval <expr> - evaluate an arbitrary lisp expression"
 88 |   (handler-case
 89 |       (let* ((*standard-output* (make-string-output-stream))
 90 |              (*package* (find-package "ORCABOT"))
 91 |              (expr (format nil "~{~a~^ ~}" args))
 92 |              (results (multiple-value-list (eval (read-from-string expr)))))
 93 |         (format *standard-output* "~{~s~%~}" results)
 94 |         (with-input-from-string (str (get-output-stream-string *standard-output*))
 95 |           (loop for line = (read-line str nil)
 96 |                while line
 97 |              do (reply-to message "~a" line))))
 98 |     (error (err)
 99 |         (reply-to message "ERROR: ~a~%" err))))
100 | 
101 | 


--------------------------------------------------------------------------------
/src/automsg.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2019 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule automsg automsg-module ()
18 |   (messages))
19 | 
20 | (defmethod initialize-module ((module automsg-module) config)
21 |   (with-slots (messages) module
22 |     (setf messages (rest (assoc 'automsg config)))))
23 | 
24 | (defmethod examine-message ((module automsg-module)
25 |                             (message irc:irc-join-message))
26 |   (with-slots (messages) module
27 |     (let ((automsg (cdr (assoc (first (arguments message)) messages :test 'equal))))
28 |       (when automsg
29 |         (irc:privmsg (connection message) (first (arguments message)) automsg)))))
30 | 


--------------------------------------------------------------------------------
/src/basic.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule basic basic-module ("man"))
18 | 
19 | (defmethod handle-command ((module basic-module) (cmd (eql 'man)) message args)
20 |   "man <term> - look up term in unix manual"
21 |   (let ((output (with-output-to-string (str)
22 |                   (sb-ext:run-program "/usr/bin/whatis"
23 |                                       (list (first args))
24 |                                       :input nil :output str))))
25 |     (if (search "nothing appropriate" output)
26 |         (reply-to message "Nothing found for ~a" (first args))
27 |         (ppcre:register-groups-bind (section desc)
28 |             ((ppcre:create-scanner "^\\S+\\s+\\((\\d+)posix\\)\\s+- (.*)"
29 |                                    :multi-line-mode t) output)
30 |           (reply-to message "~a - ~a [http://linuxmanpages.com/man~a/~a.~a.php]"
31 |                     (first args) desc section (first args) section)))))
32 | 


--------------------------------------------------------------------------------
/src/bitcoin.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:orcabot)
 2 | 
 3 | (define-condition bitcoin-error ()
 4 |   ((message :accessor message-of :initarg :message)))
 5 | 
 6 | (defmethod print-object ((object bitcoin-error) stream)
 7 |   (print-unreadable-object (object stream)
 8 |     (format stream "~a" (message-of object))))
 9 | 
10 | (defvar *bitcoin-request-cache* nil)
11 | (defvar *bitcoin-request-expiration* nil)
12 | 
13 | (defun bitcoin-request (url)
14 |   (let ((now (get-universal-time)))
15 |     (cond
16 |       ((and *bitcoin-request-cache*
17 |             (< now *bitcoin-request-expiration*))
18 |        *bitcoin-request-cache*)
19 |       (t
20 |        (setf *bitcoin-request-expiration* (+ now 60))
21 |        (pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
22 |        (handler-case
23 |            (multiple-value-bind (response status)
24 |                (drakma:http-request url)
25 |              (cond
26 |                ((/= status 200)
27 |                 (error 'bitcoin-error :message "Couldn't connect to server"))
28 |                (t
29 |                 (let* ((json:*json-identifier-name-to-lisp* #'json:simplified-camel-case-to-lisp)
30 |                        (result (json:decode-json-from-string response)))
31 |                   (setf *bitcoin-request-cache* result)))))
32 |          (usocket:timeout-error ()
33 |            (error 'bitcoin-error :message "Timed out connecting to server")))))))
34 | 
35 | (defun retrieve-bitstamp-info ()
36 |   (let* ((info (bitcoin-request "http://bitstamp.net/api/ticker/")))
37 |     (values
38 |      (cdr (assoc :last info))
39 |      (cdr (assoc :high info))
40 |      (cdr (assoc :low info))
41 |      (cdr (assoc :vwap info))
42 |      (cdr (assoc :volume info))
43 |      (cdr (assoc :bid info))
44 |      (cdr (assoc :ask info)))))
45 | 
46 | (defun retrieve-bitfinex-info ()
47 |   (let ((info (bitcoin-request "https://api.bitfinex.com/v1/pubticker/btcusd")))
48 |     (values
49 |      (cdr (assoc :last_price info))
50 |      (cdr (assoc :high info))
51 |      (cdr (assoc :low info))
52 |      (cdr (assoc :mid info))
53 |      (cdr (assoc :volume info))
54 |      (cdr (assoc :bid info))
55 |      (cdr (assoc :ask info)))))
56 | 
57 | (defmodule bitcoin bitcoin-module ("btc"))
58 | 
59 | (defmethod handle-command ((module bitcoin-module)
60 |                            (cmd (eql 'btc))
61 |                            message args)
62 |   ".btc - show bitcoin trading information"
63 |   (handler-case
64 |       (multiple-value-bind (last buy sell avg vol bid ask)
65 |           (retrieve-bitstamp-info)
66 |         (reply-to message "last:~a high:~a low:~a avg:~a volume:~a bid:~a ask:~a"
67 |                   last buy sell avg vol bid ask))
68 |     (bitcoin-error (e)
69 |       (reply-to message "Error: ~a" (message-of e)))))
70 | 


--------------------------------------------------------------------------------
/src/bugzilla.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule bugzilla bugzilla-module ("bug")
 18 |   (cookies :reader cookies-of :initform (make-instance 'drakma:cookie-jar))
 19 |   (base-url :accessor base-url-of))
 20 | 
 21 | (defun bugzilla-login (module)
 22 |   (let ((creds (authentication-credentials (puri:uri-host (puri:uri (base-url-of module))))))
 23 |     (drakma:http-request (format nil "~a/index.cgi" (base-url-of module))
 24 |                          :method :post
 25 |                          :parameters `(("Bugzilla_login" . ,(getf creds :login))
 26 |                                        ("Bugzilla_password" . ,(getf creds :password)))
 27 |                          :cookie-jar (cookies-of module))))
 28 | 
 29 | (defun retrieve-bug-info (module bug)
 30 |   (unless (drakma:cookie-jar-cookies (cookies-of module))
 31 |     (bugzilla-login module))
 32 |   (multiple-value-bind (response status headers)
 33 |       (drakma:http-request
 34 |        (format nil "~a/show_bug.cgi" (base-url-of module))
 35 |        :parameters `(("ctype" . "xml")
 36 |                      ("id" . ,bug))
 37 |        :cookie-jar (cookies-of module))
 38 |     (cond
 39 |       ((/= status 200)
 40 |        nil)
 41 |       ((and (string= (cdr (assoc :content-type headers))
 42 |                      "text/html; charset=UTF-8")
 43 |             (cl-ppcre:scan "need a legitimate login and password" response))
 44 |        (bugzilla-login module)
 45 |        (retrieve-bug-info module bug))
 46 |       (t
 47 |        (flet ((resolver (pubid sysid)
 48 |                 (declare (ignore pubid))
 49 |                 (when (puri:uri= sysid
 50 |                                  (puri:parse-uri
 51 |                                   (format nil "~a/bugzilla.dtd" (base-url-of module))))
 52 |                   (open (static-path "bugzilla.dtd") :element-type '(unsigned-byte 8)))))
 53 |          (let* ((doc (cxml:parse response
 54 |                                  (cxml-dom:make-dom-builder)
 55 |                                  :entity-resolver #'resolver))
 56 |                 (bug (elt (dom:get-elements-by-tag-name doc "bug") 0))
 57 |                 (err (dom:get-attribute-node bug "error")))
 58 |            (unless err
 59 |              (values
 60 |               (dom:node-value
 61 |                (dom:first-child
 62 |                 (elt (dom:get-elements-by-tag-name doc "short_desc") 0)))
 63 |               (dom:node-value
 64 |                (dom:first-child
 65 |                 (elt (dom:get-elements-by-tag-name doc "assigned_to") 0)))
 66 |               (dom:node-value
 67 |                (dom:first-child
 68 |                 (elt (dom:get-elements-by-tag-name doc "bug_status") 0)))))))))))
 69 | 
 70 | (defmethod initialize-module ((module bugzilla-module) config)
 71 |   (let ((module-conf (rest (assoc 'bugzilla config))))
 72 |     (setf (base-url-of module) (string-right-trim "/" (getf module-conf :base-url)))))
 73 | 
 74 | (defmethod handle-message ((module bugzilla-module)
 75 |                            (message irc:irc-privmsg-message))
 76 |   (let ((bugnums (all-matches-register
 77 |                   (ppcre:create-scanner "\\bbug[: #]+(\\d+)\\b" :case-insensitive-mode t)
 78 |                   (second (arguments message))
 79 |                   0
 80 |                   :sharedp t)))
 81 |     (dolist (bugnum (remove-duplicates bugnums :test #'string=))
 82 |       (multiple-value-bind (subject owner status)
 83 |           (retrieve-bug-info module bugnum)
 84 |         (when subject
 85 |           (reply-to message
 86 |                     "bug #~a is ~a [~a/~a] ~a/show_bug.cgi?id=~a"
 87 |                     bugnum subject owner (string-downcase status) (base-url-of module) bugnum))))
 88 |     nil))
 89 | 
 90 | (defmethod handle-command ((module bugzilla-module) (cmd (eql 'bug))
 91 |                            message args)
 92 |   "bug <bug number> - show a link to a bug in bugzilla"
 93 |   (let* ((bugnums (if (string-equal (first args) "topic")
 94 |                       (all-matches-register "bug ?(\\d{5,})"
 95 |                                             (topic (find-channel (connection message)
 96 |                                                                  (first (arguments message)))) 0
 97 |                                                                  :sharedp t)
 98 |                       args)))
 99 | 
100 |     (cond
101 |       ((null bugnums)
102 |        (reply-to message "I'd rather have a bug number >10,000."))
103 |       (t
104 |        (dolist (bugnum (remove-duplicates bugnums :test #'string=))
105 |          (multiple-value-bind (subject owner status)
106 |              (retrieve-bug-info module bugnum)
107 |            (cond
108 |              (subject
109 |               (reply-to message
110 |                         "bug #~a is ~a [~a/~a] ~a/show_bug.cgi?id=~a"
111 |                         bugnum subject owner status (base-url-of module) bugnum))
112 |              (t
113 |               (reply-to message "bug #~a doesn't seem to exist" bugnum)))))))))
114 | 


--------------------------------------------------------------------------------
/src/calc.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (esrap:defrule ws
  4 |     (esrap:? (+ (or #\space #\tab #\newline)))
  5 |   (:constant nil))
  6 | 
  7 | (esrap:defrule paren-expr
  8 |     (and #\( ws expression ws #\))
  9 |   (:destructure (p1 w1 e w2 p2) (declare (ignore p1 w1 w2 p2)) e))
 10 | 
 11 | (esrap:defrule literal-number
 12 |     (and (esrap:? (or #\+ #\-))
 13 |          (+ (digit-char-p character))
 14 |          (esrap:? (and #\. (+ (digit-char-p character)))))
 15 |   (:function (lambda (s)
 16 |                (format t "~s~%" s)
 17 |                (list
 18 |                 (let ((int-val (reduce (lambda (a b) (+ (* a 10) b)) (second s) :key #'digit-char-p))
 19 |                       (fract-part (cadr (third s))))
 20 |                   (if (endp (third s))
 21 |                       int-val
 22 |                       (+ int-val
 23 |                          (/ (reduce (lambda (a b) (+ (* a 10) b)) fract-part :key #'digit-char-p)
 24 |                             (expt 10 (length fract-part))))))))))
 25 | 
 26 | (defparameter +calc-functions+ '(("abs" 1 :abs)
 27 |                                  ("mod" 2 :mod)))
 28 | 
 29 | (esrap:defrule fname
 30 |     (and (esrap:character-ranges (#\a #\z) (#\A #\Z) #\_)
 31 |          (+ (esrap:character-ranges (#\a #\z) (#\A #\Z) (#\0 #\9) #\_)))
 32 |   (:text t))
 33 | 
 34 | (esrap:defrule fargs
 35 |     (esrap:? (and expression (* (and #\, ws expression))))
 36 |   (:function (lambda (s)
 37 |                (when s
 38 |                  (append (mapcar #'third (reverse (second s)))
 39 |                          (list (first s)))))))
 40 | 
 41 | (esrap:defrule funcall
 42 |     (and fname ws #\( ws fargs ws #\))
 43 |   (:destructure  (f1 w1 p1 w2 a1 w3 p2)
 44 |                  (declare (ignore w1 p1 w2 w3 p2))
 45 |                  (let* ((func (assoc f1 +calc-functions+ :test #'string=)))
 46 |                    (unless func
 47 |                      (error "Function not found: ~a" f1))
 48 |                    (unless (= (second func) (length a1))
 49 |                      (error "Expected ~d arguments to ~a, got ~a" (second func) f1 (length a1)))
 50 |                    `(,@(mapcan #'identity a1) ,(third func)))))
 51 | 
 52 | (esrap:defrule integer
 53 |     (or paren-expr funcall literal-number))
 54 | 
 55 | (esrap:defrule dice-op
 56 |     (and (esrap:? integer) ws "d" ws (esrap:? integer))
 57 |   (:destructure (i1 w1 d1 w2 i2)
 58 |                 (declare (ignore w1 d1 w2))
 59 |                 `(,@(or i2 '(6)) ,@(or i1 '(1)) :dice)))
 60 | 
 61 | (esrap:defrule factor
 62 |     (and (esrap:? (and (or "-" "+") ws))
 63 |          (or dice-op
 64 |              integer))
 65 |   (:destructure (n1 f1)
 66 |                 (if (and n1 (string= (first n1) "-"))
 67 |                     `(,@f1 -1 :mult)
 68 |                     f1)))
 69 | 
 70 | (esrap:defrule factor-op
 71 |     (and term ws (or "*" "/" "%") ws factor)
 72 |   (:destructure (i1 w1 o1 w2 i2)
 73 |                 (declare (ignore w1 w2))
 74 |                 `(,@i2 ,@i1 ,(alexandria:switch (o1 :test #'string=)
 75 |                                                 ("*" :mult) ("/" :div) ("%" :mod)))))
 76 | 
 77 | (esrap:defrule term
 78 |     (or factor-op factor))
 79 | 
 80 | (esrap:defrule term-op
 81 |     (and expression ws (or "+" "-") ws term)
 82 |   (:destructure (i1 w1 o1 w2 i2)
 83 |                 (declare (ignore w1 w2))
 84 |                 `(,@i2 ,@i1 ,(if (string= o1 "+") :add :sub))))
 85 | 
 86 | (esrap:defrule expression
 87 |     (or term-op term))
 88 | 
 89 | (defun parse-calc-expr (str)
 90 |   (or
 91 |    (esrap:parse 'expression str :junk-allowed t)
 92 |    (error "Parse error")))
 93 | 
 94 | (defun eval-calc (result-type code)
 95 |   (let ((stack nil))
 96 |     (dolist (c code)
 97 |       (case c
 98 |         (:dice
 99 |          (let* ((dice-num (pop stack))
100 |                 (dice-size (pop stack)))
101 |            (cond
102 |              ((not (< 0 dice-num 1000))
103 |               (return-from eval-calc (format nil "ERR: Invalid dice rolls ~a" dice-num)))
104 |              ((not (< 0 dice-size 1000))
105 |               (return-from eval-calc (format nil "ERR: Invalid dice size ~a" dice-size)))
106 |              (t
107 |               (push (loop
108 |                        repeat dice-num
109 |                        for roll = (1+ (random dice-size))
110 |                        summing roll)
111 |                     stack)))))
112 |         (:add
113 |          (push (+ (pop stack) (pop stack)) stack))
114 |         (:sub
115 |          (push (- (pop stack) (pop stack)) stack))
116 |         (:mult
117 |          (push (* (pop stack) (pop stack)) stack))
118 |         (:div
119 |          (let ((dividend (pop stack))
120 |                (divisor (pop stack)))
121 |            (when (zerop divisor)
122 |              (return-from eval-calc "ERR: Divide by zero"))
123 |            (push (/ dividend divisor) stack)))
124 |         (:mod
125 |          (push (mod (pop stack) (pop stack)) stack))
126 |         (:abs
127 |          (push (abs (pop stack)) stack))
128 |         (t
129 |          (push c stack))))
130 |     (funcall
131 |      (case result-type
132 |        (integer
133 |         #'truncate)
134 |        (float
135 |         #'float)
136 |        (rational
137 |         #'rational)
138 |        (t
139 |         #'identity))
140 |      (pop stack))))
141 | 
142 | (defmodule calc calc-module ("calc" "roll"))
143 | 
144 | (defun parse-calc-args (raw-args)
145 |   "Taking the raw-args to a calc command, returns (INTP FLOATP CODE FLAVOR)."
146 |   (let (opts args)
147 |     (dolist (arg raw-args)
148 |       (if (and (> (length arg) 1)
149 |                (string= "--" arg :end2 2))
150 |           (push arg opts)
151 |           (push arg args)))
152 |     (let ((expr (join-to-string " " (nreverse args))))
153 |       (multiple-value-bind (code end-pt)
154 |           (parse-calc-expr expr)
155 |         (let* ((flavor-text (if end-pt
156 |                                 (subseq expr end-pt)
157 |                                 ""))
158 |                (end-char (and (> (length flavor-text) 1)
159 |                               (char flavor-text (1- (length flavor-text)))))
160 |                (flavor (if (member end-char '(#\. #\? #\!))
161 |                            flavor-text
162 |                            (concatenate 'string flavor-text "."))))
163 |           (values
164 |            (cond
165 |              ((find "--int" opts :test #'string=)
166 |               'integer)
167 |              ((find "--float" opts :test #'string=)
168 |               'float)
169 |              ((find "--ratio" opts :test #'string=)
170 |               'rational)
171 |              (t nil))
172 |            expr
173 |            code
174 |            flavor))))))
175 | 
176 | (defmethod handle-command ((module calc-module)
177 |                            (cmd (eql 'calc))
178 |                            message args)
179 |   ".calc [--int|--float|--ratio] <expression> - evaluate an arithmetic expression."
180 |   (handler-case
181 |       (multiple-value-bind (result-type str code flavor)
182 |           (parse-calc-args args)
183 |         (declare (ignore flavor))
184 |         (reply-to message "~a: ~a ~@[(~(~a~))~]= ~a"
185 |                   (source message) str result-type
186 |                   (eval-calc result-type code)))
187 |     (t (err)
188 |       (reply-to message "~a: ERR: ~a" (source message) err))))
189 | 
190 | (defmethod handle-command ((module calc-module)
191 |                            (cmd (eql 'roll))
192 |                            message args)
193 |   ".roll <num>d<num>[<action>] - roll a die for an optional action."
194 |   (handler-case
195 |       (multiple-value-bind (result-type str code flavor)
196 |           (parse-calc-args args)
197 |         (declare (ignore str))
198 |         (reply-to message "~a rolls ~a~a" (source message) (eval-calc result-type code) flavor))
199 |     (t (err)
200 |       (declare (ignore err))
201 |       (reply-to message "~a rolls something funky that I didn't understand." (source message)))))
202 | 


--------------------------------------------------------------------------------
/src/chant.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule chant chant-module ("chant")
18 |   (chants :reader chants-of :initform (make-hash-table :test 'equal)))
19 | 
20 | (defmethod examine-message ((module chant-module)
21 |                             (message irc:irc-privmsg-message))
22 |   (let* ((text (cl-ppcre:split "\\s+"
23 |                                (remove-if-not (lambda (c)
24 |                                                 (or (alphanumericp c)
25 |                                                     (eql #\space c)))
26 |                                               (second (arguments message)))))
27 |          (signifier-pos (or (position "more" text :test 'string-equal)
28 |                             (position "less" text :test 'string-equal)
29 |                             (position "too" text :test 'string-equal)))
30 |          (source (if (message-target-is-channel-p message)
31 |                      (first (arguments message))
32 |                      (source message))))
33 |     (when (and signifier-pos
34 |                (> (length text) (1+ signifier-pos)))
35 |       (setf (gethash source (chants-of module))
36 |             (format nil "~a ~a"
37 |                     (elt text signifier-pos)
38 |                     (elt text (1+ signifier-pos)))))))
39 | 
40 | (defmethod handle-command ((module chant-module) (cmd (eql 'chant))
41 |                            message args)
42 |   "chant - set up a chant!"
43 |   (let* ((source (if (message-target-is-channel-p message)
44 |                      (first (arguments message))
45 |                      (source message)))
46 |          (chant (gethash source (chants-of module))))
47 |     (when chant
48 |       (let ((msg (format nil "~a" (string-upcase chant))))
49 |         (if (message-target-is-channel-p message)
50 |             (irc:privmsg (connection message) (first (arguments message)) msg)
51 |             (irc:privmsg (connection message) (source message) msg))))))
52 | 


--------------------------------------------------------------------------------
/src/credit.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (defparameter +starting-balance+ 100)
  4 | 
  5 | (defclass transaction ()
  6 |   ((source :reader source-of :initarg :source)
  7 |    (dest :reader dest-of :initarg :dest)
  8 |    (amount :reader amount-of :initarg :amount)
  9 |    (channel :reader channel-of :initarg :channel)
 10 |    (source-status :accessor source-status-of :initform :unknown)
 11 |    (dest-status :accessor dest-status-of :initform :unknown)))
 12 | 
 13 | (defmodule credit credit-module ("credits" "give")
 14 |   (balances :accessor balances-of :initform (make-hash-table :test 'equalp))
 15 |   (pending :accessor pending-of :initform nil))
 16 | 
 17 | (defun balance-for-nick (module nick)
 18 |   (gethash (normalize-nick nick)
 19 |            (balances-of module)
 20 |            100))
 21 | 
 22 | (defmethod initialize-module ((module credit-module) config)
 23 |   (clrhash (balances-of module))
 24 |   (with-open-file (inf (data-path "credits.lisp")
 25 |                        :direction :input
 26 |                        :if-does-not-exist nil)
 27 |     (when inf
 28 |       (loop for tuple = (read inf nil)
 29 |          while tuple
 30 |          do (setf (gethash (first tuple) (balances-of module))
 31 |                   (second tuple))))))
 32 | 
 33 | (defun save-balances (module)
 34 |   (with-open-file (ouf (data-path "credits.lisp")
 35 |                        :direction :output
 36 |                        :if-exists :supersede
 37 |                        :if-does-not-exist :create)
 38 |     (maphash (lambda (k v)
 39 |                (write (list k v) :stream ouf)
 40 |                (terpri ouf))
 41 |              (balances-of module))))
 42 | 
 43 | (defun update-pending-txns (module nick status)
 44 |   (dolist (txn (pending-of module))
 45 |     (when (string= nick (source-of txn))
 46 |       (setf (source-status-of txn) status))
 47 |     (when (string= nick (dest-of txn))
 48 |       (setf (dest-status-of txn) status))))
 49 | 
 50 | (defun process-eligible-txns (module)
 51 |   (dolist (txn (pending-of module))
 52 |     (unless (or (eql (source-status-of txn) :unknown)
 53 |                 (eql (dest-status-of txn) :unknown))
 54 |       (let ((balance (balance-for-nick module (source-of txn))))
 55 |         (cond
 56 |           ((eql (source-status-of txn) :invalid)
 57 |            (irc:privmsg (conn-of module) (source-of txn)
 58 |                         "You must be logged into NickServ to transfer credits."))
 59 |           ((eql (dest-status-of txn) :invalid)
 60 |            (irc:privmsg (conn-of module) (source-of txn)
 61 |                         (format nil "~a must be logged into NickServ to receive credits." (dest-of txn))))
 62 |           ((< balance (amount-of txn))
 63 |            (irc:privmsg (conn-of module) (source-of txn)
 64 |                         (format nil "You don't have ~d to give to ~a." (amount-of txn) (dest-of txn))))
 65 |           (t
 66 |            (decf (gethash (normalize-nick (source-of txn))
 67 |                           (balances-of module)
 68 |                           100)
 69 |                  (amount-of txn))
 70 |            (incf (gethash (normalize-nick (dest-of txn))
 71 |                           (balances-of module)
 72 |                           100)
 73 |                  (amount-of txn))
 74 |            (irc:privmsg (conn-of module) (channel-of txn)
 75 |                         (format nil "~a gives ~d credit~:p to ~a."
 76 |                                 (source-of txn)
 77 |                                 (amount-of txn)
 78 |                                 (dest-of txn)))
 79 |            (irc:privmsg (conn-of module) (source-of txn)
 80 |                         (format nil "You now have ~d credit~:p." (balance-for-nick module (source-of txn))))
 81 |            (irc:privmsg (conn-of module) (dest-of txn)
 82 |                         (format nil "~a has given you ~d credit~:p.  You now have ~d credit~:p."
 83 |                                 (source-of txn)
 84 |                                 (amount-of txn)
 85 |                                 (balance-for-nick module (dest-of txn))))
 86 |            (irc:privmsg (conn-of module) (dest-of txn)
 87 |                         (format nil "You now have ~d credit~:p." (balance-for-nick module (dest-of txn))))))
 88 |         (save-balances module))))
 89 | 
 90 |   ;; now delete the transactions just processed
 91 |   (setf (pending-of module)
 92 |         (delete-if (lambda (txn)
 93 |                      (not (or (eql (source-status-of txn) :unknown)
 94 |                               (eql (dest-status-of txn) :unknown))))
 95 |                    (pending-of module))))
 96 | 
 97 | 
 98 | 
 99 | (defmethod handle-message ((module credit-module)
100 |                            (message irc:irc-notice-message))
101 |   (when (string= (source message) "NickServ")
102 |     (multiple-value-bind (match regs)
103 |         (ppcre:scan-to-strings "STATUS (\\S+) ([0-3])" (second (arguments message)))
104 |       (when match
105 |         (let ((nick (aref regs 0))
106 |               (status (if (member (aref regs 1) '("2" "3") :test #'string=)
107 |                           :valid
108 |                           :invalid)))
109 |           (update-pending-txns module nick status)
110 |           (process-eligible-txns module))
111 |         t))))
112 | 
113 | 
114 | (defmethod handle-command ((module credit-module)
115 |                            (cmd (eql 'give))
116 |                            message args)
117 |   "give <credits> <nick> - transfer your credits to another person"
118 |   (multiple-value-bind (amt target)
119 |       (let ((first-amt (parse-integer (or (first args) "") :junk-allowed t)))
120 |         (if first-amt
121 |             (values first-amt (second args))
122 |             (values (parse-integer (or (second args) "") :junk-allowed t)
123 |                     (first args))))
124 |     (cond
125 |       ((or (null amt)
126 |            (null target))
127 |        (reply-to message "Usage: .give <credits> <nick>"))
128 |       ((string= (normalize-nick (source message))
129 |                 (normalize-nick target))
130 |        (reply-to message "Sure... Okay..."))
131 |       ((zerop amt)
132 |        (reply-to message "Done."))
133 |       ((minusp amt)
134 |        (reply-to message "Ha, ha.  Very funny."))
135 |       
136 |       (t
137 |        (irc:privmsg (conn-of module)
138 |                     "NickServ"
139 |                     (format nil "STATUS ~a ~a" (source message) target))
140 |        (push (make-instance 'transaction
141 |                             :source (source message)
142 |                             :dest target
143 |                             :amount amt
144 |                             :channel (first (arguments message)))
145 |              (pending-of module))))))
146 | 
147 | (defmethod handle-command ((module credit-module)
148 |                            (cmd (eql 'credits))
149 |                            message args)
150 |   "credits - check your credit balance"
151 |   (irc:privmsg (conn-of module)
152 |                (source message)
153 |                (format nil "You have ~a credit~:p."
154 |                        (balance-for-nick module (source message)))))


--------------------------------------------------------------------------------
/src/db.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | ;;; Data in the DB module is stored in TERMS.  A term has the following slots:
 18 | ;;;   KEY - the key of the term
 19 | ;;;   SOURCE - the information source of the term
 20 | ;;;   CONTEXT - the context of the term
 21 | ;;;   PROPERTY - the attribute of the term being defined
 22 | ;;;   VALUE - the value of the key's property in a given context
 23 | ;;; These may be repeated if an key's property has multiple values.
 24 | ;;;
 25 | ;;; A query may specify any of these.  If an unspecified slot has
 26 | ;;; multiple qualifiers, the query may choose to ask for disambiguation.
 27 | ;;;   - Ambiguous source: "according to whom?"
 28 | ;;;   - Ambiguous context: "which x do you mean?"
 29 | ;;;   - Ambiguous propery: "what do you want to know about x?"
 30 | ;;;
 31 | ;;; Example:
 32 | ;;;   ("APPEND" "CLHS" "Common Lisp" "url" "http://clhs.lisp.se/Body/f_append.htm")
 33 | ;;;   ("APPEND" "Go Spec" "Go" "url" "http://golang.org/ref/spec#Appending_and_copying_slices")
 34 | 
 35 | ;;; DB should have learned, static, and external databases.  External
 36 | ;;; databases are those accessed via the web.  Static databases are
 37 | ;;; simply loaded into memory at startup.  Learned databases are
 38 | ;;; editable via observation and deliberate additions.
 39 | ;;;
 40 | ;;; Initially, we'll only have static databases, but we need to define
 41 | ;;; the interfaces properly.
 42 | ;;;
 43 | 
 44 | (defclass query ()
 45 |   ((key :accessor key-of :initarg :key)
 46 |    (source :accessor source-of :initarg :source :initform nil)
 47 |    (context :accessor context-of :initarg :context :initform nil)
 48 |    (property :accessor property-of :initarg :property :initform nil)))
 49 | 
 50 | (defgeneric load-database (name))
 51 | (defgeneric update-database (name))
 52 | (defgeneric database-name (db))
 53 | (defgeneric query-database (db query &key exactp))
 54 | 
 55 | (defclass static-database ()
 56 |   ((name :initarg :name :accessor name-of)
 57 |    terms))
 58 | 
 59 | (defmethod initialize-instance :after ((db static-database) &rest args)
 60 |   (declare (ignore args))
 61 |   (load-database db))
 62 | 
 63 | (defmethod database-name ((db static-database))
 64 |   (slot-value db 'name))
 65 | 
 66 | (defmethod load-database ((db static-database))
 67 |   (with-slots (name terms) db
 68 |     (with-open-file (inf (data-path (format nil "~a-db.lisp" name)) :direction :input)
 69 |       (setf terms
 70 |             (loop for term = (read inf nil)
 71 |                while term
 72 |                collect term)))))
 73 | 
 74 | (defmethod query-database ((db static-database) query &key exactp)
 75 |   (let ((key (string-downcase (string-trim '(#\space #\tab #\newline) (key-of query)))))
 76 |     (remove-if-not (lambda (term)
 77 |                      (and (>= (length (first term)) (length key))
 78 |                           (string-equal key (first term) :end2 (unless exactp (length key)))
 79 |                           (or (null (source-of query)) (string-equal (source-of query) (second term)))
 80 |                           (or (null (context-of query)) (string-equal (context-of query) (third term)))
 81 |                           (or (null (property-of query)) (string-equal (property-of query) (fourth term)))))
 82 |                    (slot-value db 'terms))))
 83 | 
 84 | ;; <term>
 85 | ;; <term> <property>
 86 | ;; <context> <term>
 87 | 
 88 | (defun respond-to-query (databases query-str stream)
 89 |   (let* ((query (make-instance 'query :key query-str))
 90 |          (results (or (mapcan (lambda (db) (query-database db query :exactp t)) databases)
 91 |                       (mapcan (lambda (db) (query-database db query)) databases))))
 92 |     (cond
 93 |       ((endp results)
 94 |        ;; no results
 95 |        (format stream "No results found for ~a" query-str))
 96 |       ((endp (rest results))
 97 |        ;; one result - what we actually want
 98 |        (let ((term (first results)))
 99 |          (format stream "~a ~a: ~a"
100 |                    (first term)
101 |                    (fourth term)
102 |                    (fifth term))))
103 |       (t
104 |        ;; more than one result
105 |        (format stream "Which ~a do you want?" query)))))
106 | 
107 | (defmodule db db-module ()
108 |   (databases :accessor databases-of :initform nil))
109 | 
110 | (defmethod initialize-module ((module db-module) config)
111 |   (setf (databases-of module)
112 |         (mapcar (lambda (db-tuple)
113 |                   (apply #'make-instance (rest db-tuple)))
114 |                 (remove 'db config :test-not 'eql :key 'car))))
115 | 
116 | (defmethod handle-message ((module db-module)
117 |                            (message irc:irc-privmsg-message))
118 |   "Handle messages of the form <db> <query>
119 | <query> can be:
120 |   <key>
121 |   <key> <property>
122 |   <context> <key>
123 |   <context> <key> <property>
124 | "
125 |   (ppcre:register-groups-bind (query-str)
126 |       ("(.*)\\?\\?$" (second (arguments message)) :sharedp t)
127 |     (reply-to message "~a"
128 |               (with-output-to-string (result)
129 |                 (respond-to-query (databases-of module) query-str result)))
130 |     (return-from handle-message t))
131 | 
132 |   (destructuring-bind (db-name &optional query-str)
133 |       (re:split "\\s+" (second (arguments message)) :limit 2)
134 |     (when (and db-name query-str)
135 |       (let ((db (find db-name (databases-of module) :test #'string-equal :key #'name-of)))
136 |         (when db
137 |           (reply-to message "~a"
138 |                     (with-output-to-string (result)
139 |                       (respond-to-query (list db) query-str result))))))))
140 | 


--------------------------------------------------------------------------------
/src/defpackage.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (defpackage #:orcabot
16 | 	(:use :common-lisp
17 |           :local-time
18 |           :irc
19 |           :parse-number)
20 |     (:import-from #:alexandria
21 |                   #:alist-hash-table
22 |                   #:hash-table-keys
23 |                   #:hash-table-values
24 |                   #:random-elt)
25 | 	(:export start-orcabot-session
26 |              background-orcabot-session)
27 |     (:local-nicknames (:log :com.ravenbrook.common-lisp-log)
28 |                       (:re :cl-ppcre)))
29 | 


--------------------------------------------------------------------------------
/src/fifa.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defvar *last-fifa-id* 0)
 18 | 
 19 | (defun retrieve-fifa-updates (match &optional last-update)
 20 |   (cxml:parse
 21 |    (drakma:http-request
 22 |     (format nil "http://www.fifa.com/live/Competitions/worldcup/matchcentrelight/MatchDay=13/Day=1/Match=~a/matchIndex.xml~@[?ign=~a~]" match last-update))
 23 |    (cxml-xmls:make-xmls-builder)))
 24 | 
 25 | (defun node-attr (node attr)
 26 |   (second (assoc attr (cxml-xmls:node-attrs node)
 27 |                  :test #'string=)))
 28 | 
 29 | (defun node-named-child (node child-name)
 30 |   (assoc child-name
 31 |          (remove-if-not #'listp (cxml-xmls:node-children node))
 32 |          :test #'string=))
 33 | 
 34 | (defun event-id (e)
 35 |   (parse-integer (second (assoc "id" (cxml-xmls:node-attrs e)
 36 |                                    :test #'string=))))
 37 | (defun new-event-p (e)
 38 |   (> (event-id e) *last-fifa-id*))
 39 | 
 40 | (defun new-fifa-events (xml)
 41 |   (let* ((allevents (remove-if-not #'listp
 42 |                                    (cxml-xmls:node-children
 43 |                                     (assoc "allevents"
 44 |                                            (remove-if-not #'listp (cddr xml))
 45 |                                            :test #'string=))))
 46 |          (latest-events (remove-if-not 'new-event-p allevents)))
 47 |     #+nil (setf *last-fifa-id* (apply #'max *last-fifa-id*
 48 |                                 (mapcar 'event-id latest-events)))
 49 |     latest-events))
 50 | 
 51 | (defun retrieve-team-info (xml team)
 52 |   (dolist (node (cxml-xmls:node-children
 53 |                  (node-named-child
 54 |                   (node-named-child xml "matchinfo")
 55 |                   "match")))
 56 |     (when (and (listp node) (string= (node-attr node "team")
 57 |                                      team))
 58 |       (return-from retrieve-team-info node)))
 59 |   nil)
 60 | 
 61 | (defun event-desc (home-team-code home-team-name away-team-name e)
 62 |   (case (parse-integer (or (node-attr e "code") "0") :junk-allowed t)
 63 |     (0 nil)                      ; No code
 64 |     (1 "Yellow carded")                      ; yellow carded
 65 |     (2 "Red carded")
 66 |     (4 "Substitution")                      ; substitution
 67 |     (6 "Blocked")                      ; blocked
 68 |     (7 "Shot Wide")                      ; shot wide
 69 |     (8 "Denied Goal")                      ; denied goal
 70 |     (9 "Offsides")                      ; offsides (1)
 71 |     (10 "Corner Kick")                     ; corner kick
 72 |     (11 "Foul")                     ; foul (1)
 73 |     (21 "Commentary")                     ; commentary
 74 |     (32 "Save")                     ; save
 75 |     (55 "No Idea")                     ; no idea
 76 |     (100 nil)                    ; promotion
 77 |     (3
 78 |      (format nil "~a has scored a goal at ~a - Score is ~a ~a- ~a ~a"
 79 |              (if (string= (node-attr e "t_id") home-team-code)
 80 |                  home-team-name
 81 |                  away-team-name)
 82 |              (node-attr e "timedisplay")
 83 |              home-team-name
 84 |              (node-attr e "hs")
 85 |              away-team-name
 86 |              (node-attr e "as")))
 87 |     (13
 88 |      "Start of play")
 89 |     (14
 90 |      "End of play")
 91 |     (t
 92 |      (format nil "Unknown event: ~a" e))))
 93 | 
 94 | (defun new-fifa-event-descs ()
 95 |   (let* ((xml (retrieve-fifa-updates "300061461"))
 96 |          (home-team-info (retrieve-team-info xml "home"))
 97 |          (home-team-code (node-attr home-team-info "code"))
 98 |          (home-team-name (node-attr home-team-info "name"))
 99 |          (away-team-name (node-attr (retrieve-team-info xml "away") "name"))
100 |          (new-events (new-fifa-events xml)))
101 |     (loop
102 |        for e in new-events
103 |        as desc = (event-desc home-team-code
104 |                              home-team-name
105 |                              away-team-name
106 |                              e)
107 |        when desc
108 |        collect desc)))


--------------------------------------------------------------------------------
/src/groups.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule groups groups-module ("group" "groupadd" "groupdel")
 18 |   (groups :accessor groups-of :initform nil))
 19 | 
 20 | (defun load-group-definitions (module)
 21 |   (with-open-file (inf (data-path "groups.lisp")
 22 |                        :direction :input
 23 |                        :if-does-not-exist nil)
 24 |     (setf (groups-of module) (if inf (read inf nil) nil))))
 25 | 
 26 | (defun save-group-definitions (module)
 27 |   (write-to-file (data-path "groups.lisp")
 28 |                  (groups-of module)))
 29 | 
 30 | (defun group-definition-by-name (module name)
 31 |   (assoc name (groups-of module) :test #'string-equal))
 32 | 
 33 | (defun select-channel-nicks (connection channel-name nick-list)
 34 |   "Returns a list of the members of nick-list that are in the channel,
 35 | and a list of the member of nick-list that are not."
 36 |   (let ((channel (irc:find-channel connection channel-name)))
 37 |     (when channel
 38 |       (loop
 39 |          for channel-nick in (mapcar 'nickname (hash-table-values (users channel)))
 40 |          as normal-nick = (normalize-nick channel-nick)
 41 |          if (find normal-nick nick-list :test 'string-equal)
 42 |          collect channel-nick into online-nicks
 43 |          and
 44 |          collect normal-nick into normalized-nicks
 45 |          finally (return (values
 46 |                           (sort online-nicks #'string<)
 47 |                           (sort (set-difference nick-list normalized-nicks :test 'string=)
 48 |                                 'string<)))))))
 49 | 
 50 | (defmethod initialize-module ((module groups-module)
 51 |                               config)
 52 |   (load-group-definitions module))
 53 | 
 54 | (defmethod handle-message ((module groups-module)
 55 |                            (message irc:irc-privmsg-message))
 56 |   "Send message to group if a message on a channel is addressed to the
 57 | group."
 58 |   (ppcre:register-groups-bind (nick text)
 59 |       ("^([^:,]+)[:,] *(.*)" (second (arguments message)))
 60 |     (let ((group-def (group-definition-by-name module nick)))
 61 |       (when group-def
 62 |         (let ((nicks (select-channel-nicks (connection message)
 63 |                                            (first (arguments message))
 64 |                                            (rest group-def))))
 65 |           (if nicks
 66 |               (reply-to message "~{~a~^,~}: ~a"
 67 |                         (select-channel-nicks (connection message)
 68 |                                               (first (arguments message))
 69 |                                               (rest group-def))
 70 |                         text)
 71 |               (reply-to message "~a: No-one from group '~a' is present."
 72 |                         (source message)
 73 |                         nick))))))
 74 |   nil)
 75 | 
 76 | (defmethod handle-command ((module groups-module)
 77 |                            (cmd (eql 'group))
 78 |                            message args)
 79 |   "group [<group name> [<message>]] - send a message to a group on the same channel"
 80 |   (cond
 81 |     ((null args)
 82 |      (if (groups-of module)
 83 |          (reply-to message "Groups: ~{~a~^, ~}" (mapcar #'first (groups-of module)))
 84 |          (reply-to message "There are no groups.")))
 85 |     (t
 86 |      (let ((group-def (group-definition-by-name module (first args))))
 87 |        (multiple-value-bind (online-nicks offline-nicks)
 88 |            (select-channel-nicks (connection message)
 89 |                                  (first (arguments message))
 90 |                                  (rest group-def))
 91 |          (cond
 92 |            ((null group-def)
 93 |             (reply-to message "No such group '~a'" (first args)))
 94 |            ((null (rest args))
 95 |             (if (message-target-is-channel-p message)
 96 |                 (reply-to message "Group '~a'~@[ online: ~{~a~^ ~}~]~:[~;,~]~@[ offline: ~{~a~^ ~}~]"
 97 |                           (first group-def)
 98 |                           online-nicks
 99 |                           (and online-nicks offline-nicks)
100 |                           offline-nicks)
101 |                 (reply-to message "Group '~a' members: ~{~a~^ ~}"
102 |                           (first group-def)
103 |                           (rest group-def))))
104 |            ((null online-nicks)
105 |             (reply-to message "Nobody in group '~a' is here" (first args)))
106 |            (t
107 |             (reply-to message "~{~a~^,~}: ~{~a~^ ~}" online-nicks (rest args)))))))))
108 | 
109 | (defmethod handle-command ((module groups-module)
110 |                            (cmd (eql 'groupadd))
111 |                            message args)
112 |   "groupadd <group name> <nicks> - add new group and/or nicks to the group"
113 |   (cond
114 |     ((null args)
115 |      (reply-to message "You must specify a group and nicks to add"))
116 |     ((null (rest args))
117 |      (reply-to message "You must specify nicks to add"))
118 |     ((null (assoc (first args)
119 |                   (groups-of module)
120 |                   :test #'string-equal))
121 |      (push args (groups-of module))
122 |      (save-group-definitions module)
123 |      (reply-to message "Group '~a' added with nicks: ~{~a~^, ~}"
124 |                (first args)
125 |                (rest args)))
126 |     (t
127 |      (let* ((group-def (assoc (first args)
128 |                               (groups-of module)
129 |                               :test #'string-equal))
130 |             (new-nicks (set-difference (rest args) (rest group-def) :test #'string=)))
131 |        (cond
132 |          (new-nicks
133 |           (setf (rest group-def) (append (rest group-def) new-nicks))
134 |           (save-group-definitions module)
135 |           (reply-to message "Added ~{~a~^, ~} to group '~a'" new-nicks (first args)))
136 |          (t
137 |           (reply-to message "No new nicks added to group '~a'" (first args))))))))
138 | 
139 | (defmethod handle-command ((module groups-module)
140 |                            (cmd (eql 'groupdel))
141 |                            message args)
142 |   "groupdel <group name> [<nicks>] - remove group or nicks from group"
143 |   (cond
144 |     ((null args)
145 |      (reply-to message "You must specify a group and nicks to remove"))
146 |     ((null (assoc (first args)
147 |                   (groups-of module)
148 |                   :test #'string-equal))
149 |      (reply-to message "Group '~a' does not exist." (first args)))
150 |     ((null (rest args))
151 |      (let ((group-def (assoc (first args)
152 |                              (groups-of module)
153 |                              :test #'string-equal)))
154 |        (setf (groups-of module) (delete group-def (groups-of module)))
155 |        (save-group-definitions module)
156 |        (reply-to message "Group '~a': removed ~@[(~{~a~^, ~})~]"
157 |                  (first group-def)
158 |                  (rest group-def))))
159 |     (t
160 |      (let* ((group-def (assoc (first args)
161 |                               (groups-of module)
162 |                               :test #'string-equal))
163 |             (doomed-nicks (intersection (rest args)
164 |                                         (rest group-def)
165 |                                         :test #'string-equal))
166 |             (invalid-nicks (set-difference (rest args)
167 |                                            (rest group-def)
168 |                                            :test #'string-equal)))
169 |        ;; Remove group if all nicks are removed
170 |        (cond
171 |          ((subsetp (rest group-def) doomed-nicks :test #'string-equal)
172 |           (setf (groups-of module) (delete group-def (groups-of module)))
173 |           (reply-to message "Group '~a': removed ~@[ (~{~a~^, ~})~]"
174 |                     (first group-def)
175 |                     (rest group-def)))
176 |          (t
177 |           (setf (rest group-def) (set-difference (rest group-def)
178 |                                                  doomed-nicks
179 |                                                  :test #'string-equal))
180 |           (reply-to message "Group '~a':~@[ removed ~{~a~^, ~}~]~:[~;, ~]~@[ ignored ~{~a~^, ~}~]"
181 |                     (first group-def)
182 |                     doomed-nicks
183 |                     (and doomed-nicks invalid-nicks)
184 |                     invalid-nicks)))
185 | 
186 |        (save-group-definitions module)))))
187 | 


--------------------------------------------------------------------------------
/src/karma.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule karma karma-module ("karma")
18 |   (scores :accessor scores-of :initform (make-hash-table :test 'equalp)))
19 | 
20 | (defmethod initialize-module ((module karma-module) config)
21 |   (clrhash (scores-of module))
22 |   (with-open-file (inf (data-path "karma.lisp")
23 |                        :direction :input
24 |                        :if-does-not-exist nil)
25 |     (when inf
26 |       (loop for tuple = (read inf nil)
27 |          while tuple
28 |          do (setf (gethash (first tuple) (scores-of module))
29 |                   (second tuple))))))
30 | 
31 | (defun save-karma-scores (module)
32 |   (with-open-file (ouf (data-path "karma.lisp")
33 |                        :direction :output
34 |                        :if-exists :supersede
35 |                        :if-does-not-exist :create)
36 |     (maphash (lambda (k v)
37 |                (write (list k v) :stream ouf)
38 |                (terpri ouf))
39 |              (scores-of module))))
40 | 
41 | (defmethod handle-message ((module karma-module)
42 |                            (message irc:irc-privmsg-message))
43 |   ;; Add karma to nick.  Take karma away if they're trying to give
44 |   ;; themselves karma
45 |   (ppcre:register-groups-bind (nick1 nick2)
46 |       ("^(?:([^+-]+)\\+\\+|\\+\\+([^+-]+\))$" (second (arguments message)))
47 |     (let ((nick (or nick1 nick2)))
48 |       (when (valid-nick-p nick)
49 |         (if (irc-string-equal nick (source message))
50 |             (decf (gethash nick (scores-of module) 0))
51 |             (incf (gethash nick (scores-of module) 0)))
52 |         (save-karma-scores module))))
53 | 
54 |   ;; Take karma away from nick
55 |   (ppcre:register-groups-bind (nick1 nick2)
56 |       ("^(?:([^+-]+)\\-\\-|\\-\\-([^+-]+\))$" (second (arguments message)))
57 |     (let ((nick (or nick1 nick2)))
58 |       (when (valid-nick-p nick)
59 |         (decf (gethash nick (scores-of module) 0))
60 |         (save-karma-scores module))))
61 |   nil)
62 | 
63 | (defmethod handle-command ((module karma-module)
64 |                            (cmd (eql 'karma))
65 |                            message args)
66 |   "karma <nick> - check the karma in the soul"
67 |   (if args
68 |       (reply-to message "~a has ~a karma"
69 |                 (first args)
70 |                 (gethash (first args)
71 |                          (scores-of module)
72 |                          0))
73 |       (reply-to message "Usage: karma <nick>")))
74 | 


--------------------------------------------------------------------------------
/src/lastseen.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule lastseen lastseen-module ("seen")
18 |   (last-action :accessor last-action-of :initform (make-hash-table :test 'equalp)))
19 | 
20 | (defmethod initialize-module ((module lastseen-module) config)
21 |   (clrhash (last-action-of module)))
22 | 
23 | (defun describe-message-action (message)
24 |   (typecase message
25 |     (irc:irc-privmsg-message
26 |      (format nil "saying on ~a: ~a"
27 |              (first (arguments message))
28 |              (second (arguments message))))
29 |     (irc:irc-notice-message
30 |      (format nil "noting on ~a: ~a"
31 |              (first (arguments message))
32 |              (second (arguments message))))
33 |     (irc:irc-kick-message
34 |      (format nil "kicking ~a from ~a"
35 |              (first (arguments message))
36 |              (second (arguments message))))
37 |     (irc:irc-topic-message
38 |      (format nil "setting the topic on ~a to: ~a"
39 |              (first (arguments message))
40 |              (second (arguments message))))
41 |     (irc:irc-mode-message
42 |      (format nil "changing mode of ~a: ~w"
43 |              (first (arguments message))
44 |              (rest (arguments message))))
45 |     (irc:irc-nick-message
46 |      (format nil "changing nick to ~a"
47 |              (second (arguments message))))
48 |     (irc:irc-join-message
49 |      (format nil "joining ~a" (first (arguments message))))
50 |     (irc:irc-part-message
51 |      (format nil "leaving ~a~@[ (~a)~]"
52 |              (first (arguments message))
53 |              (second (arguments message))))
54 |     (irc:irc-quit-message
55 |      (format nil
56 |              "quitting~@[ (~a)~]"
57 |              (second (arguments message))))
58 |     (irc:ctcp-action-message
59 |      (format nil
60 |              "acting on ~a: ~a"
61 |              (first (arguments message))
62 |              (subseq (second (arguments message))
63 |                      8
64 |                      (1- (length (second (arguments message)))))))))
65 | 
66 | (defmethod examine-message ((module lastseen-module) message)
67 |   (setf (gethash (source message) (last-action-of module)) message))
68 | 
69 | (defmethod handle-command ((module lastseen-module)
70 |                            (cmd (eql 'seen))
71 |                            message args)
72 |   "seen <nick> - show the last activity from the nick"
73 |   (if args
74 |       (dolist (nick args)
75 |         (let ((last-action (gethash nick (last-action-of module))))
76 |           (if last-action
77 |               (reply-to message "~a was last seen at ~a ~a"
78 |                         (source last-action)
79 |                         (local-time:format-timestring
80 |                          nil
81 |                          (local-time:universal-to-timestamp
82 |                           (received-time last-action)))
83 |                         (describe-message-action last-action))
84 |               (reply-to message "I haven't seen ~a" nick))))
85 |       (reply-to message "Usage: .seen <nick> [...]")))
86 | 


--------------------------------------------------------------------------------
/src/liarsdice.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (defmodule liarsdice liarsdice-module ("ld")
  4 |   (round :accessor round-of :initform nil)
  5 |   (current-player :accessor current-player-of :initform nil)
  6 |   (last-claim :accessor last-claim-of :initform nil
  7 |               :documentation "Last claim of form (NICK N D)")
  8 |   (players :accessor players-of :initform nil)
  9 |   (dice-left :accessor dice-left-of :initform nil)
 10 |   (dice-rolls :accessor dice-rolls-of :initform nil))
 11 | 
 12 | (defun liarsdice-setup-game (module message players)
 13 |   (cond
 14 |     ((players-of module)
 15 |      (reply-to message "There is already a game on!"))
 16 |     ((< (length players) 2)
 17 |      (reply-to message "You need at least two players!"))
 18 |     ((member (nickname (user (connection message)))
 19 |              players
 20 |              :test 'string-equal)
 21 |      (reply-to message "The bot can't play this game."))
 22 |     (t
 23 |      (setf (players-of module) (alexandria:shuffle players))
 24 |      (reply-to message "Starting game with player order: ~{~a~^, ~}" (players-of module))
 25 |      (setf (current-player-of module) (first (players-of module)))
 26 |      (setf (round-of module) 1
 27 |            (last-claim-of module) nil
 28 |            (dice-left-of module) (mapcar (lambda (nick)
 29 |                                            (cons nick 5))
 30 |                                          (players-of module)))
 31 |      (liarsdice-roll-dice module message))))
 32 | 
 33 | (defun liarsdice-roll-dice (module message)
 34 |   (reply-to message "Round #~a: Rolling ~a total dice.  It is ~a's turn."
 35 |             (round-of module)
 36 |             (reduce '+ (mapcar 'cdr (dice-left-of module)))
 37 |             (current-player-of module))
 38 |   (setf (dice-rolls-of module)
 39 |         (mapcar (lambda (nick)
 40 |                   (let ((rolls (sort (loop repeat (cdr (assoc nick (dice-left-of module) :test 'string-equal))
 41 |                                            collect (1+ (random 6)))
 42 |                                      '<)))
 43 |                     (irc:privmsg (connection message) nick
 44 |                                  (format nil "Round #~a: your dice rolls are ~{~a~^ ~}" (round-of module) rolls))
 45 |                     (cons nick rolls)))
 46 |                 (remove-if (lambda (nick)
 47 |                              (zerop (cdr (assoc nick (dice-left-of module)
 48 |                                                 :test 'string-equal))))
 49 |                            (players-of module)))))
 50 | 
 51 | (defun liarsdice-show-score (module message)
 52 |   (reply-to message "Dice left: ~:{~a - ~a~:^, ~}"
 53 |             (mapcar (lambda (x) (list (car x) (cdr x)))
 54 |                     (dice-left-of module))))
 55 | 
 56 | (defun liarsdice-penalize (module message nick)
 57 |   (let ((target (assoc nick (dice-left-of module) :test 'string-equal)))
 58 |     (decf (cdr target))
 59 |     
 60 |     (when (= 1 (count-if-not 'zerop (dice-left-of module) :key 'cdr))
 61 |       ;; one player remaining
 62 |       (reply-to message "~a loses a die and has been eliminated!" nick)
 63 |       (reply-to message "~a is the winner!"
 64 |                 (car (find-if-not 'zerop (dice-left-of module) :key 'cdr)))
 65 |       (setf (players-of module) nil)
 66 |       (return-from liarsdice-penalize nil))
 67 |     
 68 |     (if (zerop (cdr target))
 69 |         (reply-to message "~a loses a die and has been eliminated!  It is now ~a's turn." nick)
 70 |         (reply-to message "~a loses a die!" nick))))
 71 | 
 72 | (defun advance-player (module)
 73 |   (loop
 74 |     (setf (current-player-of module)
 75 |           (elt (players-of module)
 76 |                (mod (1+ (position (current-player-of module)
 77 |                                   (players-of module)))
 78 |                     (length (players-of module)))))
 79 |     (when (plusp (cdr (assoc (current-player-of module)
 80 |                              (dice-left-of module)
 81 |                              :test 'string-equal)))
 82 |       (return-from advance-player))))
 83 | 
 84 | (defmethod handle-command ((module liarsdice-module)
 85 |                            (cmd (eql 'ld))
 86 |                            message args)
 87 |   ".ld [start <nicks>|claim|call|ragequit] - Facilitates a game of Liar's Dice."
 88 |   (unless (message-target-is-channel-p message)
 89 |     (reply-to message ".ld command should be used only in a channel.")
 90 |     (return-from handle-command nil))
 91 |   
 92 |   (alexandria:switch ((first args) :test 'string-equal)
 93 |     ("start"
 94 |      (liarsdice-setup-game module message (rest args)))
 95 |     ("claim"
 96 |      (let (n d)
 97 |        (cond
 98 |          ((endp (players-of module))
 99 |           (reply-to message "No game is in progress!"))
100 |          ((string-not-equal (source message) (current-player-of module))
101 |           (reply-to message "It's not your turn!"))
102 |          ((or (/= 3 (length args))
103 |               (null (setf n (parse-integer (second args) :junk-allowed t)))
104 |               (null (setf d (parse-integer (third args) :junk-allowed t)))
105 |               (minusp n)
106 |               (not (<= 1 d 6)))
107 |           (reply-to message "Usage: .ld claim <# of dice> <die roll>"))
108 |          ((and (last-claim-of module)
109 |                (or (< n (second (last-claim-of module)))
110 |                    (and (= n (second (last-claim-of module)))
111 |                         (< d (third (last-claim-of module))))))
112 |           (reply-to message "# of dice needs to be greater than last claim, or die roll must be higher with same # of dice.")
113 |           )
114 |          (t
115 |           (setf (last-claim-of module) (list (current-player-of module) n d))
116 |           (advance-player module)
117 |           (reply-to message "~a claims there ~:[are~;is~] ~a ~:[dice~;die~] showing ~a.  It is now ~a's turn."
118 |                     (source message)
119 |                     (= n 1)
120 |                     n
121 |                     (= n 1)
122 |                     d
123 |                     (current-player-of module))))
124 |        ))
125 |     ("call"
126 |      (cond
127 |        ((endp (players-of module))
128 |         (reply-to message "No game is in progress!"))
129 |        ((string-not-equal (source message) (current-player-of module))
130 |         (reply-to message "It's not your turn!"))
131 |        ((null (last-claim-of module))
132 |         (reply-to message "No claim has been made yet!"))
133 |        (t
134 |         (reply-to message "--- round #~a results ---" (round-of module))
135 |         (dolist (rolls (dice-rolls-of module))
136 |           (reply-to message "~14a rolled ~{~a~^ ~}"
137 |                     (first rolls)
138 |                     (rest rolls)))
139 |         (let ((roll-freq (make-array '(6) :initial-element 0))
140 |               (n (second (last-claim-of module)))
141 |               (d (third (last-claim-of module))))
142 |           (dolist (rolls (dice-rolls-of module))
143 |             (dolist (roll (rest rolls))
144 |               (incf (aref roll-freq (1- roll)))))
145 | 
146 |           (reply-to message "There are ~:{~a ~as~:^, ~}"
147 |                     (loop for freq across roll-freq
148 |                           as idx from 1
149 |                           unless (zerop freq)
150 |                           collect (list freq idx)))
151 |           (cond
152 |             ((>= (aref roll-freq (1- d)) n)
153 |              (reply-to message "~a's claim was at least ~a ~as, which was CORRECT." (first (last-claim-of module)) n d)
154 |              (liarsdice-penalize module message (current-player-of module))
155 |              (setf (current-player-of module) (first (last-claim-of module))))
156 |             (t
157 |              (reply-to message "~a's claim was at least ~a ~as, which was a LIE." (first (last-claim-of module)) n d)
158 |              (liarsdice-penalize module message (first (last-claim-of module))))))
159 |         (when (players-of module)
160 |           ;; still playing?  Go to next round.
161 |           (incf (round-of module))
162 |           (liarsdice-show-score module message)
163 |           (liarsdice-roll-dice module message)
164 |           (setf (last-claim-of module) nil)))))
165 |     
166 |     ("ragequit"
167 |      (cond
168 |        ((endp (players-of module))
169 |         (reply-to message "No game is in progress!"))
170 |        ((not (member (source message)
171 |                      (players-of module)
172 |                      :test 'string-equal))
173 |         (reply-to message "You're not one of the players, jerk."))
174 |        (t
175 |         (reply-to message "You flip the table over in a rage!  Dice go flying!")
176 |         (setf (players-of module) nil))))
177 |     (t
178 |      (reply-to message "Usage: .ld [start <nicks>|claim|call|ragequit] - play a game of Liar's Dice."))))
179 | 


--------------------------------------------------------------------------------
/src/logging.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule logging logging-module ()
 18 |   (channel-streams :accessor channel-streams-of :initform nil))
 19 | 
 20 | (defmethod initialize-module ((module logging-module)
 21 |                               config)
 22 |   (let ((log-confs (remove 'log config :test-not #'eql :key #'first)))
 23 |     (dolist (log-conf log-confs)
 24 |       (push (list (second log-conf)
 25 |                   (open (third log-conf) :direction :output
 26 |                         :if-exists :append
 27 |                         :if-does-not-exist :create))
 28 |             (channel-streams-of module)))))
 29 | 
 30 | (defmethod deinitialize-module ((module logging-module))
 31 |   (dolist (channel-stream (channel-streams-of module))
 32 |     (close (second channel-stream))))
 33 | 
 34 | (defmethod examine-message ((module logging-module) message)
 35 |   (let ((channel-stream (assoc (first (arguments message))
 36 |                                (channel-streams-of module)
 37 |                                :test #'string=)))
 38 |     (when channel-stream
 39 |       (case (type-of message)
 40 |         (irc:irc-privmsg-message
 41 |          (format (second channel-stream)
 42 |                  "~a <~a> ~a~%"
 43 |                  (local-time:format-timestring nil (local-time:now))
 44 |                  (source message)
 45 |                  (second (arguments message))))
 46 |         (irc:irc-notice-message
 47 |          (format (second channel-stream)
 48 |                  "~a -~a- ~a~%"
 49 |                  (local-time:format-timestring nil (local-time:now))
 50 |                  (source message)
 51 |                  (second (arguments message))))
 52 |         (irc:irc-kick-message
 53 |          (format (second channel-stream)
 54 |                  "~a ~a has kicked ~a~@[ (~a)~]~%"
 55 |                  (local-time:format-timestring nil (local-time:now))
 56 |                  (source message)
 57 |                  (second (arguments message))
 58 |                  (third (arguments message))))
 59 |         (irc:irc-topic-message
 60 |          (format (second channel-stream)
 61 |                  "~a ~a has set the topic to: ~a~%"
 62 |                  (local-time:format-timestring nil (local-time:now))
 63 |                  (source message)
 64 |                  (second (arguments message))))
 65 |         (irc:irc-error-message
 66 |          (format (second channel-stream)
 67 |                  "~a ERROR received: ~a~%"
 68 |                  (local-time:format-timestring nil (local-time:now))
 69 |                  (second (arguments message))))
 70 |         (irc:irc-mode-message
 71 |          (format (second channel-stream)
 72 |                  "~a ~a changed mode: ~w~%"
 73 |                  (local-time:format-timestring nil (local-time:now))
 74 |                  (source message)
 75 |                  (rest (arguments message))))
 76 |         (irc:irc-nick-message
 77 |          (format (second channel-stream)
 78 |                  "~a ~a changed nick to ~a~%"
 79 |                  (local-time:format-timestring nil (local-time:now))
 80 |                  (source message)
 81 |                  (second (arguments message))))
 82 |         (irc:irc-join-message
 83 |          (format (second channel-stream)
 84 |                  "~a ~a has joined the channel~%"
 85 |                  (local-time:format-timestring nil (local-time:now))
 86 |                  (source message)))
 87 |         (irc:irc-part-message
 88 |          (format (second channel-stream)
 89 |                  "~a ~a has left the channel~@[ (~a)~]~%"
 90 |                  (local-time:format-timestring nil (local-time:now))
 91 |                  (source message)
 92 |                  (second (arguments message))))
 93 |         (irc:irc-quit-message
 94 |          (format (second channel-stream)
 95 |                  "~a ~a has quit~@[ (~a)~]~%"
 96 |                  (local-time:format-timestring nil (local-time:now))
 97 |                  (source message)
 98 |                  (second (arguments message))))
 99 |         (irc:ctcp-action-message
100 |          (format (second channel-stream)
101 |                  "~a * ~a ~a~%"
102 |                  (local-time:format-timestring nil (local-time:now))
103 |                  (source message)
104 | 
105 |                  (subseq (second (arguments message))
106 |                          8
107 |                          (1- (length (second (arguments message))))))))
108 |       (finish-output (second channel-stream)))))
109 | 


--------------------------------------------------------------------------------
/src/main.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defvar *thread* nil)
 18 | (defvar *process-count* 1)
 19 | (defvar *quitting* nil)
 20 | (defvar *event-base* nil)
 21 | 
 22 | (defun session-connection-info (config)
 23 |   (let ((server (cdr (assoc 'server config)))
 24 |         (user (cdr (assoc 'user config))))
 25 |     (values
 26 |      (getf user :nickname "orca")
 27 |      (or (getf server :host)
 28 |          (error "session didn't specify a server host"))
 29 |      (getf server :port 6667)
 30 |      (getf user :username "orcabot")
 31 |      (getf user :realname "Orcabot")
 32 |      (getf server :security :none))))
 33 | 
 34 | (defun main-event-loop (conn)
 35 |   (let ((fd (iolib:socket-os-fd (cl-irc::socket conn))))
 36 |     (unwind-protect
 37 |          (progn
 38 |            (iolib:set-io-handler *event-base*
 39 |                                  fd
 40 |                                  :read
 41 |                                  (lambda (fd event exception)
 42 |                                    (declare (ignore fd event exception))
 43 |                                    (cl-irc:read-message conn)))
 44 |            (iolib:event-dispatch *event-base*))
 45 |       (when (iolib.multiplex::fd-monitored-p *event-base* fd :read)
 46 |         (iolib:remove-fd-handlers *event-base* fd)))))
 47 | 
 48 | (defun orcabot-connect (config)
 49 |   (multiple-value-bind (nickname host port username realname security)
 50 |       (session-connection-info config)
 51 |     (cl-irc:connect
 52 |      :nickname nickname
 53 |      :server host
 54 |      :username username
 55 |      :realname realname
 56 |      :password (getf (authentication-credentials host) :password)
 57 |      :port port
 58 |      :connection-security security)))
 59 | 
 60 | (defun send-irc-keepalive (conn)
 61 |   (cond
 62 |     ((not *received-keepalive-p*)
 63 |      (error 'keepalive-failed))
 64 |     (t
 65 |      (setf *received-keepalive-p* nil)
 66 |      (cl-irc:ping conn "keepalive"))))
 67 | 
 68 | (defun make-orcabot-instance (data-dir &key log-to-stdoutp)
 69 |   (lambda ()
 70 |     (let* ((*quitting* nil)
 71 |            (*random-state* (make-random-state t))
 72 |            (babel::*suppress-character-coding-errors* t)
 73 |            (*event-base* (make-instance 'iolib:event-base))
 74 |            (*received-keepalive-p* t)
 75 |            (*orcabot-data-root-pathname* data-dir))
 76 |       (local-time:enable-read-macros)
 77 |       (setf (log:log-manager)
 78 |             (make-instance 'log:log-manager :message-class 'log:formatted-message))
 79 |       (when log-to-stdoutp
 80 |         (log:start-messenger 'log:text-stream-messenger
 81 |                              :name 'stdout
 82 |                              :stream *standard-output*))
 83 |       (log:start-messenger 'log:text-file-messenger
 84 |                            :name 'tofile
 85 |                            :filename (data-path "orcabot.log"))
 86 |       (log:log-message :notice "Starting orcabot...")
 87 |       (loop until *quitting* do
 88 |         (let ((conn nil)
 89 |               (keepalive nil)
 90 |               (config (read-orcabot-config)))
 91 |           (unwind-protect
 92 |                (handler-case
 93 |                    (progn
 94 |                      (log:log-message :info "Connecting to server")
 95 |                      (setf conn (orcabot-connect config))
 96 |                      (log:log-message :info "Initializing dispatcher")
 97 |                      (initialize-dispatcher conn config)
 98 |                      (log:log-message :info "Scheduling keepalive")
 99 |                      (setf *received-keepalive-p* t)
100 |                      (setf keepalive
101 |                            (iolib:add-timer *event-base*
102 |                                             (lambda () (send-irc-keepalive conn))
103 |                                             60))
104 |                      (log:log-message :info "Entering main loop")
105 |                      (handler-bind
106 |                          ((flexi-streams:external-format-encoding-error
107 |                             #'(lambda (c)
108 |                                 (declare (ignore c))
109 |                                 (use-value #\?))))
110 |                        (main-event-loop conn)))
111 |                  (irc:no-such-reply (err)
112 |                    (log:log-message :notice "Recieved invalid reply code ~a" (reply-number err)))
113 |                  (iolib:hangup (err)
114 |                    (log:log-message :notice "Hangup received ~a" err))
115 |                  (iolib:socket-error (err)
116 |                    (log:log-message :error "Socket error ~a" err))
117 |                  (iolib:resolver-no-name-error (err)
118 |                    (log:log-message :error "DNS error ~a" err))
119 |                  (sb-int:simple-stream-error (err)
120 |                    (log:log-message :error "Simple stream error ~a" err))
121 |                  (cl+ssl::ssl-error-syscall (err)
122 |                    (log:log-message :error "SSL error ~a" err))
123 |                  (cl+ssl::ssl-error-zero-return (err)
124 |                    (log:log-message :error "SSL zero return error ~a" err))
125 |                  (keepalive-failed ()
126 |                    (log:log-message :error "Keepalive failed.  Reconnecting."))
127 |                  (orcabot-rebooting ()
128 |                    (log:log-message :info "Rebooting..."))
129 |                  (orcabot-exiting ()
130 |                    (log:log-message :info "Exiting gracefully")
131 |                    (setf *quitting* t)))
132 |             (ignore-errors
133 |              (when keepalive
134 |                (iolib:remove-timer *event-base* keepalive))
135 |              (when conn
136 |                (shutdown-dispatcher conn)
137 |                (irc:quit conn (if *quitting*
138 |                                   "Quitting"
139 |                                   "Don't panic!")))))))
140 |       (unless *quitting*
141 |         (log:log-message :info "Sleeping 5 seconds before reconnecting.")
142 |         (sleep 5)))))
143 | 
144 | (defun start-process (function name)
145 |   "Trivial wrapper around implementation thread functions."
146 |   (declare (ignorable name))
147 |   #+allegro (mp:process-run-function name function)
148 |   #+cmu (mp:make-process function :name name)
149 |   #+lispworks (mp:process-run-function name nil function)
150 |   #+sb-thread (sb-thread:make-thread function :name name)
151 |   #+openmcl (ccl:process-run-function name function)
152 |   #+armedbear (ext:make-thread function))
153 | 
154 | (defun read-orcabot-config ()
155 |   (let ((*package* (find-package "ORCABOT")))
156 |     (local-time:enable-read-macros)
157 |     (with-open-file (inf (data-path "config.lisp")
158 |                          :direction :input)
159 |       (loop for form = (read inf nil)
160 |          while form
161 |          collect form))))
162 | 
163 | (defun background-orcabot-session (data-dir)
164 |   (start-process (make-orcabot-instance data-dir)
165 |                  (format nil "orcabot-handler-~D" (incf *process-count*))))
166 | 
167 | (defun start-orcabot-session (data-dir)
168 |   (funcall (make-orcabot-instance data-dir :log-to-stdoutp t)))
169 | 


--------------------------------------------------------------------------------
/src/memo.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule memo memo-module ("memo")
 18 |   (memos :accessor memos-of :initform (make-hash-table :test 'equalp)
 19 |          :documentation "Container for memo information.  Memos are
 20 | stored as NICK UNIVERSAL-TIME MESSAGE, with the destination user as
 21 | the key.
 22 | "))
 23 | 
 24 | (defmethod initialize-module ((module memo-module) config)
 25 |   (clrhash (memos-of module))
 26 |   (with-open-file (inf (data-path "memos.lisp")
 27 |                        :direction :input
 28 |                        :if-does-not-exist nil)
 29 |     (when inf
 30 |       (loop for tuple = (read inf nil)
 31 |          while tuple
 32 |          do (setf (gethash (first tuple) (memos-of module))
 33 |                   (rest tuple))))))
 34 | 
 35 | (defun save-memos (module)
 36 |   (with-open-file (ouf (data-path "memos.lisp")
 37 |                        :direction :output
 38 |                        :if-exists :supersede
 39 |                        :if-does-not-exist :create)
 40 |     (maphash (lambda (k v)
 41 |                (write (list* k v) :stream ouf)
 42 |                (terpri ouf))
 43 |              (memos-of module))))
 44 | 
 45 | (defun send-pending-memos (module nick)
 46 |   (let* ((user (normalize-nick nick))
 47 |          (memos (gethash user (memos-of module))))
 48 |     (when memos
 49 |       (log:log-message :info "Sending ~a pending memos to ~a" (length memos) user)
 50 |       (dolist (memo memos)
 51 |         (irc:privmsg (conn-of module)
 52 |                      nick
 53 |                      (format nil "~a said ~a ago: ~a"
 54 |                              (first memo)
 55 |                              (describe-duration (- (get-universal-time)
 56 |                                                    (second memo)))
 57 |                              (third memo))))
 58 |       (remhash user (memos-of module))
 59 |       (save-memos module))))
 60 | 
 61 | (defun add-new-memo (module from-nick to-nick message)
 62 |   (push (list from-nick
 63 |               (get-universal-time)
 64 |               message)
 65 |         (gethash (normalize-nick to-nick) (memos-of module)))
 66 |   (save-memos module))
 67 | 
 68 | (defmethod examine-message ((module memo-module)
 69 |                            (message irc:ctcp-action-message))
 70 |   (send-pending-memos module (source message)))
 71 | 
 72 | (defmethod examine-message ((module memo-module)
 73 |                            (message irc:irc-privmsg-message))
 74 |   (send-pending-memos module (source message)))
 75 | 
 76 | (defmethod examine-message ((module memo-module)
 77 |                            (message irc:irc-nick-message))
 78 |   (send-pending-memos module (source message)))
 79 | 
 80 | (defmethod examine-message ((module memo-module)
 81 |                            (message irc:irc-part-message))
 82 |   (send-pending-memos module (source message)))
 83 | 
 84 | (defmethod examine-message ((module memo-module)
 85 |                            (message irc:irc-join-message))
 86 |   (send-pending-memos module (source message)))
 87 | 
 88 | (defmethod handle-command ((module memo-module)
 89 |                            (cmd (eql 'memo))
 90 |                            message args)
 91 |   "memo <nick> <message> - leave a memo for nick "
 92 |   (cond
 93 |     ((< (length args) 2)
 94 |      (reply-to message "Usage: memo <nick> <message>"))
 95 |     ((not (valid-nick-p (first args)))
 96 |      (reply-to message "'~a' is not a valid nick." (first args)))
 97 |     ((string= (first args)
 98 |               (nickname (user (connection message))))
 99 |      (reply-to message "No need to memo, I'm right here!"))
100 |     (t
101 |      (add-new-memo module (source message)
102 |                    (first args)
103 |                    (format nil "~{~a~^ ~}" (rest args)))
104 |      (reply-to message "Memo left for ~a." (first args)))))
105 | 


--------------------------------------------------------------------------------
/src/parrot.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule parrot parrot-module ("parrot")
 18 |   (parrots :accessor parrots-of :initform (make-hash-table :test 'equalp))
 19 |   (save-counter :accessor save-counter-of :initform 0))
 20 | 
 21 | (defmethod initialize-module ((module parrot-module) config)
 22 |   (setf (save-counter-of module)
 23 |         (or (second (assoc 'parrot-save-lines config)) 100))
 24 |   (load-parrots module))
 25 | 
 26 | (defun save-parrots (module)
 27 |   (with-open-file (ouf (data-path "parrots.lisp")
 28 |                        :direction :output
 29 |                        :if-exists :rename-and-delete
 30 |                        :if-does-not-exist :create)
 31 |     (dolist (parrot-nick (sort (hash-table-keys (parrots-of module)) #'string<))
 32 |       (let ((parrot (gethash parrot-nick (parrots-of module))))
 33 |         (format ouf "(parrot ~s ~s)~%"
 34 |                 parrot-nick
 35 |                 (loop
 36 |                    for key in (hash-table-keys parrot)
 37 |                    collect (list key (gethash key parrot))))))))
 38 | 
 39 | (defun load-parrots (module)
 40 |   (clrhash (parrots-of module))
 41 |   (let ((*package* (find-package "ORCABOT")))
 42 |     (with-open-file (inf (data-path "parrots.lisp")
 43 |                          :if-does-not-exist nil)
 44 |       (when inf
 45 |         (loop
 46 |            for parrot-spec = (read inf nil)
 47 |            while parrot-spec
 48 |            when (eql (first parrot-spec) 'parrot)
 49 |            do
 50 |              (let ((parrot (or (gethash (normalize-nick (second parrot-spec))
 51 |                                         (parrots-of module))
 52 |                                (make-hash-table :test 'equal))))
 53 |                (setf (gethash (normalize-nick (second parrot-spec))
 54 |                               (parrots-of module))
 55 |                      parrot)
 56 |                (dolist (tuple (third parrot-spec))
 57 |                  (dolist (word (second tuple))
 58 |                    (push word (gethash (first tuple) parrot))))))))))
 59 | 
 60 | (defmethod handle-message ((module parrot-module)
 61 |                            (message irc:irc-privmsg-message))
 62 | 
 63 |   (parrot-learn module
 64 |                 (normalize-nick (source message))
 65 |                 (second (arguments message)))
 66 |   (when (>= (save-counter-of module) 100)
 67 |     (save-parrots module)
 68 |     (setf (save-counter-of module) 0)))
 69 | 
 70 | (defmethod handle-command ((module parrot-module)
 71 |                            (cmd (eql 'parrot))
 72 |                            message args)
 73 |   (cond
 74 |     ((null args)
 75 |      (reply-to message "Usage: parrot <nick>"))
 76 |     ((null (gethash (normalize-nick (first args)) (parrots-of module)))
 77 |      (reply-to message "Never heard of ~a." (first args)))
 78 |     (t
 79 |      (reply-to message "~a" (parrot-speak module (normalize-nick (first args)))))))
 80 | 
 81 | (defun markov-learn (corpus text)
 82 |   (let ((words (cl-ppcre:split "\\s+" text)))
 83 |     (loop for (first second) on words by #'cdr
 84 |        while (and first second)
 85 |        do (push second (gethash (list first) corpus)))))
 86 | 
 87 | (defun markov-generate (corpus count)
 88 |   (let ((result (random-elt (hash-table-keys corpus))))
 89 |     (loop
 90 |        repeat count
 91 |        for branches = (gethash (list (first result)) corpus)
 92 |        while branches
 93 |        do (push (random-elt branches) result))
 94 |     (nreverse result)))
 95 | 
 96 | (defun parrot-learn (module nick text)
 97 |   (let ((parrot (gethash nick (parrots-of module))))
 98 |     (unless parrot
 99 |       (setf parrot (make-hash-table :test 'equal))
100 |       (setf (gethash nick (parrots-of module)) parrot))
101 |     (markov-learn parrot text)))
102 | 
103 | (defun parrot-speak (module nick)
104 |   (let ((parrot (gethash nick (parrots-of module))))
105 |     (if (and parrot (plusp (hash-table-count parrot)))
106 |         (format nil "<~a> ~a" nick (join-to-string " " (markov-generate parrot 100)))
107 |         (format nil "Never heard of ~a" nick))))
108 | 
109 | ;;; The code below this line is for convenience
110 | (defun parrots-learn-from-line (module line)
111 |   (multiple-value-bind (match regs)
112 |       (cl-ppcre:scan-to-strings
113 |        "<span class=\"irc-black\">&lt;([^[&_-]+)[^&]*&gt; (.*)</span><br />"
114 |        line :sharedp t)
115 |     (when match
116 |       (parrot-learn module (aref regs 0) (aref regs 1)))))
117 | 
118 | (defun parrots-learn-from-file (module path)
119 |   (with-open-file (inf path :direction :input)
120 |     (loop
121 |        for line = (read-line inf nil)
122 |        while line
123 |        do (parrots-learn-from-line module line))))
124 | 
125 | (defun parrots-learn-from-dir (module dir-path)
126 |   (dolist (file-path (directory dir-path))
127 |     (format t "Learning from ~a~%" file-path)
128 |     (parrots-learn-from-file module file-path)))
129 | 
130 | (defun textify-irc-logs (dir-path)
131 |   (dolist (inf-path (directory dir-path))
132 |     (format t "Textifying ~a~%" inf-path)
133 |     (with-open-file (inf inf-path)
134 |       (with-open-file (ouf (make-pathname
135 |                             :type "txt"
136 |                             :defaults inf-path)
137 |                            :direction :output
138 |                            :if-exists :rename-and-delete
139 |                            :if-does-not-exist :create)
140 |         (loop
141 |            for line = (read-line inf nil)
142 |            while line
143 |            do
144 |              (cl-ppcre:register-groups-bind (hour minute nick message)
145 |                  ("<span class=\"irc-date\">\\[(\\d+):(\\d+)\\]</span> <span class=\"irc-black\">&lt;([^[&_-]+)[^&]*&gt; (.*)</span><br />" line :sharedp t)
146 |                (when (and hour minute)
147 |                  (format ouf "[~2d:~2d] <~a> ~a~%"
148 |                          (parse-integer hour)
149 |                          (parse-integer minute)
150 |                          nick
151 |                          message)))
152 |              (cl-ppcre:register-groups-bind (hour minute message)
153 |                  ("<span class=\"irc-date\">\\[(\\d+):(\\d+)\\]</span> <span class=\"irc-brick\">(\\* .*)</span><br />" line :sharedp t)
154 |                (when (and hour minute)
155 |                  (format ouf "[~2d:~2d] ~a~%"
156 |                          (parse-integer hour)
157 |                          (parse-integer minute)
158 |                          message))))))))
159 | 


--------------------------------------------------------------------------------
/src/patches.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (defun make-socket-and-connect (server port)
  4 |   (let ((socket (iolib:make-socket :connect :active
  5 |                                    :address-family :internet
  6 |                                    :type :stream
  7 |                                    :ipv6 t)))
  8 |     (iolib:connect socket
  9 |                    (iolib:lookup-hostname server :ipv6 t)
 10 |                    :port port :wait t)
 11 |     socket))
 12 | 
 13 | (defun cl-irc::connect (&key (nickname cl-irc::*default-nickname*)
 14 |                           (username nil)
 15 |                           (realname nil)
 16 |                           (password nil)
 17 |                           (mode 0)
 18 |                           (server cl-irc::*default-irc-server*)
 19 |                           (port :default)
 20 |                           (connection-type 'nonblocking-connection)
 21 |                           (connection-security :none)
 22 |                           (logging-stream t))
 23 |   "Connect to server and return a connection object.
 24 | 
 25 | `port' and `connection-security' have a relation: when `port' equals
 26 | `:default' `*default-irc-server-port*' is used to find which port to
 27 | connect to.  `connection-security' determines which port number is found.
 28 | 
 29 | `connection-security' can be either `:none' or `:ssl'.  When passing
 30 | `:ssl', the cl+ssl library must have been loaded by the caller.
 31 | 
 32 | This version has been patched to use iolib instead of usocket.
 33 | "
 34 |   (let* ((port (if (eq port :default)
 35 |                    ;; get the default port for this type of connection
 36 |                    (getf cl-irc::*default-irc-server-port* connection-security)
 37 |                    port))
 38 |          (socket (make-socket-and-connect server port))
 39 |          (stream (if (eq connection-security :ssl)
 40 |                      (cl-irc::dynfound-funcall (cl-irc::make-ssl-client-stream :cl+ssl)
 41 |                                                (iolib:socket-os-fd socket)
 42 |                                                :unwrap-stream-p nil)
 43 |                      socket))
 44 |          (connection (make-connection :connection-type connection-type
 45 |                                       :network-stream stream
 46 |                                       :client-stream logging-stream
 47 |                                       :server-name server))
 48 |          (user (make-user connection
 49 |                           :nickname nickname
 50 |                           :username username
 51 |                           :realname realname)))
 52 |     (setf (cl-irc::socket connection) socket)
 53 |     (setf (iolib:socket-option socket :keep-alive) t)
 54 |     (setf (user connection) user)
 55 |     (unless (null password)
 56 |       (pass connection password))
 57 |     (nick connection nickname)
 58 |     (user- connection (or username nickname) mode (or realname nickname))
 59 |     (add-default-hooks connection)
 60 |     connection))
 61 | 
 62 | (defmethod cl-irc::default-hook ((message cl-irc::irc-rpl_topic-message))
 63 |   "Redefines the default hook for the topic reply message so that it
 64 | won't raise an error when one is received for an unknown channel"
 65 |   (destructuring-bind
 66 |         (target channel-name &optional topic)
 67 |       (arguments message)
 68 |     (declare (ignore target))
 69 |     (let* ((connection (cl-irc::connection message))
 70 |            (channel (cl-irc::find-channel connection channel-name)))
 71 |       (when channel
 72 |         (setf (cl-irc::topic channel) topic)))))
 73 | 
 74 | (defmethod cl-irc::irc-message-event (connection (message cl-irc::irc-message))
 75 |   "Redefines the standard IRC message-event handler so that it doesn't
 76 | log anything when it receives an unhandled event."
 77 |   (declare (ignore connection))
 78 |   (cl-irc::apply-to-hooks message))
 79 | 
 80 | (defclass nonblocking-connection (cl-irc::connection)
 81 |   ((cl-irc::socket :accessor cl-irc::socket :initform nil)
 82 |    (line-buffer :accessor line-buffer :initform (make-array '(0)
 83 |                                                              :adjustable t
 84 |                                                              :fill-pointer 0))))
 85 | 
 86 | (defun cl-irc::read-protocol-line (connection)
 87 |   "Reads a line from the input network stream, returning a
 88 | character array with the input read."
 89 |   (multiple-value-bind (buf buf-len incompletep)
 90 |       (cl-irc::read-sequence-until (network-stream connection)
 91 |                                    (make-array 1024
 92 |                                                :element-type '(unsigned-byte 8)
 93 |                                                :fill-pointer t)
 94 |                                    '(10)
 95 |                                    :non-blocking t)
 96 |     (let ((line-buffer (line-buffer connection)))
 97 |       (loop
 98 |          for c across buf
 99 |          for i upto (1- buf-len)
100 |          do (vector-push-extend c (line-buffer connection)))
101 | 
102 |       (unless incompletep
103 |         (setf (fill-pointer line-buffer)
104 |               ;; remove all trailing CR and LF characters
105 |               ;; (This allows non-conforming clients to send CRCRLF
106 |               ;;  as a line separator too).
107 |               (or (position-if #'(lambda (x) (member x '(10 13)))
108 |                                line-buffer :from-end t :end (fill-pointer line-buffer))
109 |                   (fill-pointer line-buffer)))
110 |         (prog1
111 |             (cl-irc::try-decode-line buf cl-irc::*default-incoming-external-formats*)
112 |           ;; Reset line-buffer once the line is decoded
113 |           (setf (fill-pointer line-buffer) 0))))))
114 | 
115 | (eval-when (:compile-toplevel :load-toplevel :execute)
116 |   (defparameter *new-reply-names*
117 |     '((900 :rpl_loggedin)
118 |       (901 :rpl_loggedout)
119 |       (902 :err_nicklocked)
120 |       (903 :rpl_saslsuccess)
121 |       (904 :err_saslfail)
122 |       (905 :err_sasltoolong)
123 |       (906 :err_saslaborted)
124 |       (907 :err_saslalready)
125 |       (908 :rpl_saslmechs)
126 |       (524 :err_helpnotfound)
127 |       (525 :err_invalidkey)
128 |       (670 :rpl_starttls)
129 |       (671 :rpl_whoissecure)
130 |       (691 :err_starttls)
131 |       (696 :err_invalidmodeparam)
132 |       (704 :rpl_helpstart)
133 |       (705 :rpl_helptxt)
134 |       (706 :rpl_endofhelp)
135 |       (723 :err_noprivs)
136 |       )))
137 | 
138 | 
139 | (in-package #:cl-irc)
140 | 
141 | (setf cl-irc::*reply-names* (append cl-irc::*reply-names* orcabot::*new-reply-names*))
142 | (cl-irc::create-irc-message-classes #.(mapcar #'second orcabot::*new-reply-names*))
143 | 


--------------------------------------------------------------------------------
/src/pick.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (defun save-pick-catalog (module)
  4 |   (with-open-file (ouf (data-path "pick-catalog.lisp")
  5 |                        :direction :output
  6 |                        :if-exists :supersede
  7 |                        :if-does-not-exist :create)
  8 |     (write (catalog-of module) :stream ouf)))
  9 | 
 10 | (defun load-pick-catalog (module)
 11 |   (with-open-file (inf (data-path "pick-catalog.lisp")
 12 |                        :if-does-not-exist nil)
 13 |     (setf (catalog-of module) (if inf (read inf nil) nil))))
 14 | 
 15 | (defmodule pick pick-module ("pick")
 16 |   (catalog :accessor catalog-of :initform nil))
 17 | 
 18 | (defmethod initialize-module ((module pick-module) config)
 19 |   (load-pick-catalog module))
 20 | 
 21 | (defun lookup-category (catalog category)
 22 |   (rest (assoc category catalog :test #'string-equal)))
 23 | 
 24 | (defun find-reference-cycles (catalog start category)
 25 |   (when (string-equal start category)
 26 |     (return-from find-reference-cycles t))
 27 |   (dolist (term (lookup-category catalog category))
 28 |     (when (or (string-equal start term)
 29 |               (find-reference-cycles catalog start term))
 30 |       (return t))))
 31 | 
 32 | (defun add-pick-choice (module message category choices)
 33 |   (when (find #\, category)
 34 |     (reply-to message "~a: Categories may not have commas in their names." (source message))
 35 |     (return-from add-pick-choice))
 36 |   
 37 |   (let ((bad-choices (remove-if-not (lambda (choice)
 38 |                                       (find-reference-cycles (catalog-of module) category choice))
 39 |                                     choices)))
 40 |     (when bad-choices
 41 |       (reply-to message "Ignoring choices that would cause a dependency cycle: ~{~a~^, ~}"
 42 |                 bad-choices))
 43 |     (setf choices (set-difference choices bad-choices)))
 44 | 
 45 |   (let ((tuple (assoc category (catalog-of module) :test #'string-equal)))
 46 |     (cond
 47 |       ((null choices)
 48 |        (reply-to message "No choices to add."))
 49 |       ((null tuple)
 50 |        (push (cons category choices) (catalog-of module))
 51 |        (save-pick-catalog module)
 52 |        (reply-to message "Category '~a' added with choices: ~{~a~^, ~}"
 53 |                  category
 54 |                  choices))
 55 |       (t
 56 |        (let* ((new-choices (set-difference choices (rest tuple) :test #'string=)))
 57 |          (cond
 58 |            (new-choices
 59 |             (setf (rest tuple) (append (rest tuple) new-choices))
 60 |             (save-pick-catalog module)
 61 |             (reply-to message "Added ~{~a~^, ~} to category '~a'" new-choices category))
 62 |            (t
 63 |             (reply-to message "No new choices added to category '~a'" category))))))))
 64 | 
 65 | (defun del-pick-choice (module message category choices)
 66 |   (cond
 67 |     ((null (assoc category
 68 |                   (catalog-of module)
 69 |                   :test #'string-equal))
 70 |      (reply-to message "Category '~a' does not exist." category))
 71 |     ((null choices)
 72 |      (let ((category-def (assoc category
 73 |                                 (catalog-of module)
 74 |                                 :test #'string-equal)))
 75 |        (setf (catalog-of module) (delete category-def (catalog-of module)))
 76 |        (save-pick-catalog module)
 77 |        (reply-to message "Category '~a': removed ~@[(~{~a~^, ~})~]"
 78 |                  (first category-def)
 79 |                  (rest category-def))))
 80 |     (t
 81 |      (let* ((category-def (assoc category
 82 |                                  (catalog-of module)
 83 |                                  :test #'string-equal))
 84 |             (doomed-picks (intersection choices
 85 |                                         (rest category-def)
 86 |                                         :test #'string-equal))
 87 |             (invalid-picks (set-difference choices
 88 |                                            (rest category-def)
 89 |                                            :test #'string-equal)))
 90 |        ;; Remove category if all picks are removed
 91 |        (cond
 92 |          ((subsetp (rest category-def) doomed-picks :test #'string-equal)
 93 |           (setf (catalog-of module) (delete category-def (catalog-of module)))
 94 |           (reply-to message "Category '~a': removed ~@[ (~{~a~^, ~})~]"
 95 |                     (first category-def)
 96 |                     (rest category-def)))
 97 |          (t
 98 |           (setf (rest category-def) (set-difference (rest category-def)
 99 |                                                     doomed-picks
100 |                                                     :test #'string-equal))
101 |           (reply-to message "Category '~a':~@[ removed ~{~a~^, ~}~]~:[~;, ~]~@[ ignored ~{~a~^, ~}~]"
102 |                     (first category-def)
103 |                     doomed-picks
104 |                     (and doomed-picks invalid-picks)
105 |                     invalid-picks)))
106 | 
107 |        (save-pick-catalog module)))))
108 | 
109 | (defmethod handle-command ((module pick-module)
110 |                            (cmd (eql 'pick))
111 |                            message raw-args)
112 |   ".pick <choice>, <choice> [,<choice>...] ) - selects randomly between choices
113 | .pick - lists categories from which to pick
114 | .pick <category> - selects random option in category
115 | .pick --show [<category>] - display list of categories or category contents
116 | .pick --add category <choice> - adds option to category
117 | .pick --del category <choice> - removes option from category
118 | "
119 |   (handler-case
120 |       (multiple-value-bind (opts args)
121 |           (parse-args '((:add . string)
122 |                         (:del . string)
123 |                         (:show . string))
124 |                       raw-args)
125 |         (let ((choices (re:split "\\s*,\\s*" (join-to-string " " args))))
126 |           (cond
127 |             ((getf opts :add)
128 |              (add-pick-choice module message (getf opts :add) choices))
129 |             ((getf opts :del)
130 |              (del-pick-choice module message (getf opts :del) choices))
131 |             ((getf opts :show)
132 |              (let ((category (getf opts :show)))
133 |                (if category
134 |                    (let ((terms (lookup-category (catalog-of module) (getf opts :show))))
135 |                      (if terms
136 |                          (reply-to message "Picks in category ~a: ~{~a~^, ~}" category terms)
137 |                          (reply-to message "~a is not a category." category)))
138 |                    (reply-to message "Pick categories: ~{~a~^, ~}"
139 |                              (mapcar #'first (catalog-of module))))))
140 |             ((endp choices)
141 |              (reply-to message "Pick categories: ~{~a~^, ~}"
142 |                        (mapcar #'first (catalog-of module))))
143 |             ((and (null (rest choices))
144 |                   (endp (lookup-category (catalog-of module) (first choices))))
145 |              ;; if there's only one choice given, it must be a category.
146 |              (reply-to message "~a is not a category." (first choices)))
147 |             (t
148 |              ;; otherwise, pick from categories and expand.
149 |              (let ((choice (random-elt choices)))
150 |                (loop for terms = (lookup-category (catalog-of module) choice)
151 |                      while terms do
152 |                        (setf choice (random-elt terms)))
153 |                (reply-to message "~a: I pick ~a!" (source message) choice))))))
154 |     (unexpected-argument-end (err)
155 |       (reply-to message "Option --~a requires an argument."
156 |                 (string-downcase (slot-value err 'option)))
157 |       (return-from handle-command))
158 |     (unknown-option (err)
159 |       (reply-to message "Unknown option ~a" (slot-value err 'option))
160 |       (return-from handle-command))))
161 | 


--------------------------------------------------------------------------------
/src/poetry.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | (defmodule poetry poetry-module ()
  4 |   (syllables :accessor syllables-of)
  5 |   (haiku-enabled-p :accessor haiku-enabled-p :initform nil)
  6 |   (tmnt-enabled-p :accessor tmnt-enabled-p :initform nil)
  7 |   (camptown-enabled-p :accessor camptown-enabled-p :initform nil))
  8 | 
  9 | (defmethod initialize-module ((module poetry-module) config)
 10 |   (setf (syllables-of module) (read-syllable-dict (static-path "syllable-dict.txt")))
 11 |   (let ((conf (getf (rest (assoc 'poetry config)) :enable)))
 12 |     (when conf
 13 |       (setf (haiku-enabled-p module) (member 'haiku conf))
 14 |       (setf (tmnt-enabled-p module) (member 'tmnt conf))
 15 |       (setf (camptown-enabled-p module) (member 'camptown conf)))))
 16 | 
 17 | (defparameter +tmnt-pattern+ "10101010")
 18 | (defparameter +camptown-pattern+ "1010101")
 19 | 
 20 | (defun read-syllable-dict (path)
 21 |   (let ((dict (make-hash-table :test 'equal)))
 22 |     (with-open-file (inf path)
 23 |       (loop
 24 |         for line = (read-line inf nil)
 25 |         while line
 26 |         unless (or (string= "" line)
 27 |                    (string= "#" line :end2 1))
 28 |           do
 29 |              (let ((word-pronounciation (ppcre:split " " line :limit 2)))
 30 |                (setf (gethash (string-downcase (first word-pronounciation)) dict)
 31 |                      (map 'string (lambda (c) (if (char= c #\2) #\. c)) ; secondary stress can be either
 32 |                           (remove-if-not #'digit-char-p ; remove pronounciation
 33 |                                          (second word-pronounciation)))))
 34 |         finally (return dict)))))
 35 | 
 36 | (defun lookup-syllables (dict word)
 37 |   (gethash (remove-if-not (lambda (c)
 38 |                             (or (alpha-char-p c)
 39 |                                 (find c "'")))
 40 |                           (string-downcase word))
 41 |            dict))
 42 | 
 43 | (defun string-to-pattern (dict s)
 44 |   (join-to-string ""
 45 |                   (loop for word in (ppcre:split "\\s" s)
 46 |                         as pattern = (lookup-syllables dict word)
 47 |                         collect (cond
 48 |                                   ((null pattern)
 49 |                                    ;; fail if a word can't be found.  We don't
 50 |                                    ;; want any false positives.
 51 |                                    (return-from string-to-pattern nil))
 52 |                                   ((= (length pattern) 1)
 53 |                                    ;; single words can match stressed or unstressed parts
 54 |                                    ".")
 55 |                                   (t
 56 |                                    pattern)))))
 57 | 
 58 | (defun pattern-matches-p (pattern text)
 59 |   (when (= (length pattern) (length text))
 60 |     (loop for pattern-char across pattern
 61 |           for text-char across text
 62 |           when (and (not (char= pattern-char #\.))
 63 |                     (not (char= text-char #\.))
 64 |                     (char/= pattern-char text-char))
 65 |             do (return nil)
 66 |           finally (return t))))
 67 | 
 68 | (defun consume-n-syllables (tuples n)
 69 |   (let* ((line (loop
 70 |                 for tuple on tuples
 71 |                 as total = (cdr (first tuple)) then (+ total (cdr (first tuple)))
 72 |                 while (< total n)
 73 |                 collect (car (pop tuples)) into consumed
 74 |                 finally (return (and (= total n)
 75 |                                      (append consumed (list (car (pop tuples)))))))))
 76 |     (values line tuples)))
 77 | 
 78 | (defun try-haiku (dict text)
 79 |   "Returns a string displaying the haiku if the text has words adding
 80 |   to 5 syllables, then 7, then 5."
 81 |   (let ((counts (loop for word in (ppcre:split "\\s" text)
 82 |                       collect (cons word (length (lookup-syllables dict word))))))
 83 |     (cond
 84 |       ((some (lambda (c) (zerop (cdr c))) counts)
 85 |        ;; no false positives
 86 |        (return-from try-haiku nil))
 87 |       ((/= (reduce '+ counts :key 'cdr) 17)
 88 |        ;; All haiku have 17 syllables
 89 |        (return-from try-haiku nil))
 90 |       (t
 91 |        (with-output-to-string (result)
 92 |          (let (words-done words-left)
 93 |            (multiple-value-setq (words-done words-left)
 94 |              (consume-n-syllables counts 5))
 95 |            (unless words-done
 96 |              (return-from try-haiku nil))
 97 |            (write-string (join-to-string " " words-done) result)
 98 |            (write-string " / " result)
 99 |            (multiple-value-setq (words-done words-left)
100 |              (consume-n-syllables words-left 7))
101 |            (unless words-done
102 |              (return-from try-haiku nil))
103 |            (write-string (join-to-string " " words-done) result)
104 |            (write-string " / " result)
105 |            (multiple-value-setq (words-done words-left)
106 |              (consume-n-syllables words-left 5))
107 |            (unless words-done
108 |              (return-from try-haiku nil))
109 |            (write-string (join-to-string " " words-done) result)))))))
110 | 
111 | (defmethod examine-message ((module poetry-module) (message irc:irc-privmsg-message))
112 |   ;; Haikus get first dibs.
113 |   (when (haiku-enabled-p module)
114 |     (let ((haiku (try-haiku (syllables-of module) (second (arguments message)))))
115 |       (when haiku
116 |         (log:log-message :info "[poetry] haiku found: ~a" haiku)
117 |         (reply-to message "~a made a haiku!  ~a" (source message) haiku)
118 |         (return-from examine-message))))
119 | 
120 |   (when (or (tmnt-enabled-p module)
121 |             (camptown-enabled-p module))
122 |    (dolist (sentence (ppcre:split " *[.?!] *" (second (arguments message))))
123 |      (let ((pattern (string-to-pattern (syllables-of module) sentence)))
124 |        (when pattern
125 |          (cond
126 |            ((and (tmnt-enabled-p module)
127 |                  (pattern-matches-p +tmnt-pattern+ pattern))
128 |             ;; TEENAGE MUTANT NINJA TURTLES
129 |             (log:log-message :info "[poetry] TMNT found: ~a" sentence)
130 |             (reply-to message "~a" (string-upcase sentence)))
131 |            ((and (camptown-enabled-p module)
132 |                  (pattern-matches-p +camptown-pattern+ pattern))
133 |             ;; Camptown ladies sing this song
134 |             (log:log-message :info "[poetry] Camptown ladies found: ~a" sentence)
135 |             (reply-to message "doo-dah doo-dah"))))))))
136 | 


--------------------------------------------------------------------------------
/src/quote.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule quote quote-module ("quote" "quotedb")
 18 |   (quotes :accessor quotes-of :initform nil))
 19 | 
 20 | (defmethod initialize-module ((module quote-module) config)
 21 |   (load-quotes module))
 22 | 
 23 | (defun load-quotes (module)
 24 |   (setf (quotes-of module) nil)
 25 |   (with-open-file (inf (data-path "quotes.lisp")
 26 |                        :direction :input
 27 |                        :if-does-not-exist nil)
 28 |     (when inf
 29 |       (setf (quotes-of module) (loop for entry in (read inf)
 30 |                                     as idx from 1
 31 |                                     collect (cons idx entry))))))
 32 | 
 33 | (defun save-quotes (module)
 34 |   (write-to-file (data-path "quotes.lisp") (mapcar #'cdr (quotes-of module))))
 35 | 
 36 | (defmethod handle-command ((module quote-module)
 37 |                            (cmd (eql 'quote))
 38 |                            message args)
 39 |   "quote [<new quote>] - add a quote or get a random quote"
 40 |   (cond
 41 |     (args
 42 |      (let ((idx (if (quotes-of module)
 43 |                     (1+ (loop
 44 |                            for entry in (quotes-of module)
 45 |                            maximize (car entry)))
 46 |                     1)))
 47 |        (push (cons idx (format nil "~{~a~^ ~}" args))
 48 |              (quotes-of module))
 49 |        (save-quotes module)
 50 |        (reply-to message "Quote #~d added." idx)))
 51 |     ((null (quotes-of module))
 52 |      (reply-to message "There are no recorded quotes."))
 53 |     (t
 54 |      (reply-to message "~a" (cdr (random-elt (quotes-of module)))))))
 55 | 
 56 | (defun quotedb-search (module message args &aux (max-quotes 5))
 57 |   (let ((patterns (mapcar (lambda (p)
 58 |                             (handler-case
 59 |                                 (re:create-scanner p :case-insensitive-mode t)
 60 |                               (re:ppcre-syntax-error (e)
 61 |                                 (reply-to message "Regex error: ~a" e)
 62 |                                 (return-from quotedb-search))))
 63 |                           (rest args)))
 64 |         (found 0))
 65 |     (loop
 66 |       for entry in (quotes-of module)
 67 |       when (every (lambda (p)
 68 |                     (re:scan p (cdr entry)))
 69 |                   patterns)
 70 |         do
 71 |            (incf found)
 72 |            (unless (and (message-target-is-channel-p message)
 73 |                         (> found max-quotes))
 74 |              (reply-to message "~d. ~a" (car entry) (cdr entry))))
 75 |     (cond
 76 |       ((zerop found)
 77 |        (reply-to message "No quotes found matching that pattern."))
 78 |       ((and (message-target-is-channel-p message)
 79 |             (> found max-quotes))
 80 |        (reply-to message "Found ~d quote~:p, but only displaying ~d.  Try providing more search terms or using a private message."
 81 |                  found max-quotes)))))
 82 | 
 83 | (defun quotedb-remove (module message args)
 84 |   (let ((doomed (loop
 85 |                   for arg in (rest args)
 86 |                   for idx = (parse-integer arg :junk-allowed t)
 87 |                   if (null idx)
 88 |                     do (reply-to message "'~a' is not a valid quote id." arg)
 89 |                   else if (not (find idx (quotes-of module) :key #'car))
 90 |                          do (reply-to message "No quote found with id '~a'." arg)
 91 |                   else
 92 |                     collect idx)))
 93 |     (cond
 94 |       (doomed
 95 |        (setf (quotes-of module)
 96 |              (sort
 97 |               (set-difference (quotes-of module) doomed :test (lambda (a b) (eql (car a) b)))
 98 |               #'< :key #'car))
 99 |        (save-quotes module)
100 |        (reply-to message "Quote~p ~{~#[~;~a~;~a and ~a~:;~@{~a~#[~;, and ~:;, ~]~}~]~} removed." (length doomed) doomed))
101 |       (t
102 |        (reply-to message "No quotes removed.")))))
103 | 
104 | (defun quotedb-show (module message args)
105 |   (let ((show-ids (loop
106 |                    for arg in (rest args)
107 |                    for idx = (parse-integer arg :junk-allowed t)
108 |                    if (null idx)
109 |                      do (reply-to message "'~a' is not a valid quote id." arg)
110 |                    else if (not (find idx (quotes-of module) :key #'car))
111 |                           do (reply-to message "No quote found with id '~a'." arg)
112 |                    else
113 |                      collect idx)))
114 |     (cond
115 |       (show-ids
116 |        (loop
117 |          for entry in (quotes-of module)
118 |          when (member (car entry) show-ids)
119 |            do
120 |               (reply-to message "~d. ~a" (car entry) (cdr entry))))
121 |       (t
122 |        (reply-to message "No matching quotes found.")))))
123 | 
124 | (defmethod handle-command ((module quote-module)
125 |                            (cmd (eql 'quotedb))
126 |                            message args)
127 |   "quotedb (reload|search|show|remove) - edit the quote database"
128 |   (cond
129 |     ((equal (first args) "reload")
130 |      (load-quotes module)
131 |      (reply-to message "Reloaded ~d quote~:p." (length (quotes-of module))))
132 |     ((equal (first args) "search")
133 |      (quotedb-search module message args))
134 |     ((equal (first args) "remove")
135 |      (quotedb-remove module message args))
136 |     ((equal (first args) "show")
137 |      (quotedb-show module message args))
138 |     (t
139 |      (reply-to message "Usage: quotedb (search <text>|remove <id#>)"))))
140 | 


--------------------------------------------------------------------------------
/src/reminder.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule reminder reminder-module ("remind")
18 |   (reminders :accessor reminders-of :initform nil))
19 | 
20 | (defclass reminder ()
21 |   ((nick :accessor nick-of :initarg :nick)
22 |    (time :accessor time-of :initarg :time)
23 |    (message :accessor message-of :initarg :message)
24 |    (timer :accessor timer-of :initarg :timer :initform nil)))
25 | 
26 | (defun load-reminders (module path)
27 |   (with-open-file (inf path :if-does-not-exist nil)
28 |     (when inf
29 |       (loop
30 |          with now = (get-universal-time)
31 |          for reminder-data in (read inf nil)
32 |          collect (apply 'make-reminder module now reminder-data)))))
33 | 
34 | (defun save-reminders (module)
35 |   (write-to-file (data-path "reminders.lisp")
36 |                  (mapcar
37 |                   (lambda (reminder)
38 |                     (list (nick-of reminder)
39 |                           (time-of reminder)
40 |                           (message-of reminder)))
41 |                   (reminders-of module))))
42 | 
43 | (defmethod initialize-module ((module reminder-module) config)
44 |   (setf (reminders-of module) (load-reminders module (data-path "reminders.lisp"))))
45 | 
46 | (defmethod deinitialize-module ((module reminder-module))
47 |   (mapc 'deschedule-reminder (reminders-of module)))
48 | 
49 | (defun emit-reminder (module reminder)
50 |   (cl-irc:privmsg (conn-of module)
51 |                   (nick-of reminder) (format nil "reminder: ~a" (message-of reminder)))
52 |   (setf (reminders-of module)
53 |         (delete reminder (reminders-of module)))
54 |   (save-reminders module))
55 | 
56 | (defun make-reminder (module now nick time message)
57 |   (let ((reminder (make-instance 'reminder
58 |                                  :nick nick
59 |                                  :time time
60 |                                  :message message)))
61 |     (prog1 reminder
62 |       (setf (timer-of reminder)
63 |             (iolib:add-timer *event-base*
64 |                              (lambda ()
65 |                                (emit-reminder module reminder))
66 |                              (max (- time now) 1)
67 |                              :one-shot t))
68 |       (save-reminders module))))
69 | 
70 | 
71 | (defun deschedule-reminder (reminder)
72 |   (iolib:remove-timer *event-base* (timer-of reminder)))
73 | 
74 | (defmethod handle-command ((module reminder-module)
75 |                            (cmd (eql 'remind))
76 |                            message args)
77 |   "remind <time> <message> - send me a message after some time has passed"
78 |   (cond
79 |     ((null (cdr args))
80 |      (reply-to message "Usage: remind <time> <message>"))
81 |     (t
82 |      (let ((reminder-time (parse-expire-time (first args))))
83 |        (cond
84 |          ((null reminder-time)
85 |           (reply-to message "Didn't understand ~a as an amount of time" (first args)))
86 |          (t
87 |           (let ((now (get-universal-time)))
88 |             (push (make-reminder module
89 |                                  now
90 |                                  (source message)
91 |                                  (+ now reminder-time)
92 |                                  (format nil "~{~a~^ ~}" (rest args)))
93 |                   (reminders-of module)))
94 |           (save-reminders module)
95 |           (reply-to message "Okay, I'll remind you in ~a." (describe-duration reminder-time))))))))
96 | 


--------------------------------------------------------------------------------
/src/rt.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule rt rt-module ("tix")
 18 |   (cookies :reader cookies-of :initform (make-instance 'drakma:cookie-jar))
 19 |   (base-url :accessor base-url-of))
 20 | 
 21 | (defun tix-login (module)
 22 |   (let ((creds (authentication-credentials (puri:uri-host (puri:uri (base-url-of module))))))
 23 |     (drakma:http-request (format nil "~a/index.html" (base-url-of module))
 24 |                          :method :post
 25 |                          :parameters `(("user" . ,(getf creds :login))
 26 |                                        ("pass" . ,(getf creds :password)))
 27 |                          :cookie-jar (cookies-of module)
 28 |                          :redirect 10)))
 29 | 
 30 | (defun scrape-tix-subject (response)
 31 |   (let ((match (nth-value 1 (cl-ppcre:scan-to-strings
 32 |                              "<title>#\\d+: (.*)</title>"
 33 |                              response))))
 34 |     (and match (plump:decode-entities (aref match 0)))))
 35 | 
 36 | (defun scrape-tix-owner (response)
 37 |   (let ((match (nth-value 1 (cl-ppcre:scan-to-strings
 38 |                              (cl-ppcre:parse-string "<td class=\"label\">Owner:</td>\\s*<td class=\"value\">\\s*(\\S+)")
 39 |                              response))))
 40 |     (and match (plump:decode-entities (aref match 0)))))
 41 | 
 42 | (defun scrape-tix-status (response)
 43 |   (let ((match (nth-value 1 (cl-ppcre:scan-to-strings
 44 |                              "<td class=\"value status\">([^<]+)</td>"
 45 |                              response))))
 46 |     (and match (plump:decode-entities (aref match 0)))))
 47 | 
 48 | (defun retrieve-tix-info (module tix)
 49 |   (unless (drakma:cookie-jar-cookies (cookies-of module))
 50 |     (tix-login module))
 51 |   (multiple-value-bind (response status)
 52 |       (drakma:http-request
 53 |        (format nil "~a/Ticket/Display.html" (base-url-of module))
 54 |        :parameters `(("id" . ,tix))
 55 |        :cookie-jar (cookies-of module))
 56 |     (cond
 57 |       ((/= status 200)
 58 |        nil)
 59 |       ((cl-ppcre:scan "<title>Login</title>" response)
 60 |        (tix-login module)
 61 |        (retrieve-tix-info module tix))
 62 |       (t
 63 |        (values
 64 |         (scrape-tix-subject response)
 65 |         (scrape-tix-owner response)
 66 |         (scrape-tix-status response))))))
 67 | 
 68 | (defun lookup-all-tix (module message tix-numbers)
 69 |   (let ((match-found nil))
 70 |     (dolist (tixnum (remove-duplicates tix-numbers :test #'string=))
 71 |       (multiple-value-bind (subject owner status)
 72 |           (retrieve-tix-info module tixnum)
 73 |         (cond
 74 |           (subject
 75 |             (reply-to message
 76 |                       "tix #~a is ~a [~a/~a] [~a/Ticket/Display.html?id=~a]"
 77 |                       tixnum subject owner status (base-url-of module) tixnum)
 78 |             (setf match-found t))
 79 |           (t
 80 |            (reply-to message "tix #~a doesn't seem to exist" tixnum)))))
 81 |     match-found))
 82 | 
 83 | (defun implicit-tix-lookup (module message)
 84 |   (let ((tixnums (all-matches-register
 85 |                   (ppcre:create-scanner "\\b(?:ticket|tix|cr)[: #]+(\\d{6,})\\b"
 86 |                                         :case-insensitive-mode t)
 87 |                   (second (arguments message))
 88 |                   0
 89 |                   :sharedp t)))
 90 |     (dolist (tixnum (remove-duplicates tixnums :test #'string=))
 91 |       (multiple-value-bind (subject owner status)
 92 |           (retrieve-tix-info module tixnum)
 93 |         (when subject
 94 |           (reply-to message
 95 |                     "tix #~a is ~a [~a/~a] ~a/Ticket/Display.html?id=~a"
 96 |                     tixnum subject owner status (base-url-of module) tixnum))))))
 97 | 
 98 | (defmethod initialize-module ((module rt-module) config)
 99 |   (let ((module-conf (rest (assoc 'rt config))))
100 |     (setf (base-url-of module) (string-right-trim "/" (getf module-conf :base-url)))))
101 | 
102 | (defmethod handle-message ((module rt-module)
103 |                            (message irc:irc-privmsg-message))
104 |   (implicit-tix-lookup module message)
105 |   nil)
106 | 
107 | (defmethod handle-command ((module rt-module) (cmd (eql 'tix)) message args)
108 |   "tix <tix number> - show a link to a RT ticket"
109 |   (let* ((tixnums (if (string-equal (first args) "topic")
110 |                       (all-matches-register "#?(\\d{6,})"
111 |                                             (topic (find-channel (connection message)
112 |                                                                  (first (arguments message)))) 0
113 |                                                                  :sharedp t)
114 |                       args)))
115 | 
116 |     (cond
117 |       ((null tixnums)
118 |        (reply-to message "I'd rather have a tix number >100,000."))
119 |       (t
120 |        (lookup-all-tix module message tixnums)))))
121 | 


--------------------------------------------------------------------------------
/src/stock.lisp:
--------------------------------------------------------------------------------
 1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
 2 | ;;;
 3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
 4 | ;;; you may not use this file except in compliance with the License.
 5 | ;;; You may obtain a copy of the License at
 6 | ;;;
 7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
 8 | ;;;
 9 | ;;; Unless required by applicable law or agreed to in writing, software
10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 | ;;; See the License for the specific language governing permissions and
13 | ;;; limitations under the License.
14 | 
15 | (in-package #:orcabot)
16 | 
17 | (defmodule stock stock-module ("stock")
18 |   (api-key :accessor api-key-of :initform nil))
19 | 
20 | (defmethod initialize-module ((module stock-module) config)
21 |   (let ((module-conf (rest (assoc 'stock config))))
22 |     (setf (api-key-of module) (getf module-conf :api-key)))
23 | 
24 |   (when (null (api-key-of module))
25 |     (log:log-message :warning "WARNING: Missing API key for STOCK module~%")))
26 | 
27 | (defun valid-stock-symbol-p (str)
28 |   (every (lambda (c)
29 |            (or (alpha-char-p c)
30 |                (eql c #\^))) str))
31 | 
32 | (defun stock-quote-retriever (api-key)
33 |   (lambda (symbol)
34 |     (multiple-value-bind (response status)
35 |         (drakma:http-request "https://www.alphavantage.co/query"
36 |                              :parameters `(("function" . "TIME_SERIES_DAILY")
37 |                                            ("symbol" . ,symbol)
38 |                                            ("apikey" . ,api-key)
39 |                                            ("datatype" . "csv")))
40 |       (when (= status 200)
41 |         (destructuring-bind (date open high low closing volume)
42 |             ;; first record is headers, second record is most recent day
43 |             (second (cl-csv:read-csv (babel:octets-to-string response)))
44 |           (declare (ignore high low volume))
45 |           (let ((closing (parse-integer closing :junk-allowed t))
46 |                 (open (parse-integer open :junk-allowed t)))
47 |             (list
48 |              date
49 |              (string-upcase symbol)
50 |              closing
51 |              (float (/ (* 100 (- closing open)) open)))))))))
52 | 
53 | (defun retrieve-stock-quotes (api-key symbols)
54 |   (mapcar (stock-quote-retriever api-key) symbols))
55 | 
56 | (defmethod handle-command ((module stock-module)
57 |                            (cmd (eql 'stock))
58 |                            message args)
59 |   "stock <symbol> - grab the latest price of a stock"
60 |   (let ((symbols (or args '("GOOG"))))
61 |     (cond
62 |       ((null (api-key-of module))
63 |        (reply-to message "API key not set."))
64 |       ((notevery 'valid-stock-symbol-p symbols)
65 |        (let ((bad-arg (find-if-not 'valid-stock-symbol-p args)))
66 |          (reply-to message "Invalid stock symbol ~a" bad-arg)))
67 |       ((> (length symbols) 5)
68 |        (reply-to message "OMG! Too many ticker symbols!"))
69 |       (t
70 |        (let ((quote-list (retrieve-stock-quotes (api-key-of module) symbols)))
71 |          (reply-to message "~:{~a ~a: ~a (~,2@f%)~%~}" quote-list))))))
72 | 


--------------------------------------------------------------------------------
/src/strings.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:orcabot)
  2 | 
  3 | ;;; utilities that only deal with strings
  4 | 
  5 | (defun join-to-string (delimiter seq)
  6 |   "Returns a string with the printed elements of SEQ seperated by the
  7 | printed elements of DELIMITER."
  8 |   ;; quick check for zero-length list, avoiding the call to LENGTH
  9 |   (when (endp seq)
 10 |     (return-from join-to-string ""))
 11 |   
 12 |   (let ((seq-len (length seq)))
 13 |     ;; quick check for zero-length sequence before we do anything else
 14 |     (when (zerop seq-len)
 15 |       (return-from join-to-string ""))
 16 | 
 17 |     (let* ((del-len (length delimiter))
 18 |            (total-seq-len (reduce #'+ seq :key #'length :initial-value 0))
 19 |            (result (make-string (+ total-seq-len
 20 |                                    (* (1- seq-len) del-len)))))
 21 |       (cond
 22 |         ((consp seq)
 23 |          (loop
 24 |            with offset = 0
 25 |            for el-cons on seq
 26 |            as el = (car el-cons)
 27 |            do
 28 |               (replace result el :start1 offset)
 29 |               (incf offset (length el))
 30 |               (when (cdr el-cons)
 31 |                 (replace result delimiter :start1 offset)
 32 |                 (incf offset del-len)))
 33 |          result)
 34 |         (t
 35 |          (loop
 36 |            with offset = 0
 37 |            for idx from 0 upto (- seq-len 2)
 38 |            as el = (elt seq idx)
 39 |            do
 40 |               (replace result el :start1 offset)
 41 |               (incf offset (length el))
 42 |               (replace result delimiter :start1 offset)
 43 |               (incf offset del-len)
 44 |            finally (replace result (elt seq (1- seq-len)) :start1 offset))
 45 |          result)))))
 46 | 
 47 | (defun strip-html (str)
 48 |   (ppcre:regex-replace-all "<.*?>" str ""))
 49 | 
 50 | (defun string-limit (str max-len)
 51 |   (string-trim '(#\space)
 52 |                (if (< (length str) max-len)
 53 |                    str
 54 |                    (let ((pivot (position-if-not #'alphanumericp
 55 |                                                  str
 56 |                                                  :from-end t
 57 |                                                  :end max-len)))
 58 |                      (concatenate 'string
 59 |                                   (subseq str 0 (or pivot max-len))
 60 |                                   "...")))))
 61 | 
 62 | (defun wrap-string (string width)
 63 |   "Given an initial string, returns the string broken up into lines breaking on word boundaries."
 64 |   (loop
 65 |      for raw-wrap-pos = width then (+ wrap-pos width)
 66 |      until (> raw-wrap-pos (length string))
 67 |      for wrap-pos = (or (position-if-not #'alpha-char-p string :end raw-wrap-pos :from-end t)
 68 |                         raw-wrap-pos)
 69 |      for start-pos = 0 then (1+ wrap-pos)
 70 |      collect (string-trim " " (subseq string start-pos wrap-pos))
 71 |      into result
 72 |      finally (return (nconc result
 73 |                             (list (string-trim " "
 74 |                                                (subseq string (or wrap-pos 0))))))))
 75 | 
 76 | (defun all-matches-register (regex target-string register
 77 |                              &key (start 0)
 78 |                              (end (length target-string))
 79 |                              (sharedp nil))
 80 |   (let ((substr-fn (if sharedp #'ppcre::nsubseq #'subseq))
 81 |         (result-list nil))
 82 |       (ppcre:do-scans (start end reg-start reg-end
 83 |                              regex target-string
 84 |                              result-list
 85 |                              :start start :end end)
 86 |         (push (funcall substr-fn
 87 |                        target-string
 88 |                        (aref reg-start register)
 89 |                        (aref reg-end register))
 90 |               result-list))))
 91 | 
 92 | (defun switch-person (str)
 93 |   (cl-ppcre:regex-replace-all
 94 |    (cl-ppcre:create-scanner "\\b(mine|me|my|I am|I'm|I|you are|you're|yours|your|you)\\b" :case-insensitive-mode t)
 95 |    str
 96 |    (lambda (target start end match-start match-end reg-starts reg-ends)
 97 |      (declare (ignore start end reg-starts reg-ends))
 98 |      (alexandria:switch (target :test (lambda (a b)
 99 |                                         (string-equal a b
100 |                                                       :start1 match-start
101 |                                                       :end1 match-end)))
102 |        ("I" "you")
103 |        ("me" "you")
104 |        ("my" "your")
105 |        ("I am" "you are")
106 |        ("I'm" "you're")
107 |        ("mine" "yours")
108 |        ("you" "I")
109 |        ("you" "me")
110 |        ("your" "my")
111 |        ("you are" "I am")
112 |        ("you're" "I'm")
113 |        ("yours" "mine")))))
114 | 
115 | (define-condition unknown-option (parse-error)
116 |   ((option :initarg :option)))
117 | 
118 | (define-condition unexpected-argument-end (parse-error)
119 |   ((option :initarg :option)))
120 | 
121 | (define-condition invalid-option (parse-error)
122 |   ((option :initarg :option)
123 |    (bad-value :initarg :bad-value)))
124 | 
125 | (define-condition invalid-option-type (error)
126 |   ((option :initarg :option)))
127 | 
128 | (defun extract-option (arg)
129 |   "Parses strings of form \"foo\", \"--foo\", and \"--foo=bar\".  Returns three values - the first is T when the string is an option, otherwise NIL.  The second value is the option name, the third is the value of the option, or NIL if the value was not specified."
130 |   (let ((raw-option (when (and (string/= "" arg)
131 |                                (member (char arg 0) '(#\- #\em_dash)))
132 |                       (string-left-trim '(#\- #\em_dash) arg))))
133 |     (unless raw-option
134 |       (return-from extract-option nil))
135 | 
136 |     (let* ((equals-pos (position #\= raw-option))
137 |            (opt-name (if equals-pos
138 |                          (subseq raw-option 0 equals-pos)
139 |                          raw-option))
140 |            (opt-value (if equals-pos
141 |                           (subseq raw-option (1+ equals-pos))
142 |                           nil)))
143 |       (values t opt-name opt-value))))
144 | 
145 | (defun parse-args (spec raw-args)
146 |   "Given a spec in the format ((OPTION . TYPE) ...), parses a list of
147 | arguments and returns two values: a property list of the option values
148 | and a list of the positional arguments.  May raise conditions
149 | UNKNOWN-OPTION, UNEXPECTED-ARGUMENT-END, or INVALID-OPTION-TYPE."
150 |   (let ((opts nil)
151 |         (args nil))
152 |     (labels ((string-value (arg)
153 |                (when (null arg)
154 |                  (error 'unexpected-argument-end
155 |                         :option (first opts)))
156 |                (push arg opts)
157 |                #'option-arg-or-end)
158 |              (integer-value (arg)
159 |                (when (null arg)
160 |                  (error 'unexpected-argument-end
161 |                         :option (first opts)))
162 |                (handler-case
163 |                    (push (parse-integer arg) opts)
164 |                  (parse-error (err)
165 |                    (declare (ignore err))
166 |                    (error 'invalid-option
167 |                           :option (first opts)
168 |                           :bad-value arg)))
169 |                #'option-arg-or-end)
170 |              (arg-or-end (arg)
171 |                (unless (null arg)
172 |                  (push arg args)
173 |                  #'arg-or-end))
174 |              (option-arg-or-end (arg)
175 |                (unless (null arg)
176 |                  (multiple-value-bind (optionp opt-name opt-value)
177 |                      (extract-option arg)
178 |                    (cond
179 |                      ((null optionp)
180 |                       (push arg args)
181 |                       #'option-arg-or-end)
182 |                      ((string= opt-name "")
183 |                       #'arg-or-end)
184 |                      (t
185 |                       (let ((opt-spec (assoc opt-name spec :key #'symbol-name :test #'string-equal)))
186 |                         (when (null opt-spec)
187 |                           (signal 'unknown-option :option arg))
188 |                         (push (car opt-spec) opts)
189 |                         (case (cdr opt-spec)
190 |                           (boolean
191 |                            (push t opts)
192 |                            #'option-arg-or-end)
193 |                           (string
194 |                            (if opt-value
195 |                                (string-value opt-value)
196 |                                #'string-value))
197 |                           (integer
198 |                            (if opt-value
199 |                                (integer-value opt-value)
200 |                                #'integer-value))
201 |                           (t
202 |                            (error 'invalid-option-type
203 |                                   :option (car opt-spec)))))))))))
204 |       (loop
205 |          with expect = #'option-arg-or-end
206 |          until (null expect)
207 |          do
208 |            (setf expect (funcall expect (pop raw-args)))))
209 |     (values (reverse opts) (reverse args))))
210 | 


--------------------------------------------------------------------------------
/src/subversion.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule subversion subversion-module ("svn")
 18 |   (repo-url :accessor repo-url-of)
 19 |   (trac-url :accessor trac-url-of))
 20 | 
 21 | (defun retrieve-svn-log (module rev)
 22 |   (let* ((creds (authentication-credentials (puri:uri-host (puri:uri (repo-url-of module)))))
 23 |          (log (with-output-to-string (str)
 24 |                (sb-ext:run-program "/usr/bin/svn"
 25 |                                    `("log" "-r" ,rev
 26 |                                            ,@(when (getf creds :login)
 27 |                                                    (list "--username" (getf creds :login)))
 28 |                                            ,@(when (getf creds :password)
 29 |                                                    (list "--password" (getf creds :password)))
 30 |                                            "--non-interactive"
 31 |                                            "--no-auth-cache"
 32 |                                            ,(repo-url-of module))
 33 |                                    :input nil :output str))))
 34 |     (ppcre:register-groups-bind (user message)
 35 |         ((ppcre:create-scanner "-+\\nr\\d+ \\| (.*) \\| [^(]+\\([^)]+\\) \\| \\d+ lines?\\n\\n(.*?)^-{70,}" :single-line-mode t :multi-line-mode t)
 36 |          log)
 37 |       (format nil "~a - ~a" user
 38 |               (string-limit (substitute #\space #\newline message) 160)))))
 39 | 
 40 | (defun retrieve-svn-last-commit-log (module path)
 41 |   (let* ((creds (authentication-credentials (puri:uri-host (puri:uri (repo-url-of module)))))
 42 |          (log (with-output-to-string (str)
 43 |                 (sb-ext:run-program "/usr/bin/svn"
 44 |                                     `("log" "--limit" "1"
 45 |                                             ,@(when (getf creds :login)
 46 |                                                     (list "--username" (getf creds :login)))
 47 |                                             ,@(when (getf creds :password)
 48 |                                                     (list "--password" (getf creds :password)))
 49 |                                             "--non-interactive"
 50 |                                             "--no-auth-cache"
 51 |                                             ,(concatenate 'string (repo-url-of module) path))
 52 |                                     :input nil :output str))))
 53 |     (ppcre:register-groups-bind (rev user message)
 54 |                                 ((ppcre:create-scanner "-+\\nr(\\d+) \\| (.*) \\| [^(]+\\([^)]+\\) \\| \\d+ lines?\\n\\n(.*?)^-{70,}" :single-line-mode t :multi-line-mode t)
 55 |                                  log)
 56 |                                 (format nil "r~a - ~a - ~a ~a/changeset/~a" rev user
 57 |                                         (string-limit (substitute #\space #\newline message) 160)
 58 |                                         (trac-url-of module)
 59 |                                         rev))))
 60 | 
 61 | (defun lookup-all-svn (module message rev-numbers)
 62 |   (let ((match-found nil))
 63 |     (dolist (rev (remove-duplicates rev-numbers :test #'string=))
 64 |       (multiple-value-bind (match regs)
 65 |           (ppcre:scan-to-strings "[#r]?(\\d+)" rev)
 66 |         (cond
 67 |           (match
 68 |               (let ((subject (retrieve-svn-log module (aref regs 0))))
 69 |                 (if subject
 70 |                     (reply-to message
 71 |                               "svn r~a is ~a ~a/changeset/~a"
 72 |                               (aref regs 0) subject (trac-url-of module) (aref regs 0))
 73 |                     (reply-to message "SVN r~a doesn't seem to exist" (aref regs 0)))))
 74 |           (t
 75 |            (let ((info (retrieve-svn-last-commit-log module rev)))
 76 |              (if info
 77 |                 (reply-to message
 78 |                           "~a last modified ~a"
 79 |                           rev info)
 80 |                 (reply-to message "I'd rather have a revision number or path.")))))))
 81 |     match-found))
 82 | 
 83 | (defmethod initialize-module ((module subversion-module) config)
 84 |   (let ((module-conf (rest (assoc 'subversion config))))
 85 |     (setf (repo-url-of module) (getf module-conf :repo-url))
 86 |     (setf (trac-url-of module) (string-right-trim "/" (getf module-conf :trac-url)))))
 87 | 
 88 | (defmethod handle-message ((module subversion-module) (message irc:irc-privmsg-message))
 89 |   (dolist (revnum (all-matches-register
 90 |                    (ppcre:create-scanner "(?:[^a-zA-Z0-9-]|^)(?:svn [:#]*|r)(\\d{6,})(?:$|[^\\d-])"
 91 |                                          :case-insensitive-mode t)
 92 |                    (second (arguments message)) 0
 93 |                    :sharedp t))
 94 |     (let ((subject (retrieve-svn-log module revnum)))
 95 |       (when subject
 96 |           (reply-to message
 97 |                     "svn r~a is ~a ~a/changeset/~a"
 98 |                     revnum subject (trac-url-of module) revnum))))
 99 |   nil)
100 | 
101 | (defmethod handle-command ((module subversion-module) (cmd (eql 'svn))
102 |                            message
103 |                            args)
104 |   "svn <revision number/path> - show a link to an subversion revision"
105 |   (let* ((revnums (if (string-equal (first args) "topic")
106 |                       (all-matches-register "r(\\d+)"
107 |                                             (topic (find-channel (connection message)
108 |                                                                  (first (arguments message)))) 0
109 |                                                                  :sharedp t)
110 |                       args)))
111 | 
112 |     (cond
113 |       ((null revnums)
114 |        (reply-to message "I'd rather have a revision number or path"))
115 |       (t
116 |        (lookup-all-svn module message revnums)))))
117 | 


--------------------------------------------------------------------------------
/src/utils.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defvar *orcabot-data-root-pathname* nil)
 18 | (defparameter *orcabot-static-root-pathname*
 19 |   (merge-pathnames #p"data/"
 20 |                    (asdf:component-pathname (asdf:find-system "orcabot"))))
 21 | 
 22 | (define-condition keepalive-failed () ())
 23 | (define-condition orcabot-rebooting () ())
 24 | (define-condition orcabot-exiting () ())
 25 | (define-condition no-such-module (error) ())
 26 | 
 27 | (defvar *command-funcs* (make-hash-table :test 'equalp))
 28 | 
 29 | (defun static-path (filename)
 30 |   "Returns a pathname referring to the static data directory in the
 31 | project root."
 32 |   (merge-pathnames filename *orcabot-static-root-pathname*))
 33 | 
 34 | (defun data-path (filename)
 35 |   "Returns a pathname within the data directory specified at startup."
 36 |   (merge-pathnames filename *orcabot-data-root-pathname*))
 37 | 
 38 | (defun write-to-file (path object)
 39 |   (with-open-file (ouf (data-path path)
 40 |                        :direction :output
 41 |                        :if-exists :supersede
 42 |                        :if-does-not-exist :create)
 43 |     (write object :stream ouf)
 44 |     (terpri ouf)))
 45 | 
 46 | (defun http-to-file (url path)
 47 |   (let ((inf (drakma:http-request url :want-stream t)))
 48 |     (when inf
 49 |       (let ((byte-stream (flexi-streams:flexi-stream-stream inf)))
 50 |         (with-open-file (ouf path
 51 |                              :element-type '(unsigned-byte 8)
 52 |                              :direction :output
 53 |                              :if-exists :supersede
 54 |                              :if-does-not-exist :create)
 55 |           (loop
 56 |              with buf = (make-array #x2000 :element-type '(unsigned-byte 8))
 57 |              for read-bytes = (read-sequence buf byte-stream)
 58 |              while (= read-bytes #x2000)
 59 |              do (write-sequence buf ouf)
 60 |              finally (write-sequence buf ouf :end read-bytes))))
 61 |       t)))
 62 | 
 63 | (defun action-to (message fmt &rest args)
 64 |   (let* ((raw-response (format nil "~?" fmt args))
 65 |          (raw-response-lines (ppcre:split "\\n" raw-response))
 66 |          (responses (mapcan (lambda (line)
 67 |                               (wrap-string line 405))
 68 |                             raw-response-lines)))
 69 |     (cond
 70 |       ((message-target-is-channel-p message)
 71 |        (dolist (line responses)
 72 |          (when (string/= line "")
 73 |            (irc::action (connection message) (first (arguments message)) line))))
 74 |       (t
 75 |        (dolist (line responses)
 76 |          (when (string/= line "")
 77 |            (irc::action (connection message) (source message) line)))))))
 78 | 
 79 | (defun reply-to (message fmt &rest args)
 80 |   (let* ((raw-response (format nil "~?" fmt args))
 81 |          (raw-response-lines (ppcre:split "\\n" raw-response))
 82 |          (responses (mapcan (lambda (line)
 83 |                               (wrap-string line 405))
 84 |                             raw-response-lines)))
 85 |     (cond
 86 |       ((message-target-is-channel-p message)
 87 |        (dolist (line responses)
 88 |          (when (string/= line "")
 89 |            (irc:privmsg (connection message) (first (arguments message)) line))))
 90 |       (t
 91 |        (dolist (line responses)
 92 |          (when (string/= line "")
 93 |            (irc:privmsg (connection message) (source message) line)))))))
 94 | 
 95 | (defun authentication-credentials (host)
 96 |   (flet ((read-word (stream)
 97 |            (when (peek-char t stream nil)
 98 |              (with-output-to-string (s)
 99 |                (loop
100 |                   for c = (read-char stream nil)
101 |                   while (and c
102 |                              (char/= c #\newline)
103 |                              (char/= c #\space)) do
104 |                     (princ c s))))))
105 |     (let ((found-machine nil)
106 |           (result nil))
107 |       (with-open-file (inf (merge-pathnames (user-homedir-pathname)
108 |                                             ".netrc")
109 |                            :direction :input
110 |                            :if-does-not-exist nil)
111 |         (when inf
112 |           (loop
113 |              for key = (read-word inf)
114 |              as val = (read-word inf)
115 |              while val do
116 |              (cond
117 |                ((string-equal key "machine")
118 |                 (setf found-machine (string-equal val host)))
119 |                (found-machine
120 |                 (push val result)
121 |                 (push (intern (string-upcase key) :keyword) result)))))
122 |         result))))
123 | 
124 | (defun shorten-nick (full-nick)
125 |   (ppcre:scan-to-strings "[A-Za-z]+" full-nick))
126 | 
127 | (defun valid-nick-p (nick)
128 |   (and (ppcre:scan "^[A-Za-z_\\{}[\\]^`|][A-Za-z_\\{}[\\]^`|0-9-]\*$" nick)
129 |        t))
130 | 
131 | (defun irc-downcase (s)
132 |   "Downcase the string using special IRC rules, as specified in section 2.2 of RFC 2812."
133 |   (map 'string
134 |        (lambda (c)
135 |          (case c
136 |            (#\[ #\{)
137 |            (#\] #\})
138 |            (#\\ #\|)
139 |            (#\~ #\^)
140 |            (t
141 |             (char-downcase c))))
142 |        s))
143 | 
144 | (defun irc-string-equal (a b)
145 |   "Compare nicks for equality using specially downcased versions of the nicks."
146 |   (string= (irc-downcase a) (irc-downcase b)))
147 | 
148 | (defun normalize-nick (nick)
149 |   "Remove trailing numbers and everything after an underscore or dash, then
150 | downcase what is left. Used for comparing nicks for equality."
151 |   (irc-downcase (ppcre:regex-replace "(?:[-_].*|\\d+$)" nick "")))
152 | 
153 | (defun message-target-is-channel-p (message)
154 |   (find (char (first (arguments message)) 0) "#+"))
155 | 
156 | (defun make-random-list (length max)
157 |   "Generate a non-repeating list of random numbers of length LENGTH.  The maxim\
158 | um value of the random numbers is MAX - 1."
159 |   (declare (fixnum length max))
160 |   (unless (plusp length)
161 |     (error "LENGTH may not be negative."))
162 |   (unless (plusp max)
163 |     (error "Can't generate negative numbers."))
164 |   (unless (<= length max)
165 |     (error "Can't generate a non-repeating list when LENGTH > MAX"))
166 |   (let ((unused (make-array max :element-type 'fixnum)))
167 |     ;; create an array with each element set to its index
168 |     (dotimes (idx max)
169 |       (setf (aref unused idx) idx))
170 |     ;; select a random index to pull from the array, then set the number
171 |     ;; at the index to the last selectable element in the array.  Continue
172 |     ;; until we have the requisite list length
173 |     (loop for result-size from 0 upto (1- length)
174 |           as num = (random (- max result-size))
175 |           collect (aref unused num)
176 |           do (setf (aref unused num) (aref unused (- max result-size 1))))))
177 | 
178 | (defun describe-duration (span)
179 |   (cond
180 |     ((>= span 86400)
181 |      (format nil "~ad" (round span 86400)))
182 |     ((>= span 3600)
183 |      (format nil "~ah" (round span 3600)))
184 |     ((>= span 60)
185 |      (format nil "~am" (round span 60)))
186 |     (t
187 |      (format nil "~as" span))))
188 | 
189 | (defun parse-expire-time (str)
190 |   (or
191 |    (multiple-value-bind (match regs)
192 |        (cl-ppcre:scan-to-strings "^(\\d+)([dhms]?)$" str)
193 |      (when match
194 |        (let ((num (parse-integer (aref regs 0))))
195 |          (if (zerop (length (aref regs 1)))
196 |              (* num 60)
197 |              (ecase (char (aref regs 1) 0)
198 |                (#\d (* num 86400))
199 |                (#\h (* num 3600))
200 |                (#\m (* num 60))
201 |                (#\s num))))))
202 |    (let* ((now (local-time:now))
203 |           (parsed-ts (chronicity:parse str
204 |                                        :context :future
205 |                                        :now now
206 |                                        :endian-preference :middle
207 |                                        :guess :middle
208 |                                        :ambiguous-time-range 8)))
209 |      (when (and parsed-ts
210 |                 (timestamp< now parsed-ts))
211 |        (local-time:timestamp-difference parsed-ts now)))))
212 | 


--------------------------------------------------------------------------------
/src/web.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright 2012 Daniel Lowe All Rights Reserved.
  2 | ;;;
  3 | ;;; Licensed under the Apache License, Version 2.0 (the "License");
  4 | ;;; you may not use this file except in compliance with the License.
  5 | ;;; You may obtain a copy of the License at
  6 | ;;;
  7 | ;;;     http://www.apache.org/licenses/LICENSE-2.0
  8 | ;;;
  9 | ;;; Unless required by applicable law or agreed to in writing, software
 10 | ;;; distributed under the License is distributed on an "AS IS" BASIS,
 11 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 12 | ;;; See the License for the specific language governing permissions and
 13 | ;;; limitations under the License.
 14 | 
 15 | (in-package #:orcabot)
 16 | 
 17 | (defmodule web web-module ("g" "url")
 18 |   (ignored-hosts :accessor ignored-hosts-of :initform nil)
 19 |   (urls :accessor urls-of :initform nil)
 20 |   (search-cse-id :accessor search-cse-id-of :initform nil)
 21 |   (search-api-key :accessor search-api-key-of :initform nil))
 22 | 
 23 | (defmethod initialize-module ((module web-module) config)
 24 |   ;; load configuration for custom search engine
 25 |   (let ((search-config (cdr (assoc 'search config))))
 26 |     (when search-config
 27 |       (setf (search-api-key-of module) (getf search-config :api-key)
 28 |             (search-cse-id-of module) (getf search-config :cse-id))))
 29 |   (let ((web-config (cdr (assoc 'web config))))
 30 |     (when web-config
 31 |       (setf (ignored-hosts-of module)
 32 |             (getf web-config :ignored-hosts))))
 33 | 
 34 |   (setf (urls-of module) nil)
 35 |   (with-open-file (inf (data-path "urls.lisp")
 36 |                        :direction :input
 37 |                        :if-does-not-exist nil)
 38 |     (when inf
 39 |       (setf (urls-of module) (read inf)))))
 40 | 
 41 | (defun save-urls (module)
 42 |   (write-to-file (data-path "urls.lisp")
 43 |                  (urls-of module)))
 44 | 
 45 | (defun format-snippet (snippet)
 46 |   (string-limit
 47 |    (string-trim '(#\space)
 48 |                 (ppcre:regex-replace-all "\\s+" snippet " "))
 49 |    100))
 50 | 
 51 | (defun find-node-by-path (root tag-names)
 52 |   "Returns the node found by traversing a DOM hierarchy by tag names."
 53 |   (let ((child-element (find (first tag-names)
 54 |                           (plump:child-elements root)
 55 |                           :key #'plump:tag-name
 56 |                           :test #'string-equal)))
 57 |     (cond
 58 |       ((null child-element)
 59 |        nil)
 60 |       ((endp (rest tag-names))
 61 |        child-element)
 62 |       (t
 63 |        (find-node-by-path child-element (rest tag-names))))))
 64 | 
 65 | (defun generic-uri-summary (response content-type)
 66 |   (handler-case
 67 |       (alexandria:switch (content-type :test #'string=)
 68 |         ("text/html"
 69 |          (let* ((text (flexi-streams:octets-to-string response :external-format :utf-8))
 70 |                 (dom (plump:parse text))
 71 |                 (titles (and dom (find-node-by-path dom '("html" "head" "title"))))
 72 |                 (title-text-node (and titles (plump:first-child titles))))
 73 |            (when title-text-node
 74 |              (format-snippet (plump:text title-text-node)))))
 75 |         ("text/plain"
 76 |          (format-snippet (flexi-streams:octets-to-string response :external-format :utf-8))))
 77 |     (flexi-streams:external-format-error ()
 78 |       nil)))
 79 | 
 80 | (defun retrieve-uri-summary (uri)
 81 |   (multiple-value-bind (response status headers uri)
 82 |       (drakma:http-request uri :want-stream t :connection-timeout 2
 83 |                                :cookie-jar (make-instance 'drakma:cookie-jar))
 84 |     
 85 |     (when (= status 200)
 86 |       ;; on success read into our buffer
 87 |       (let* ((buf (make-array '(32767) :element-type '(unsigned-byte 8)))
 88 |              (uncompressed (if (string= (cdr (assoc :content-encoding headers)) "gzip")
 89 |                                (chipz:make-decompressing-stream 'chipz:gzip response)
 90 |                                response))
 91 |              (len (read-sequence buf uncompressed)))
 92 |         (close response)
 93 |         (values
 94 |          (generic-uri-summary (subseq buf 0 len)
 95 |                               (multiple-value-bind (type subtype)
 96 |                                   (drakma:get-content-type headers)
 97 |                                 (concatenate 'string type "/" subtype)))
 98 |          uri)))))
 99 | 
100 | (defmethod examine-message ((module web-module)
101 |                             (message irc:irc-privmsg-message))
102 |   (ppcre:do-matches-as-strings  (uri-string "https?:\\/\\/[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-z]{2,6}\\b[-a-zA-Z0-9@:%_\\+.~#&//=]*\\??[-a-zA-Z0-9@:%_\\+.~#&//=]*" (second (arguments message)) nil :sharedp t)
103 |     (when (< (length uri-string) 2083)
104 |       (log:log-message :info "~a mentioned url ~a" (source message)
105 |                        uri-string)
106 |       ;; save url
107 |       (pushnew uri-string (urls-of module) :test #'string=)
108 |       (save-urls module)
109 |       ;; query url and emit summary
110 |       (handler-case
111 |           (multiple-value-bind (summary uri)
112 |               (retrieve-uri-summary uri-string)
113 |             ;; TODO: maybe cache summary?
114 |             (cond
115 |               ((null summary)
116 |                (log:log-message :info "No summary found for ~a" uri-string))
117 |               ((null uri)
118 |                (log:log-message :info "Shouldn't happen - (summary ~s) (uri ~s) (uri-string ~s)" summary uri uri-string))
119 |               ((member (puri:uri-host uri)
120 |                        (ignored-hosts-of module)
121 |                        :test (lambda (a b)
122 |                                (alexandria:ends-with-subseq b a)))
123 |                (log:log-message :info "No summary for ignored host ~a"
124 |                                 (puri:uri-host uri)))
125 |               (t
126 |                (log:log-message :info "Summary for ~a : ~a" uri-string summary)
127 |                (reply-to message "[~a] - ~a" summary (puri:uri-host uri)))))
128 |         (drakma::drakma-simple-error ()
129 |           (log:log-message :error "Error retrieving ~a: ~a" uri-string)
130 |           nil)
131 |         (puri:uri-parse-error ()
132 |           (log:log-message :error "failed to parse url ~a" uri-string)
133 |           nil)
134 |         (usocket:ns-host-not-found-error ()
135 |           (log:log-message :error "Error retrieving ~a: Host not found" uri-string)
136 |           nil)
137 |         (usocket:timeout-error ()
138 |           (log:log-message :error "socket timeout checking url ~a" uri-string)
139 |           nil)
140 |         (usocket:ns-try-again-condition ()
141 |           (log:log-message :error "temp dns lookup failure checking url ~a" uri-string)
142 |           nil)))))
143 | 
144 | (defun google-api-search (query cse-id api-key)
145 |   (pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
146 |   (let ((response
147 |           (drakma:http-request "https://www.googleapis.com/customsearch/v1"
148 |                                :parameters `(("q" . ,query)
149 |                                              ("num" . "1")
150 |                                              ("cx" . ,cse-id)
151 |                                              ("key" . ,api-key)))))
152 |     (when response
153 |       (let* ((result (json:decode-json-from-string response))
154 |              (item (first (cdr (assoc :items result)))))
155 |         (and item
156 |              (format nil "~a - ~a - ~a"
157 |                      (cdr (assoc :link item))
158 |                      (format-snippet (cdr (assoc :title item)))
159 |                      (format-snippet (cdr (assoc :snippet item)))))))))
160 | 
161 | (defmethod handle-command ((module web-module)
162 |                            (cmd (eql 'g))
163 |                            message args)
164 |   "g <search> - Return first Google result for search."
165 |   (cond
166 |     ((not (and (search-api-key-of module) (search-cse-id-of module)))
167 |      (reply-to message "Sorry, search engine is not configured."))
168 |     (args
169 |      (let* ((query (join-to-string " " args))
170 |             (result (google-api-search query
171 |                                        (search-cse-id-of module)
172 |                                        (search-api-key-of module))))
173 |        (if result
174 |            (reply-to message "~a" result)
175 |            (reply-to message "No search results found for '~a'" query))))
176 |     (t
177 |      (reply-to message "Missing search terms."))))
178 | 
179 | (defmethod handle-command ((module web-module)
180 |                            (cmd (eql 'url))
181 |                            message args)
182 |   "url [<new url>] - add a url or get a random url"
183 |   (cond
184 |     (args
185 |      (push (format nil "~{~a~^ ~}" args)
186 |            (urls-of module))
187 |      (save-urls module)
188 |      (reply-to message "Url added."))
189 |     ((null (urls-of module))
190 |      (reply-to message "There are no stored URLs."))
191 |     (t
192 |      (reply-to message "~a" (random-elt (urls-of module))))))
193 | 


--------------------------------------------------------------------------------