2021-04-08 14:15:14 +00:00
# !/usr/bin/guile
! #
( use-modules ( ice-9 rdelim )
( ice-9 textual-ports )
2021-04-09 06:05:47 +00:00
( ice-9 format )
( ice-9 control )
2021-04-09 06:13:16 +00:00
( ice-9 sandbox )
2021-04-11 09:43:24 +00:00
( ice-9 popen )
( ice-9 regex )
2021-04-09 06:05:47 +00:00
( rnrs exceptions ) )
2021-04-08 14:15:14 +00:00
2021-06-19 16:46:05 +00:00
( define +channels+ ' ( "#tildetown" "#lisp" "#bots" ) )
;; (define +channels+ '("#bots"))
2021-05-26 10:05:39 +00:00
( load "greets.scm" )
2021-04-08 14:15:14 +00:00
( define ( scdr lst )
2021-04-08 14:57:05 +00:00
"Safe CDR. Returns CDR of lst, if it is a list. Returns lst otherwise."
( if ( not ( pair? lst ) )
2021-04-08 14:15:14 +00:00
lst
( cdr lst ) ) )
2021-04-08 14:57:05 +00:00
( define ( scar lst )
"Safe CAR, see scdr."
( if ( not ( pair? lst ) )
lst
( car lst ) ) )
2021-04-08 14:15:14 +00:00
( define ( slist-ref lst index )
2021-04-08 14:57:05 +00:00
"Safe list-ref, see scdr."
2021-04-08 14:15:14 +00:00
( if ( < ( length lst ) ( + index 1 ) )
' ( )
( list-ref lst index ) ) )
( define ( slist-tail lst index )
2021-04-08 14:57:05 +00:00
"Safe list-tail, see scdr."
2021-04-08 14:15:14 +00:00
( if ( < ( length lst ) ( + index 1 ) )
' ( )
( list-tail lst index ) ) )
( define ( string-tail str index )
"List-tail for strings."
( list->string ( list-tail ( string->list str ) index ) ) )
( define ( intersperse sep lst )
"Returns a new list with sep between each element of lst."
( cond
( ( or ( null? lst )
( null? ( cdr lst ) ) ) lst )
( else ( cons ( car lst )
( cons sep
( intersperse sep ( cdr lst ) ) ) ) ) ) )
( define ( make-connection host port )
2021-08-18 10:38:18 +00:00
"Connect to server on host:port, returns a socket for reading and writing."
2021-04-08 14:15:14 +00:00
( let* ( ( sock ( socket PF_INET SOCK_STREAM 0 ) )
( con ( connect sock
AF_INET
( car ( vector-ref ( gethost host ) 4 ) )
port ) ) )
sock ) )
2021-05-17 13:48:05 +00:00
( define ( get-username str )
( define ( get-username-list lst )
( cond ( ( null? lst ) ' ( ) )
( ( eq? ( car lst ) #\! ) ' ( ) )
( else ( cons ( car lst )
( get-username-list ( cdr lst ) ) ) ) ) )
( list->string ( cdr ( get-username-list ( string->list str ) ) ) ) )
2021-04-08 14:15:14 +00:00
( define ( pong stream )
( format stream "PONG :anna\r\n" ) )
( define ( send-nick stream )
( format stream "NICK anna\r\n" ) )
( define ( send-user stream )
( format stream "USER anna 0.0.0.0 anna :Anna\r\n" ) )
2021-04-08 14:46:41 +00:00
( define ( join-channels stream )
2021-04-08 14:57:05 +00:00
( for-each ( lambda ( chn )
( format stream "JOIN ~a\r\n" chn ) )
+channels+ ) )
2021-04-08 14:15:14 +00:00
( define ( send-message stream chn msg )
( format stream "PRIVMSG ~a :~a\r\n" chn msg ) )
( define ( send-action stream chn action )
( format stream "PRIVMSG ~a :\x01ACTION ~a\x01\r\n" chn action ) )
2021-05-26 10:05:39 +00:00
;;; TODO: this can be refactored into a function that takes one char and
;;; removes it, and composing that into more complex functions.
2021-04-09 14:04:19 +00:00
( define ( input-filter str )
2021-04-11 09:43:24 +00:00
"Remove escaped chars to avoid fooling the bot into performing bad actions."
( define ( remove-escaped-chars lst )
2021-04-09 14:04:19 +00:00
( cond
( ( or ( null? lst )
( null? ( cdr lst ) ) ) lst )
2021-04-11 09:43:24 +00:00
( ( eq? ( car lst ) #\\ ) ( remove-escaped-chars ( cddr lst ) ) )
( else ( cons ( car lst ) ( remove-escaped-chars ( cdr lst ) ) ) ) ) )
( list->string ( remove-escaped-chars ( string->list str ) ) ) )
2021-04-09 14:04:19 +00:00
2021-05-26 10:05:39 +00:00
( define ( remove-newlines str )
( define ( remove-newlines-aux lst )
( cond ( ( null? lst ) ' ( ) )
( ( or ( equal? ( string ( car lst ) ) "\n" )
( equal? ( string ( car lst ) ) "\r" ) )
( remove-newlines-aux ( cdr lst ) ) )
( else ( cons ( car lst ) ( remove-newlines-aux ( cdr lst ) ) ) ) ) )
( list->string ( remove-newlines-aux ( string->list str ) ) ) )
2021-04-09 06:05:47 +00:00
( define ( evaluate str )
2021-04-11 09:43:24 +00:00
"Evaluate the given string in a sandbox without crashing on errors."
2021-04-09 06:05:47 +00:00
( guard ( ex
( else ( begin ( display "error encountered!\n" )
2021-04-09 14:04:19 +00:00
'error ) ) ) ;; << this gets printed in chat
2021-08-18 10:38:18 +00:00
( eval-in-sandbox ( read ( open-input-string str ) )
# :bindings all-pure-and-impure-bindings ) ) )
2021-04-09 06:05:47 +00:00
2021-04-11 09:43:24 +00:00
( define ( find-documentation language search )
"Find documentation for different programming languages."
( cond
( ( null? language ) "Missing langauge specifier." )
( ( null? ( string-tokenize search ) ) "Missing search string." )
( ( eq? language 'cl ) ( find-cl-documentation search ) )
( else "Unrecognized language! Supported languages are: cl" ) ) )
2021-05-17 13:48:05 +00:00
( define ( read-file f )
( call-with-input-file f get-string-all ) )
( define ( timezone user )
( let ( ( path ( string-append "/home/" user "/.tz" ) ) )
( if ( access? path R_OK )
2021-05-26 10:05:39 +00:00
( remove-newlines ( read-file path ) )
2021-05-17 13:48:05 +00:00
( string-append user
" has not set their timezone. Use `echo '<timezone here>' > ~/.tz' to add your timezone." ) ) ) )
2021-04-11 09:43:24 +00:00
( define ( slice start end lst )
"Return the list between index start and end (start inclusive, end not inclusive)."
( cond
( ( > start end ) ( error "Start index can't be more than end index." ) )
( ( > end ( length lst ) ) ( error "End index too large." ) )
( ( = start end ) ' ( ) )
( else ( cons ( list-ref lst start )
( slice ( + 1 start ) end lst ) ) ) ) )
( define ( escape-string str )
"Replace all special regex chars with escaped versions."
( define chars ' ( #\( #\) #\* #\+ #\? ) )
( define ( member? elem lst )
( cond
( ( null? lst ) #f )
( ( eq? ( car lst ) elem ) #t )
( else ( member? elem ( cdr lst ) ) ) ) )
( define ( loop lst )
( cond
( ( null? lst ) ' ( ) )
( ( member? ( car lst ) chars ) ( cons #\\ ( cons ( car lst ) ( loop ( cdr lst ) ) ) ) )
( else ( cons ( car lst ) ( loop ( cdr lst ) ) ) ) ) )
( list->string ( loop ( string->list str ) ) ) )
( define ( find-cl-documentation search )
"Find documentation for Common Lisp."
( let ( ( status ( system* "grep" ( string-append "htm#" search "\"" ) "cl.htm" ) ) )
( cond
( ( = 0 status )
( let* ( ( port ( open-input-pipe ( string-append "grep htm#" search "\\\" cl.htm" ) ) )
( out ( string-match "Body.*\"" ( read-line port ) ) )
( sublink ( list->string ( slice ( car ( vector-ref out 1 ) )
( - ( cdr ( vector-ref out 1 ) ) 1 )
( string->list ( vector-ref out 0 ) ) ) ) ) )
( close-pipe port )
( string-append "http://www.lispworks.com/documentation/lw70/CLHS/"
sublink ) ) )
( else "Symbol not found in documentation." ) ) ) )
2021-05-21 10:12:25 +00:00
( define ( greets category name )
( if ( not ( assoc name category ) )
"0"
( number->string ( cdr ( assoc name category ) ) ) ) )
2021-05-26 10:05:39 +00:00
( define ( write-greets )
( define ( greet-values alst )
( define ( actual-values al )
( cond ( ( null? al ) ( format #f "~%" ) )
( else ( string-append ( format #f "~%(cons ~s ~s)" ( caar al ) ( cdar al ) )
( actual-values ( cdr al ) ) ) ) ) )
( format #f "(list ~a)" ( actual-values alst ) ) )
( call-with-output-file "greets.scm" ( lambda ( stream )
( format stream
"(define *left-greets* ~a)~%(define *right-greets* ~a)~%"
( greet-values *left-greets* )
( greet-values *right-greets* ) ) ) ) )
2021-05-21 10:12:25 +00:00
;; has to be separate functions since modifying the argument won't change global state
( define ( inc-left-greets name )
( if ( not ( assoc name *left-greets* ) )
( set! *left-greets* ( acons name 1 *left-greets* ) )
2021-05-26 10:05:39 +00:00
( set! *left-greets* ( assoc-set! *left-greets* name ( + 1 ( cdr ( assoc name *left-greets* ) ) ) ) ) ) )
2021-05-21 10:12:25 +00:00
( define ( inc-right-greets name )
( if ( not ( assoc name *right-greets* ) )
( set! *right-greets* ( acons name 1 *right-greets* ) )
( assoc-set! *right-greets* name ( + 1 ( cdr ( assoc name *right-greets* ) ) ) ) ) )
( define ( all-greets category )
( if ( null? category )
0
( + ( cdr ( car category ) )
( all-greets ( cdr category ) ) ) ) )
( define ( empty-list->string s )
( if ( null? s )
""
s ) )
( define ( concat-messages strings index length )
( if ( = index length )
""
( string-append ( slist-ref strings index )
( concat-messages strings ( + 1 index ) length ) ) ) )
2021-06-19 16:46:05 +00:00
( define ( n-func-results n f )
( if ( zero? n )
' ( )
( cons ( f ) ( n-func-results ( - n 1 ) f ) ) ) )
( define ( fold-right f base lst )
( if ( null? lst )
base
( f ( car lst )
( fold-right f base ( cdr lst ) ) ) ) )
( define ( diceware-one-word file )
( define ( generate-dice n sides )
( n-func-results n ( lambda ( ) ( random sides ) ) ) )
( let* ( ( entry ( fold-right string-append "" ( map number->string
( map ( lambda ( x ) ( + x 1 ) )
( generate-dice 5 6 ) ) ) ) )
;; yes, shell scripting in scheme
( port ( open-input-pipe ( string-append "grep \"^" entry "\" " file " | awk '{print $2}'" ) ) )
( out ( read-line port ) ) )
( close-pipe port )
out ) )
( define ( diceware file )
( fold-right ( lambda ( x y ) ( string-append x " " y ) )
""
2021-08-18 10:38:18 +00:00
( n-func-results 6 ( lambda ( ) ( diceware-one-word ( if ( equal? file "eff" )
2021-06-19 16:46:05 +00:00
"diceware_eff.txt"
"diceware_words.txt" ) ) ) ) ) )
2021-05-21 10:12:25 +00:00
2021-08-18 10:38:18 +00:00
( define ( qotd stream channel )
( let ( ( s ( make-connection "127.0.0.1" 1717 ) ) )
( define ( send-quote )
( let ( ( line ( read-line s ) ) )
( unless ( eof-object? line )
( send-message stream channel line )
( send-quote ) ) ) )
( send-quote )
( close-port s ) ) )
2021-04-08 14:15:14 +00:00
( define ( main-loop stream )
( let* ( ( inl ( read-line stream ) )
2021-04-08 14:57:05 +00:00
( data ( string-tokenize inl ) )
2021-04-11 09:43:24 +00:00
( chn ( scar ( scdr ( member "PRIVMSG" data ) ) ) )
( filtered-data ( map input-filter data ) ) )
2021-08-19 16:22:47 +00:00
( define ( get-greets left-or-right )
( if ( = 4 ( length data ) )
( number->string ( all-greets left-or-right ) )
( greets left-or-right ( slist-ref data 4 ) ) ) )
( define ( left-greets )
( get-greets *left-greets* ) )
( define ( right-greets )
( get-greets *right-greets* ) )
2021-04-08 14:15:14 +00:00
;; debug print
( format #t "~s~%" data )
2021-08-18 10:38:18 +00:00
( let ( ( command ( slist-ref data 3 ) ) )
( cond
( ( equal? ( car data ) "PING" )
( pong stream ) )
( ( or ( equal? ":!rollcall" command )
( equal? ":!anna" command ) )
2021-08-19 16:22:47 +00:00
( send-message stream chn "Hello! I respond to !anna, !tz <optionally user>, !greets <optionally user>, !dw <optionally \"eff\"> and !eval <s-expr>. My source code is available at https://git.tilde.town/opfez/anna" ) )
2021-08-18 10:38:18 +00:00
( ( equal? ":!eval" command )
( let ( ( expr ( string-concatenate ( intersperse " " ( cdr ( member ":!eval" filtered-data ) ) ) ) ) )
( send-message stream chn ( evaluate expr ) ) ) )
( ( equal? ":!doc" command )
( let ( ( lang ( slist-ref data 4 ) )
( search ( escape-string ( string-concatenate ( intersperse " " ( cddr ( member ":!doc" filtered-data ) ) ) ) ) ) )
( send-message stream chn ( find-documentation ( string->symbol lang ) search ) ) ) )
( ( equal? ":!tz" command )
( send-message stream chn ( if ( = 4 ( length data ) )
( timezone ( get-username ( car data ) ) )
( timezone ( slist-ref data 4 ) ) ) ) )
( ( equal? ":!greets" command )
( send-message stream chn ( string-append "o/ - "
2021-08-19 16:22:47 +00:00
( right-greets )
2021-08-18 10:38:18 +00:00
" vs \\o - "
2021-08-19 16:22:47 +00:00
( left-greets ) ) ) )
2021-08-18 10:38:18 +00:00
( ( string-contains ( empty-list->string ( concat-messages data 3 ( length data ) ) ) "\\o/" )
#f )
( ( string-contains ( empty-list->string ( concat-messages data 3 ( length data ) ) ) "\\o" )
( inc-left-greets ( get-username ( car data ) ) )
( write-greets ) )
( ( string-contains ( empty-list->string ( concat-messages data 3 ( length data ) ) ) "o/" )
( inc-right-greets ( get-username ( car data ) ) )
( write-greets ) )
( ( equal? ":!kirby" command )
( send-message stream chn " 13● 0ミ 8☆" ) )
( ( equal? ":!dw" command )
( send-message stream chn ( diceware ( slist-ref data 4 ) ) ) )
( ( equal? ":!qotd" command )
( qotd stream chn ) )
( ( and ( = 7 ( length data ) )
( equal? ( list-tail data 4 ) ' ( "ACTION" "shoots" "anna" ) ) )
( send-action stream chn "dies" )
( close-port stream )
( exit ) ) ) )
2021-04-08 14:15:14 +00:00
( main-loop stream ) ) )
( let* ( ( io ( make-connection "127.0.0.1" 6667 ) ) )
( send-nick io )
( send-user io )
2021-04-08 14:46:41 +00:00
( join-channels io )
2021-04-08 14:15:14 +00:00
( main-loop io ) )