jadedctrl/ chicken-ircc
Archived
1
0
Disbranĉigi 0
Fontkodo Tirpetoj Activity

Write egg-file, put lib in module

This commit is contained in:
Jaidyn Ann 2023-01-08 18:13:38 -06:00
parent 3ddd88c9b6
commit 74e42fbf4d
2 changed files with 151 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
ircc.egg Normal file
View File

@ -0,0 +1,8 @@
;; -*- Scheme -*-
((synopsis "IRC client library.")
(author "Jaidyn Ann")
(category net)
(license "GPLv3")
(dependencies srfi-1 srfi-19 srfi-69 srfi-130 openssl)
(components (extension ircc)))

276
ircc.scm
View File

@ -15,83 +15,106 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;; ;;
(module ircc
*
;; (irc:connect
;; irc:loop
;; irc:read-alist
;; irc:write-cmd irc:write-line
;; irc:user-set! irc:user-get
;; irc:channels irc:channel-set! irc:channel-get
;; irc:hostmask? irc:hostmask-nick irc:hostmask-ident irc:hostmask-host
;; irc:user-is-self?)
(import scheme (import scheme
(chicken io) (chicken tcp) (chicken base) (chicken io) (chicken module) (chicken string) (chicken tcp)
srfi-1 srfi-19 srfi-69 srfi-130 srfi-1 srfi-19 srfi-69 srfi-130
openssl) openssl)
;; —————————————————————————————————————————————————————————————————————————————— ;; —————————————————————————————————————————————————————————————————————————————
;; Main ;; IRC constants
;; —————————————————————————————————————————————————————————————————————————————— ;; —————————————————————————————————————————————————————————————————————————————
;; Connect to the given IRC server, returning an IRC connection object. (define RPL_WELCOME 1) (export RPL_WELCOME)
(define (irc:connect host port username nick #!optional (password #f) (realname #f)) (define RPL_WHOISUSER 311) (export RPL_WHOISUSER)
(let ([conn (make-hash-table)]) (define RPL_ENDOFWHO 315) (export RPL_ENDOFWHO)
(define-values (out in) (define RPL_ENDOFWHOIS 318) (export RPL_ENDOFWHOIS)
(ssl-connect* hostname: host port: port)) (define RPL_LIST 322) (export RPL_LIST)
(hash-table-set! conn 'in in) (define RPL_LISTEND 323) (export RPL_LISTEND)
(hash-table-set! conn 'out out) (define RPL_TOPIC 332) (export RPL_TOPIC)
(hash-table-set! conn 'username username) (define RPL_TOPICWHOTIME 333) (export RPL_TOPICWHOTIME)
(hash-table-set! conn 'nick nick) (define RPL_WHOREPLY 352) (export RPL_WHOREPLY)
(hash-table-set! conn 'realname realname) (define RPL_NAMREPLY 353) (export RPL_NAMREPLY)
(hash-table-set! conn 'channels (make-hash-table)) (define RPL_MOTD 372) (export RPL_MOTD)
(hash-table-set! conn 'users (make-hash-table)) (define RPL_MOTDSTART 375) (export RPL_MOTDSTART)
(hash-table-set! conn 'capabilities '()) (define RPL_ENDOFMOTD 376) (export RPL_ENDOFMOTD)
(define ERR_NONICKNAMEGIVEN 431) (export ERR_NONICKNAMEGIVEN)
(irc:write-cmd conn "CAP" "REQ" "userhost-in-names") (define ERR_ERRONEUSNICKNAME 432) (export ERR_ERRONEUSNICKNAME)
(if password (define ERR_NICKNAMEINUSE 433) (export ERR_NICKNAMEINUSE)
(irc:write-cmd conn "PASS" password))
(irc:write-cmd conn "USER" username "*" "0"
(if realname realname "Jane Row"))
(irc:write-cmd conn "NICK" nick)
conn))
;; Basic loop for using an IRC connection, using two hook functions: ;; —————————————————————————————————————————————————————————————————————————————
;; (on-command connection command params sender) ;; Misc. helpers
;; (on-reply connection reply-code params sender) ;; —————————————————————————————————————————————————————————————————————————————
(define (irc:loop connection on-command on-reply)
(let* ([output (irc:read-alist connection)] ;; Just car's the value of alist-ref (if it exists)
[command (alist-ref 'command output)] (define (alist-car-ref key alist)
[reply (alist-ref 'reply output)] (let ([value (alist-ref key alist)])
[params (alist-ref 'params output)] (if value
[sender (alist-ref 'sender output)]) (car value)
(if (and on-command (car command)) #f)))
(apply on-command (append (list connection) command (list params) sender)))
(if (and on-reply (car reply))
(apply on-reply (append (list connection) reply (list params) sender)))
(irc:loop connection on-command on-reply)))
;; —————————————————————————————————————————————————————————————————————————————— ;; By Göran Weinholt, from the Scheme Cookbook
;; I/O ;; https://cookbook.scheme.org/format-unix-timestamp/
;; —————————————————————————————————————————————————————————————————————————————— (define (time-unix->time-utc seconds)
(add-duration (date->time-utc (make-date 0 0 0 0 1 1 1970 0))
;; Read-in the next reply or command from the server, into a parsable alist with (make-time time-duration 0 seconds)))
;; four keys:
(define (irc:read-alist conn)
(irc:process-alist-internally
conn
(irc:line->alist (irc:read-line conn))))
;; Read a single line from the IRC server ;; By Göran Weinholt, from the Scheme Cookbook
(define (irc:read-line conn) ;; https://cookbook.scheme.org/format-unix-timestamp/
(read-line (hash-table-ref conn 'out))) (define (time-unix->string seconds . maybe-format)
(apply date->string (time-utc->date (time-unix->time-utc seconds))
maybe-format))
;; Send a specific command to the server. ;; —————————————————————————————————————————————————————————————————————————————
(define (irc:write-cmd conn command . parameters) ;; Mucking around with hostmasks
(irc:write-line (apply irc:cmd->string (append `(,command) parameters)) ;; —————————————————————————————————————————————————————————————————————————————
conn))
;; Return the nick part of a hostmask
(define (irc:hostmask-nick hostmask)
(car (string-split hostmask "!")))
;; Write a line to the IRC server connection. ;; The username/ident part of a hostmask
(define (irc:write-line text connection) (define (irc:hostmask-ident hostmask)
(print text) (car (string-split (cadr (string-split hostmask "!"))
(write-line text (hash-table-ref connection 'in))) "@")))
;; The host part of a hostmask
(define (irc:hostmask-host hostmask)
(cadr (string-split hostmask "@")))
;; Return whether or not a string is likely a valid hostmask
(define (irc:hostmask? string)
(let ([at-! (string-contains string "!")]
[at-@ (string-contains string "@")]
[at-. (string-contains string ".")])
(and at-! at-@ at-.
(string-cursor<? at-! at-@)
(string-cursor<? at-@ at-.))))
;; Return whether or not the given string (username/nick/hostmask/etc) is
;; equivalent to current user.
(define (irc:user-is-self? conn user-string)
(string=? (irc:hostmask-nick user-string)
(hash-table-ref conn 'nick)))
;; —————————————————————————————————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————————————————————————————————
@ -167,7 +190,6 @@
(irc:channel-user-add! conn room-name (irc:hostmask-nick new-user)))])) (irc:channel-user-add! conn room-name (irc:hostmask-nick new-user)))]))
;; —————————————————————————————————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————————————————————————————————
;; Metadata accessors ;; Metadata accessors
;; —————————————————————————————————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————————————————————————————————
@ -266,7 +288,7 @@
conn chan 'users conn chan 'users
(filter (lambda (a-nick) (filter (lambda (a-nick)
(not (string=? nick a-nick))) (not (string=? nick a-nick)))
(irc:channel-users conn name)))) (irc:channel-users conn chan))))
;; ————————————————————————————————————————————————————————————————————————————— ;; —————————————————————————————————————————————————————————————————————————————
@ -364,7 +386,6 @@
;; Returns a list of parameters from the parsed-out verb section of a line ;; Returns a list of parameters from the parsed-out verb section of a line
(define (irc:line-verb-params verb) (define (irc:line-verb-params verb)
(print verb)
(let* ([params (cdr verb)] (let* ([params (cdr verb)]
[other-params '()] [other-params '()]
[last-param '()]) [last-param '()])
@ -389,86 +410,75 @@
last-param))))) last-param)))))
;; ————————————————————————————————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————————————————————————————————
;; Mucking around with hostmasks ;; I/O
;; ————————————————————————————————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————————————————————————————————
;; Return the nick part of a hostmask ;; Read-in the next reply or command from the server, into a parsable alist with
(define (irc:hostmask-nick hostmask) ;; four keys:
(car (string-split hostmask "!"))) (define (irc:read-alist conn)
(irc:process-alist-internally
conn
(irc:line->alist (irc:read-line conn))))
;; The username/ident part of a hostmask ;; Read a single line from the IRC server
(define (irc:hostmask-ident hostmask) (define (irc:read-line conn)
(car (string-split (cadr (string-split hostmask "!")) (read-line (hash-table-ref conn 'out)))
"@")))
;; The host part of a hostmask ;; Send a specific command to the server.
(define (irc:hostmask-host hostmask) (define (irc:write-cmd conn command . parameters)
(cadr (string-split hostmask "@"))) (irc:write-line (apply irc:cmd->string (append `(,command) parameters))
conn))
;; Return whether or not a string is likely a valid hostmask ;; Write a line to the IRC server connection.
(define (irc:hostmask? string) (define (irc:write-line text connection)
(let ([at-! (string-contains string "!")] (write-line text (hash-table-ref connection 'in)))
[at-@ (string-contains string "@")]
[at-. (string-contains string ".")])
(and at-! at-@ at-.
(string-cursor<? at-! at-@)
(string-cursor<? at-@ at-.))))
;; Return whether or not the given string (username/nick/hostmask/etc) is ;; ——————————————————————————————————————————————————————————————————————————————
;; equivalent to current user. ;; Main
(define (irc:user-is-self? conn user-string) ;; ——————————————————————————————————————————————————————————————————————————————
(string=? (irc:hostmask-nick user-string)
(hash-table-ref conn 'nick))) ;; Connect to the given IRC server, returning an IRC connection object.
(define (irc:connect host port username nick #!optional (password #f) (realname #f))
(let ([conn (make-hash-table)])
(define-values (out in)
(ssl-connect* hostname: host port: port))
(hash-table-set! conn 'in in)
(hash-table-set! conn 'out out)
(hash-table-set! conn 'username username)
(hash-table-set! conn 'nick nick)
(hash-table-set! conn 'realname realname)
(hash-table-set! conn 'channels (make-hash-table))
(hash-table-set! conn 'users (make-hash-table))
(hash-table-set! conn 'capabilities '())
(irc:write-cmd conn "CAP" "REQ" "userhost-in-names")
(if password
(irc:write-cmd conn "PASS" password))
(irc:write-cmd conn "USER" username "*" "0"
(if realname realname "Jane Row"))
(irc:write-cmd conn "NICK" nick)
conn))
;; ————————————————————————————————————————————————————————————————————————————— ;; Basic loop for using an IRC connection, using two hook functions:
;; Misc. helpers ;; (on-command connection command params sender)
;; ————————————————————————————————————————————————————————————————————————————— ;; (on-reply connection reply-code params sender)
(define (irc:loop connection on-command on-reply)
;; Just car's the value of alist-ref (if it exists) (let* ([output (irc:read-alist connection)]
(define (alist-car-ref key alist) [command (alist-ref 'command output)]
(let ([value (alist-ref key alist)]) [reply (alist-ref 'reply output)]
(if value [params (alist-ref 'params output)]
(car value) [sender (alist-ref 'sender output)])
#f))) (if (and on-command (car command))
(apply on-command (append (list connection) command (list params) sender)))
(if (and on-reply (car reply))
(apply on-reply (append (list connection) reply (list params) sender)))
(irc:loop connection on-command on-reply)))
;; By Göran Weinholt, from the Scheme Cookbook ) ;; ircc module
;; https://cookbook.scheme.org/format-unix-timestamp/
(define (time-unix->time-utc seconds)
(add-duration (date->time-utc (make-date 0 0 0 0 1 1 1970 0))
(make-time time-duration 0 seconds)))
;; By Göran Weinholt, from the Scheme Cookbook
;; https://cookbook.scheme.org/format-unix-timestamp/
(define (time-unix->string seconds . maybe-format)
(apply date->string (time-utc->date (time-unix->time-utc seconds))
maybe-format))
;; —————————————————————————————————————————————————————————————————————————————
;; IRC constants
;; —————————————————————————————————————————————————————————————————————————————
(define RPL_WELCOME 1)
(define RPL_WHOISUSER 311)
(define RPL_ENDOFWHO 315)
(define RPL_ENDOFWHOIS 318)
(define RPL_LIST 322)
(define RPL_LISTEND 323)
(define RPL_TOPIC 332)
(define RPL_TOPICWHOTIME 333)
(define RPL_WHOREPLY 352)
(define RPL_NAMREPLY 353)
(define RPL_MOTD 372)
(define RPL_MOTDSTART 375)
(define RPL_ENDOFMOTD 376)
(define ERR_NONICKNAMEGIVEN 431)
(define ERR_ERRONEUSNICKNAME 432)
(define ERR_NICKNAMEINUSE 433)