Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 219 lines (198 sloc) 7.72 KB
#!/usr/bin/env gosh
;;; A simple Chaton-Twitter bridge
;; - Chaton posts are forwarded to a twitter account, truncated if necessary,
;; plus a back link to the Chaton permalink using
;; - Twitter replies are fowarded to Chaton as a new post.
;; - You need Gauche-net-twitter package.
;; - In order to run this script, you need to have (1) twitter API access
;; keys (consumer key and consumer secret), (2) twitter access tokens
;; of the account you're planning to forward messages to, and
;; (3) a account.
;; You have to provide these info via a configuration file, which contain
;; an assoc list of the following items:
;; chaton-url : chaton's room url to communicate (string)
;; twitter-username : twitter username to feed
;; twitter-consumer-key : consumer key (string)
;; twitter-consumer-secret : consumer secret (string)
;; twitter-access-token : access token (string)
;; twitter-access-token-secret : access token secret (string)
;; bitly-username :'s login name (string)
;; bitly-apikey :'s api key (string)
;; Example config file entry:
;; (
;; (chaton-url . "")
;; (twitter-consumer-key . "XXXXXXXXXXXXXXXXXXXX")
;; (twitter-consumer-secret . "XXXXXXXXXXXXXXXXXXX")
;; (twitter-access-token . "XXXXXXXXXXXXXXXXXXXXXX")
;; (twitter-access-token-secret . "XXXXXXXXXXXXXXXXXXX")
;; (twitter-password . "mytwitterpassword")
;; (bitly-username . "mybitlyaccount")
;; (bitly-apikey . "mybitlyapikey")
;; )
(use gauche.threads)
(use gauche.logger)
(use gauche.parseopt)
(use chaton.client)
(use srfi-13)
(use rfc.http)
(use rfc.base64)
(use sxml.ssax)
(use sxml.sxpath)
(use file.util)
(use util.match)
(use util.list)
(use :prefix tw:)
(use net.twitter.status :prefix tw:)
(use net.twitter.friendship :prefix tw:)
(use net.twitter.core)
;; Configuration
(define (read-configuration file)
(guard (e [(or (<system-error> e)
(<read-error> e))
(exit 1 "Reading config file failed: ~a" (ref e'message))])
(let1 ss (file->sexp-list file)
(unless (and (= (length ss) 1) (list? (car ss)))
(exit 1 "Malformed configuration file: ~a" file))
(dolist [k '(twitter-username twitter-password bitly-username bitly-apikey)]
(unless (string? (assoc-ref (car ss) k))
(exit 1 "Entry for ~a is missing or non-string in ~a" k file)))
;; Returns a closure to look up
(lambda (k) (assoc-ref (car ss) k)))))
;; access layer
(define (shorten-url config url)
(let1 r (make-request 'get ""
(version "2.0.1") (format "xml") (longUrl ,url)
(login ,(config 'bitly-username))
(apiKey ,(config 'bitly-apikey))))
(unless (equal? ((if-car-sxpath '(// statusCode *text*)) r) "OK")
(log-format " returned an error: ~s" r))
((if-car-sxpath '(// results nodeKeyVal shortUrl *text*)) r)))
;; Twitter access layer
(define (config->twitter-cred config)
(make <twitter-cred>
:consumer-key (config 'twitter-consumer-key)
:consumer-secret (config 'twitter-consumer-secret)
:access-token (config 'twitter-access-token)
:access-token-secret (config 'twitter-access-token-secret)))
;; Integration
(define *short-url-length* 23)
(define (feed-to-twitter config client nick time text)
;; Twitter shortens link to *short-url-length* chars, no matter how
;; long the original link is.
;; TODO: We should check the urls within content as well.
(let* ([content (format "~a: ~a" nick text)]
[link (chaton-permalink client time)]
[post (if (> (+ (string-length content) 1 *short-url-length*) 140)
(string-append (string-take content (- 140 *short-url-length* 2))
(string #\u2026 #\space)
(string-append content " " link))])
(log-format "twitter-post: ~s" post)
(tw:update (config->twitter-cred config) post)))
(define (make-observer config)
(lambda (client message)
(guard (e [else (log-format "observer error: ~a" (ref e'message)) #f])
(log-format "~a" message)
[(<chaton-error> message)
(log-format "chaton-error: ~a" (ref message'message)) #f]
[(and-let* ([pos (assq-ref message 'pos)]) (< pos (chaton-pos client)))
[(assq-ref message 'content)
=> (lambda (msgs)
(dolist [m msgs]
(match m
[(nick time text . _)
(feed-to-twitter config client nick time text)]
[_ #f])))]
[else #f]))))
(define (forward-from-twitter client username text)
(chaton-talk client #`",|username|@twitter" text))
(define (get-follower-mention config followers s)
(and-let* ([id (assoc-ref s "id")]
[text (assoc-ref s "text")]
;; without RT status
[(not (assoc-ref s "retweeted_status"))]
[user (assoc-ref s "user")]
[username (assoc-ref user "screen_name")]
[user-id (assoc-ref user "id")]
[me (config'twitter-username)]
[(member user-id followers)]
[rx (string->regexp #`"@,|me|\\s*")]
;; filter out friends status.
[(rx text)])
(list username (regexp-replace-all rx text ""))))
(define (kick-reply-watcher! client config)
(define cred (config->twitter-cred config))
(define followers '())
(define (stream-handler _ json)
(let1 event (assoc-ref json "event")
[(equal? event "follow")
(and-let* ([me (config'twitter-username)]
[user (assoc-ref json "source")]
[(not (equal? (assoc-ref user "screen_name") me))]
[user-id (assoc-ref user "id")])
(unless (memq user-id followers)
(set! followers (cons user-id followers))))]
[(and (not event) (get-follower-mention config followers json)) =>
(^ [args] (apply forward-from-twitter client args))])))
;; observe followers (To check unfollower)
(define (follower-observer)
(guard (e [else (log-format "twitter api error: ~a" (ref e'message))])
(let1 me (config'twitter-username)
(set! followers (tw:followers/ids cred :screen-name me))))
(sys-sleep 900)
(define (main args)
(let-args (cdr args) ([logfile "l=s"] [else _ (usage)] . restargs)
(cond [(equal? logfile "-") (common-log-open #t)]
[(string? logfile) (common-log-open logfile)])
(log-format "starting ~a" (car args))
(match restargs
(let* ([config (read-configuration file)]
[client (chaton-connect (config'chaton-url) "chaton-twitter"
(make-observer config))])
(kick-reply-watcher! client config))]
[_ (usage)])))
(define (usage)
(print "Usage: chaton-twitter [-l logfile] config-file")
(exit 0))
(define (common-log-open dst) (log-open dst) (chaton-log-open dst))
;; Utility
(define (make-request method server request-uri :optional body :rest opts)
(receive (status header body)
(case method
[(get) (apply http-get server request-uri opts)]
[(post) (apply http-post server request-uri body opts)])
(unless (equal? status "200")
(log-format "~a returned status ~a: ~a" server status body)
(error "make-request error"))
(call-with-input-string body (cut ssax:xml->sxml <> '()))))
;; Local variables:
;; mode: scheme
;; end: