├── cl-line-bot-sdk.asd ├── qlfile ├── .gitignore ├── linebot ├── package.lisp ├── config.lisp ├── models.lisp ├── linebot.asd ├── http.lisp ├── tests │ └── util.lisp ├── models │ ├── profile.lisp │ ├── base.lisp │ ├── source.lisp │ ├── send-message.lisp │ ├── imagemap.lisp │ ├── template.lisp │ ├── message.lisp │ └── event.lisp ├── webhook.lisp ├── errors.lisp ├── app.lisp ├── api.lisp ├── handler.lisp └── tests.lisp ├── linebot-tests.asd ├── .travis.yml ├── examples ├── echo-app.lisp ├── echo.lisp └── echo-handler.lisp ├── qlfile.lock ├── README.markdown └── tests ├── webhook.json └── webhook.lisp /cl-line-bot-sdk.asd: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (asdf:defsystem #:cl-line-bot-sdk 4 | :depends-on (:linebot)) 5 | -------------------------------------------------------------------------------- /qlfile: -------------------------------------------------------------------------------- 1 | github jonathan Rudolph-Miller/jonathan 2 | github lack fukamachi/lack 3 | github assoc-utils fukamachi/assoc-utils 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | 10 | quicklisp/ 11 | -------------------------------------------------------------------------------- /linebot/package.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:linebot 2 | (:nicknames #:cl-line-bot-sdk) 3 | (:use-reexport #:linebot/api 4 | #:linebot/webhook 5 | #:linebot/handler 6 | #:linebot/config 7 | #:linebot/errors 8 | #:linebot/models)) 9 | -------------------------------------------------------------------------------- /linebot-tests.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:linebot-tests 2 | :depends-on (:linebot 3 | :prove) 4 | :components 5 | ((:test-file "tests/webhook")) 6 | 7 | :defsystem-depends-on (:prove-asdf) 8 | :perform (asdf:test-op :after (op c) 9 | (funcall (intern #.(string :run-test-system) :prove) c))) 10 | -------------------------------------------------------------------------------- /linebot/config.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/config 3 | (:use #:cl) 4 | (:export #:*channel-secret* 5 | #:*channel-access-token* 6 | #:*message-api-endpoint*)) 7 | (in-package #:linebot/config) 8 | 9 | (defvar *channel-secret* nil) 10 | (defvar *channel-access-token* nil) 11 | 12 | (defvar *message-api-endpoint* 13 | "https://api.line.me/v2/bot/") 14 | -------------------------------------------------------------------------------- /linebot/models.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (uiop:define-package #:linebot/models 3 | (:use-reexport #:linebot/models/event 4 | #:linebot/models/message 5 | #:linebot/models/send-message 6 | #:linebot/models/source 7 | #:linebot/models/imagemap 8 | #:linebot/models/template 9 | #:linebot/models/profile)) 10 | -------------------------------------------------------------------------------- /linebot/linebot.asd: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | #-asdf3.1 (error "LINEBOT requires ASDF 3.1") 4 | (asdf:defsystem #:linebot 5 | :class :package-inferred-system 6 | :version "0.1" 7 | :author "Eitaro Fukamachi" 8 | :license "BSD 2-Clause" 9 | :depends-on ("linebot/package" 10 | :uiop) 11 | :description "SDK for the LINE Messaging API for Common Lisp" 12 | :in-order-to ((asdf:test-op (asdf:test-op linebot-tests)))) 13 | 14 | (asdf:register-system-packages "lack-component" '(#:lack.component)) 15 | (asdf:register-system-packages "lack-request" '(#:lack.request)) 16 | -------------------------------------------------------------------------------- /linebot/http.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/http 3 | (:use #:cl) 4 | (:import-from #:linebot/config 5 | #:*message-api-endpoint* 6 | #:*channel-access-token*) 7 | (:import-from #:dexador) 8 | (:import-from #:quri 9 | #:merge-uris 10 | #:uri) 11 | (:export #:request)) 12 | (in-package #:linebot/http) 13 | 14 | (defun message-api (&optional (path "/")) 15 | (quri:merge-uris (quri:uri path) 16 | (quri:uri *message-api-endpoint*))) 17 | 18 | (defun request (path &key (method :get) headers content want-stream) 19 | (dex:request (message-api path) 20 | :method method 21 | :headers (append `((:authorization . ,(format nil "Bearer ~A" *channel-access-token*))) 22 | headers) 23 | :content content 24 | :want-stream want-stream)) 25 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:$PATH 7 | - ROSWELL_BRANCH=release 8 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 9 | - COVERAGE_EXCLUDE=tests 10 | matrix: 11 | - LISP=sbcl-bin COVERALLS=true REVIEWDOG=true 12 | - LISP=ccl-bin 13 | - LISP=abcl-bin 14 | 15 | addons: 16 | apt: 17 | packages: 18 | - default-jre 19 | 20 | install: 21 | # Install Roswell 22 | - curl -L https://raw.githubusercontent.com/roswell/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 23 | - ros install Rudolph-Miller/jonathan 24 | - ros install fukamachi/lack 25 | - ros install fukamachi/assoc-utils 26 | - ros install prove 27 | - if [ "$REVIEWDOG" ]; then ros install fukamachi/sblint; fi 28 | 29 | cache: 30 | directories: 31 | - $HOME/.roswell 32 | - $HOME/.config/common-lisp 33 | 34 | script: 35 | - run-prove linebot-tests.asd 36 | - if [ "$REVIEWDOG" ]; then sblint-reviewdog; fi 37 | -------------------------------------------------------------------------------- /examples/echo-app.lisp: -------------------------------------------------------------------------------- 1 | (let ((asdf:*central-registry* 2 | (cons (make-pathname :directory (butlast (pathname-directory 3 | (or *load-pathname* *compile-file-pathname*)))) 4 | asdf:*central-registry*))) 5 | (ql:quickload '(:linebot/app :uiop) :silent t)) 6 | 7 | (in-package #:cl-user) 8 | (defpackage #:linebot/examples/echo-app 9 | (:use #:cl)) 10 | (in-package #:linebot/examples/echo-app) 11 | 12 | (setf linebot:*channel-secret* (uiop:getenv "LINE_CHANNEL_SECRET")) 13 | (setf linebot:*channel-access-token* (uiop:getenv "LINE_CHANNEL_ACCESS_TOKEN")) 14 | 15 | (defclass echo-app (linebot/app:app) ()) 16 | 17 | (defmethod linebot:handle-message-event ((handler echo-app) 18 | (event linebot:message-event) 19 | (message linebot:text-message)) 20 | (linebot:reply-message 21 | (linebot:event-reply-token event) 22 | (make-instance 'linebot:text-send-message 23 | :text (linebot:message-text message)))) 24 | 25 | (make-instance 'echo-app :callback "/callback") 26 | -------------------------------------------------------------------------------- /qlfile.lock: -------------------------------------------------------------------------------- 1 | ("quicklisp" . 2 | (:class qlot.source.ql:source-ql-all 3 | :initargs (:project-name "quicklisp" :%version :latest) 4 | :version "2016-09-29")) 5 | ("jonathan" . 6 | (:class qlot.source.github:source-github 7 | :initargs (:project-name "jonathan" :repos "Rudolph-Miller/jonathan" :ref nil :branch nil :tag nil) 8 | :version "github-459e20e142ac5f891858e2c85dd109027b9ebd21" 9 | :repos "Rudolph-Miller/jonathan" 10 | :url "https://github.com/Rudolph-Miller/jonathan/archive/459e20e142ac5f891858e2c85dd109027b9ebd21.tar.gz" 11 | :ref "459e20e142ac5f891858e2c85dd109027b9ebd21")) 12 | ("lack" . 13 | (:class qlot.source.github:source-github 14 | :initargs (:project-name "lack" :repos "fukamachi/lack" :ref nil :branch nil :tag nil) 15 | :version "github-32358fdad0b779768b37701cbaf0cd1bcd6efa62" 16 | :repos "fukamachi/lack" 17 | :url "https://github.com/fukamachi/lack/archive/32358fdad0b779768b37701cbaf0cd1bcd6efa62.tar.gz" 18 | :ref "32358fdad0b779768b37701cbaf0cd1bcd6efa62")) 19 | ("assoc-utils" . 20 | (:class qlot.source.github:source-github 21 | :initargs (:project-name "assoc-utils" :repos "fukamachi/assoc-utils" :ref nil :branch nil :tag nil) 22 | :version "github-35970e50380a3917cf782eab950944fb93d61a39" 23 | :repos "fukamachi/assoc-utils" 24 | :url "https://github.com/fukamachi/assoc-utils/archive/35970e50380a3917cf782eab950944fb93d61a39.tar.gz" 25 | :ref "35970e50380a3917cf782eab950944fb93d61a39")) 26 | -------------------------------------------------------------------------------- /linebot/tests/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/tests/util 3 | (:use #:cl) 4 | (:import-from #:usocket) 5 | (:export #:random-port 6 | #:make-random-string)) 7 | (in-package #:linebot/tests/util) 8 | 9 | (defun port-available-p (port) 10 | (let (socket) 11 | (unwind-protect 12 | (handler-case (progn 13 | (setq socket (usocket:socket-listen "127.0.0.1" port :reuse-address t)) 14 | t) 15 | (usocket:address-in-use-error () nil) 16 | (usocket:socket-error (e) 17 | (warn "USOCKET:SOCKET-ERROR: ~A" e) 18 | nil)) 19 | (when socket 20 | (usocket:socket-close socket) 21 | t)))) 22 | 23 | (defun random-port () 24 | "Return a port number not in use from 50000 to 60000." 25 | (loop for port from (+ 50000 (random 1000)) upto 60000 26 | if (port-available-p port) 27 | return port)) 28 | 29 | (defun make-random-string (&optional (length 12)) 30 | (declare (type fixnum length)) 31 | (let ((result (make-string length))) 32 | (declare (type simple-string result)) 33 | (dotimes (i length result) 34 | (setf (aref result i) 35 | (ecase (random 5) 36 | ((0 1) (code-char (+ #.(char-code #\a) (random 26)))) 37 | ((2 3) (code-char (+ #.(char-code #\A) (random 26)))) 38 | ((4) (code-char (+ #.(char-code #\0) (random 10))))))))) 39 | -------------------------------------------------------------------------------- /linebot/models/profile.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/profile 3 | (:use #:cl 4 | #:assoc-utils) 5 | (:import-from #:linebot/models/base 6 | #:json-serializable) 7 | (:export #:profile 8 | #:make-profile 9 | #:profile-display-name 10 | #:profile-user-id 11 | #:profile-picture-url 12 | #:profile-status-message)) 13 | (in-package #:linebot/models/profile) 14 | 15 | (defclass profile (json-serializable) 16 | ((display-name :type string 17 | :initarg :display-name 18 | :accessor profile-display-name) 19 | (user-id :type string 20 | :initarg :user-id 21 | :accessor profile-user-id) 22 | (picture-url :type (or string null) 23 | :initarg :picture-url 24 | :accessor profile-picture-url) 25 | (status-message :type (or string null) 26 | :initarg :status-message 27 | :accessor profile-status-message))) 28 | 29 | (defun make-profile (alist) 30 | (make-instance 'profile :alist alist)) 31 | 32 | (defmethod initialize-instance :after ((object profile) &key alist &allow-other-keys) 33 | (with-slots (display-name user-id picture-url status-message) object 34 | (setf display-name (aget alist "displayName") 35 | user-id (aget alist "userId") 36 | picture-url (aget alist "pictureUrl") 37 | status-message (aget alist "statusMessage")))) 38 | -------------------------------------------------------------------------------- /examples/echo.lisp: -------------------------------------------------------------------------------- 1 | (let ((asdf:*central-registry* 2 | (cons (make-pathname :directory (butlast (pathname-directory 3 | (or *load-pathname* *compile-file-pathname*)))) 4 | asdf:*central-registry*))) 5 | (ql:quickload '(:clack :lack-request :linebot) :silent t)) 6 | 7 | (defparameter linebot:*channel-secret* (uiop:getenv "LINE_CHANNEL_SECRET")) 8 | (defparameter linebot:*channel-access-token* (uiop:getenv "LINE_CHANNEL_ACCESS_TOKEN")) 9 | 10 | (lambda (env) 11 | (block nil 12 | (unless (and (eq (getf env :request-method) :post) 13 | (string= (getf env :path-info) "/callback")) 14 | (return '(404 () ("Not Found")))) 15 | 16 | (let ((req (lack.request:make-request env)) 17 | (headers (getf env :headers))) 18 | (unless (linebot:validate-signature (lack.request:request-content req) 19 | (gethash "x-line-signature" headers)) 20 | (return '(400 () ("Invalid signature")))) 21 | 22 | (let ((events (linebot:parse-request (lack.request:request-content req)))) 23 | (dolist (event events) 24 | (when (and (eq (linebot:event-type event) :message) 25 | (typep (linebot:event-message event) 'linebot:text-message)) 26 | (linebot:reply-message 27 | (linebot:event-reply-token event) 28 | (make-instance 'linebot:text-send-message 29 | :text (linebot:event-message-text event)))))) 30 | '(200 () ("ok"))))) 31 | -------------------------------------------------------------------------------- /linebot/models/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/base 3 | (:use #:cl) 4 | (:import-from #:closer-mop 5 | #:class-slots 6 | #:slot-definition-name) 7 | (:import-from #:jonathan 8 | #:%to-json 9 | #:with-object 10 | #:write-key-value) 11 | (:import-from #:local-time 12 | #:timestamp 13 | #:timestamp-to-unix 14 | #:timestamp-millisecond) 15 | (:import-from #:kebab 16 | #:to-camel-case) 17 | (:export #:json-serializable)) 18 | (in-package #:linebot/models/base) 19 | 20 | (defclass json-serializable () ()) 21 | 22 | (defmethod jojo:%to-json ((object json-serializable)) 23 | (jojo:with-object 24 | (loop for slot in (c2mop:class-slots (class-of object)) 25 | for slot-name = (c2mop:slot-definition-name slot) 26 | when (slot-boundp object slot-name) 27 | do (let ((slot-value (slot-value object slot-name))) 28 | (jojo:write-key-value (kebab:to-camel-case (symbol-name slot-name)) 29 | (typecase slot-value 30 | (null :null) 31 | (keyword (string-downcase slot-value)) 32 | (timestamp 33 | (+ (* (timestamp-to-unix slot-value) 1000) 34 | (timestamp-millisecond slot-value))) 35 | (otherwise slot-value))))))) 36 | -------------------------------------------------------------------------------- /linebot/webhook.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/webhook 3 | (:use #:cl) 4 | (:import-from #:linebot/models 5 | #:make-event) 6 | (:import-from #:linebot/config 7 | #:*channel-secret*) 8 | (:import-from #:ironclad 9 | #:make-hmac 10 | #:update-hmac 11 | #:hmac-digest 12 | #:ascii-string-to-byte-array) 13 | (:import-from #:cl-base64 14 | #:base64-string-to-usb8-array) 15 | (:import-from #:jonathan 16 | #:parse) 17 | (:import-from #:assoc-utils 18 | #:aget) 19 | (:export #:validate-signature 20 | #:parse-request)) 21 | (in-package #:linebot/webhook) 22 | 23 | (defun validate-signature (content x-line-signature) 24 | (when (stringp x-line-signature) 25 | (let ((hmac (ironclad:make-hmac (ascii-string-to-byte-array *channel-secret*) :sha256))) 26 | (ironclad:update-hmac hmac (if (stringp content) 27 | (ascii-string-to-byte-array content) 28 | content)) 29 | (equalp (ironclad:hmac-digest hmac) 30 | (base64-string-to-usb8-array x-line-signature))))) 31 | 32 | (defun parse-request (content) 33 | (let ((json (jojo:parse (etypecase content 34 | (string content) 35 | ((simple-array (unsigned-byte 8) (*)) 36 | (babel:octets-to-string content :encoding :utf-8))) 37 | :as :alist))) 38 | (mapcar #'make-event (aget json "events")))) 39 | -------------------------------------------------------------------------------- /examples/echo-handler.lisp: -------------------------------------------------------------------------------- 1 | (let ((asdf:*central-registry* 2 | (cons (make-pathname :directory (butlast (pathname-directory 3 | (or *load-pathname* *compile-file-pathname*)))) 4 | asdf:*central-registry*))) 5 | (ql:quickload '(:lack-request :linebot :uiop) :silent t)) 6 | 7 | (in-package #:cl-user) 8 | (defpackage #:linebot/examples/echo-handler 9 | (:use #:cl 10 | #:lack.request)) 11 | (in-package #:linebot/examples/echo-handler) 12 | 13 | (setf linebot:*channel-secret* (uiop:getenv "LINE_CHANNEL_SECRET")) 14 | (setf linebot:*channel-access-token* (uiop:getenv "LINE_CHANNEL_ACCESS_TOKEN")) 15 | 16 | (defclass echo-handler (linebot:webhook-handler) ()) 17 | (defvar *handler* (make-instance 'echo-handler)) 18 | 19 | (defmethod linebot:handle-message ((handler echo-handler) (event linebot:message-event) (message linebot:text-message)) 20 | (linebot:reply-message 21 | (linebot:event-reply-token event) 22 | (make-instance 'linebot:text-send-message 23 | :text (linebot:message-text message)))) 24 | 25 | (lambda (env) 26 | (let ((req (make-request env))) 27 | (unless (and (eq (request-method req) :post) 28 | (string= (request-path-info req) "/callback")) 29 | (return '(404 () ("Not Found")))) 30 | 31 | (handler-case 32 | (progn 33 | (linebot:handle *handler* 34 | (request-content req) 35 | (gethash "x-line-signature" (request-headers req))) 36 | '(200 () ("ok"))) 37 | (linebot:invalid-signature () '(400 () ("Invalid signature")))))) 38 | -------------------------------------------------------------------------------- /linebot/errors.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/errors 3 | (:use #:cl) 4 | (:export #:api-error 5 | #:invalid-signature 6 | #:invalid-json-content 7 | #:invalid-event-type 8 | #:invalid-message-type 9 | #:invalid-source-type 10 | #:invalid-beacon-type)) 11 | (in-package #:linebot/errors) 12 | 13 | (define-condition api-error (error) ()) 14 | 15 | (define-condition invalid-signature (api-error) 16 | ((signature :initarg :signature)) 17 | (:report (lambda (error stream) 18 | (format stream "Invalid X-Line-Signature header: ~S" 19 | (slot-value error 'signature))))) 20 | 21 | (define-condition invalid-json-content (api-error) 22 | ((content :initarg :content)) 23 | (:report (lambda (error stream) 24 | (format stream "Failed to decode JSON content:~% ~S" 25 | (slot-value error 'content))))) 26 | 27 | (define-condition invalid-event-type (api-error) 28 | ((type :initarg :type)) 29 | (:report (lambda (error stream) 30 | (format stream "Invalid event type: ~S" (slot-value error 'type))))) 31 | 32 | (define-condition invalid-message-type (api-error) 33 | ((type :initarg :type)) 34 | (:report (lambda (error stream) 35 | (format stream "Invalid message type: ~S" (slot-value error 'type))))) 36 | 37 | (define-condition invalid-source-type (api-error) 38 | ((type :initarg :type)) 39 | (:report (lambda (error stream) 40 | (format stream "Invalid source type: ~S" (slot-value error 'type))))) 41 | 42 | (define-condition invalid-beacon-type (api-error) 43 | ((type :initarg :type)) 44 | (:report (lambda (error stream) 45 | (format stream "Invalid beacon type: ~S" (slot-value error 'type))))) 46 | -------------------------------------------------------------------------------- /linebot/app.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/app 3 | (:use #:cl) 4 | (:import-from #:linebot 5 | #:invalid-signature) 6 | (:import-from #:linebot/handler 7 | #:webhook-handler 8 | #:handle 9 | #:invalid-signature) 10 | (:import-from #:lack.component 11 | #:lack-component 12 | #:call) 13 | (:import-from #:lack.request 14 | #:make-request 15 | #:request-method 16 | #:request-path-info 17 | #:request-content 18 | #:request-headers) 19 | (:import-from #:vom) 20 | (:export #:app 21 | #:*request*)) 22 | (in-package #:linebot/app) 23 | 24 | (defparameter *request* nil) 25 | 26 | (defclass app (lack-component linebot:webhook-handler) 27 | ((callback :type string 28 | :initarg :callback 29 | :reader app-callback))) 30 | 31 | (defmethod call ((app app) env) 32 | (let ((*request* (make-request env))) 33 | (unless (and (eq (request-method *request*) :post) 34 | (string= (request-path-info *request*) (app-callback app))) 35 | (return-from call '(404 () ("Not Found")))) 36 | 37 | (handler-bind ((dex:http-request-failed 38 | (lambda (e) 39 | (vom:error "~A" e) 40 | (let ((restart (find-restart 'dex:ignore-and-continue e))) 41 | (when restart 42 | (invoke-restart restart)))))) 43 | (handler-case 44 | (progn 45 | (linebot:handle app 46 | (request-content *request*) 47 | (gethash "x-line-signature" (request-headers *request*))) 48 | '(200 () ("ok"))) 49 | (linebot:invalid-signature () '(400 () ("Invalid signature"))))))) 50 | -------------------------------------------------------------------------------- /linebot/models/source.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/source 3 | (:use #:cl) 4 | (:import-from #:linebot/models/base 5 | #:json-serializable) 6 | (:import-from #:linebot/errors 7 | #:invalid-source-type) 8 | (:import-from #:assoc-utils 9 | #:aget) 10 | (:export #:source 11 | #:make-source 12 | #:source-type 13 | #:source-user 14 | #:user-id 15 | #:source-group 16 | #:group-id 17 | #:source-room 18 | #:room-id)) 19 | (in-package #:linebot/models/source) 20 | 21 | (defclass source (json-serializable) 22 | ((type :accessor source-type))) 23 | 24 | (defun type-to-class (type) 25 | (check-type type string) 26 | (cond 27 | ((string= type "user") 'source-user) 28 | ((string= type "group") 'source-group) 29 | ((string= type "room") 'source-room) 30 | (t (error 'invalid-source-type :type type)))) 31 | 32 | (defun make-source (alist) 33 | (make-instance (type-to-class (aget alist "type")) 34 | :alist alist)) 35 | 36 | (defclass source-user (source) 37 | ((type :initform :user) 38 | (user-id :type string 39 | :initarg :user-id 40 | :accessor user-id))) 41 | 42 | (defmethod initialize-instance ((object source-user) &key alist &allow-other-keys) 43 | (call-next-method object :user-id (aget alist "userId"))) 44 | 45 | (defclass source-group (source) 46 | ((type :initform :group) 47 | (group-id :type string 48 | :initarg :group-id 49 | :accessor group-id))) 50 | 51 | (defmethod initialize-instance ((object source-group) &key alist &allow-other-keys) 52 | (call-next-method object :group-id (aget alist "groupId"))) 53 | 54 | (defclass source-room (source) 55 | ((type :initform :room) 56 | (room-id :type string 57 | :initarg :room-id 58 | :accessor room-id))) 59 | 60 | (defmethod initialize-instance ((object source-room) &key alist &allow-other-keys) 61 | (call-next-method object :room-id (aget alist "roomId"))) 62 | -------------------------------------------------------------------------------- /linebot/models/send-message.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/send-message 3 | (:use #:cl) 4 | (:import-from #:linebot/models/base 5 | #:json-serializable) 6 | (:export #:send-message 7 | #:text-send-message 8 | #:image-send-message 9 | #:video-send-message 10 | #:audio-send-message 11 | #:location-send-message 12 | #:sticker-send-message)) 13 | (in-package #:linebot/models/send-message) 14 | 15 | (defclass send-message (json-serializable) 16 | ((type :type keyword))) 17 | 18 | (defclass text-send-message (send-message) 19 | ((type :initform :text) 20 | (text :type string 21 | :initarg :text))) 22 | 23 | (defclass image-send-message (send-message) 24 | ((type :initform :image) 25 | (original-content-url :type string 26 | :initarg :original-content-url) 27 | (preview-image-url :type string 28 | :initarg :preview-image-url))) 29 | 30 | (defclass video-send-message (send-message) 31 | ((type :initform :video) 32 | (original-content-url :type string 33 | :initarg :original-content-url) 34 | (preview-image-url :type string 35 | :initarg :preview-image-url))) 36 | 37 | (defclass audio-send-message (send-message) 38 | ((type :initform :audio) 39 | (original-content-url :type string 40 | :initarg :original-content-url) 41 | (duration :type integer ;; milliseconds 42 | :initarg :duration))) 43 | 44 | (defclass location-send-message (send-message) 45 | ((type :initform :location) 46 | (title :type string 47 | :initarg :title) 48 | (address :type string 49 | :initarg :title) 50 | (latitude :type double-float 51 | :initarg :latitude) 52 | (longitude :type double-float 53 | :initarg :longitude))) 54 | 55 | (defclass sticker-send-message (send-message) 56 | ((type :initform :sticker) 57 | (package-id :type string 58 | :initarg :package-id) 59 | (sticker-id :type string 60 | :initarg :sticker-id))) 61 | -------------------------------------------------------------------------------- /linebot/api.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/api 3 | (:use #:cl) 4 | (:import-from #:linebot/http 5 | #:request) 6 | (:import-from #:linebot/models/profile 7 | #:make-profile) 8 | (:import-from #:alexandria 9 | #:ensure-list) 10 | (:import-from #:jonathan 11 | #:to-json) 12 | (:export #:reply-message 13 | #:push-message 14 | #:get-message-content 15 | #:get-profile 16 | #:leave-room 17 | #:leave-group)) 18 | (in-package #:linebot/api) 19 | 20 | (defparameter *reply-token* nil) 21 | (defun reply-message (messages &optional (reply-token *reply-token*)) 22 | (check-type reply-token string) 23 | (let ((messages (ensure-list messages))) 24 | (request "message/reply" 25 | :method :post 26 | :headers '((:content-type . "application/json")) 27 | :content (jojo:to-json `(("replyToken" . ,reply-token) 28 | ("messages" . ,messages)) 29 | :from :alist)))) 30 | 31 | (defun push-message (messages to) 32 | (check-type to string) 33 | (let ((messages (ensure-list messages))) 34 | (request "message/push" 35 | :method :post 36 | :headers '((:content-type . "application/json")) 37 | :content (jojo:to-json `(("to" . ,to) 38 | ("messages" . ,messages)) 39 | :from :alist)))) 40 | 41 | (defun get-message-content (message-id) 42 | (check-type message-id string) 43 | (request (format nil "message/~A/content" message-id) 44 | :want-stream t)) 45 | 46 | (defun get-profile (user-id) 47 | (check-type user-id string) 48 | (let ((res (request (format nil "profile/~A" user-id) 49 | :method :get))) 50 | (make-profile (jojo:parse res :as :alist)))) 51 | 52 | (defun leave-room (room-id) 53 | (check-type room-id string) 54 | (request (format nil "room/~A/leave" room-id) 55 | :method :post)) 56 | 57 | (defun leave-group (group-id) 58 | (check-type group-id string) 59 | (request (format nil "group/~A/leave" group-id) 60 | :method :post)) 61 | -------------------------------------------------------------------------------- /linebot/models/imagemap.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/imagemap 3 | (:use #:cl) 4 | (:import-from #:linebot/models/base 5 | #:json-serializable) 6 | (:import-from #:linebot/models/send-message 7 | #:send-message) 8 | (:export #:imagemap-send-message 9 | #:imagemap-action 10 | #:imagemap-uri-action 11 | #:imagemap-message-action 12 | #:imagemap-area)) 13 | (in-package #:linebot/models/imagemap) 14 | 15 | (defclass base-size (json-serializable) 16 | ((width :type number 17 | :initarg :width) 18 | (height :type number 19 | :initarg :height))) 20 | 21 | (defclass imagemap-send-message (send-message) 22 | ((type :initform :imagemap) 23 | (base-url :type string 24 | :initarg :base-url) 25 | (alt-text :type string 26 | :initarg :alt-text) 27 | (base-size :type base-size) 28 | (actions :type list 29 | :initarg :actions))) 30 | 31 | (defmethod initialize-instance :after ((object imagemap-send-message) &key base-width base-height &allow-other-keys) 32 | (setf (slot-value object 'base-size) 33 | (make-instance 'base-size 34 | :width base-width 35 | :height base-height))) 36 | 37 | (defclass imagemap-action (json-serializable) 38 | ((type :type :keyword) 39 | (area :type imagemap-area 40 | :initarg :area))) 41 | 42 | (defmethod initialize-instance :after ((action imagemap-action) &key area area-x area-y area-width area-height &allow-other-keys) 43 | (setf (slot-value action 'area) 44 | (or area 45 | (make-instance 'imagemap-area 46 | :x area-x 47 | :y area-y 48 | :width area-width 49 | :height area-height)))) 50 | 51 | (defclass imagemap-uri-action (imagemap-action) 52 | ((type :initform :uri) 53 | (link-uri :type string 54 | :initarg :link-uri))) 55 | 56 | (defclass imagemap-message-action (imagemap-action) 57 | ((type :initform :message) 58 | (text :type string 59 | :initarg :text))) 60 | 61 | (defclass imagemap-area (json-serializable) 62 | ((x :type number 63 | :initarg :x) 64 | (y :type number 65 | :initarg :y) 66 | (width :type number 67 | :initarg :width) 68 | (height :type number 69 | :initarg :height))) 70 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # cl-line-bot-sdk 2 | 3 | [![Build Status](https://travis-ci.org/fukamachi/cl-line-bot-sdk.svg?branch=master)](https://travis-ci.org/fukamachi/cl-line-bot-sdk) 4 | [![Coverage Status](https://coveralls.io/repos/github/fukamachi/cl-line-bot-sdk/badge.svg?branch=master)](https://coveralls.io/github/fukamachi/cl-line-bot-sdk?branch=master) 5 | 6 | Common Lisp SDK for the [LINE Messaging API](https://devdocs.line.me/en/). 7 | 8 | ## Usage 9 | 10 | ```common-lisp 11 | (ql:quickload :linebot/app) 12 | 13 | (defclass echo-app (linebot/app:app) ()) 14 | 15 | (defmethod linebot:handle-message-event ((handler echo-app) 16 | (event linebot:message-event) 17 | (message linebot:text-message)) 18 | (linebot:reply-message 19 | (make-instance 'linebot:text-send-message 20 | :text (linebot:message-text message)))) 21 | 22 | (make-instance 'echo-app 23 | :channel-secret "" 24 | :channel-access-token "" 25 | :callback "/callback") 26 | ``` 27 | 28 | ``` 29 | $ clackup echo.lisp 30 | ``` 31 | 32 | ## Testing 33 | 34 | ```common-lisp 35 | (use-package :prove) 36 | (use-package :linebot/tests) 37 | (import '(assoc-utils:aget lack.request:request-body-parameters)) 38 | 39 | (plan 1) 40 | 41 | (subtest-lineapp "echo" 42 | (make-instance 'echo-app 43 | :callback "/callback") 44 | (emit-webhook 45 | (linebot:make-event 46 | `(("type" . "message") 47 | ("timestamp" . ,(current-timestamp)) 48 | ("source" . (("type" . "user") 49 | ("userId" . ,(dummy-user-id)))) 50 | ("replyToken" . ,(dummy-reply-token)) 51 | ("message" . (("type" . "text") 52 | ("text" . "こんにちは")))))) 53 | 54 | (let ((requests (lineapp-requests))) 55 | (is (length requests) 1 56 | "1 response") 57 | (let ((params (request-body-parameters (aref requests 0)))) 58 | (is (length (aget params "messages")) 1 59 | "Has 1 message") 60 | (is (aget (first (aget params "messages")) "type") "text" 61 | "The message is text one") 62 | (is (aget (first (aget params "messages")) "text") "こんにちは" 63 | "The message says こんにちは")))) 64 | 65 | (finalize) 66 | ``` 67 | 68 | ## Installation 69 | 70 | ``` 71 | $ ros install fukamachi/cl-line-bot-sdk 72 | ``` 73 | 74 | ## Author 75 | 76 | * Eitaro Fukamachi (e.arrows@gmail.com) 77 | 78 | ## Copyright 79 | 80 | Copyright (c) 2016 Eitaro Fukamachi (e.arrows@gmail.com) 81 | 82 | ## License 83 | 84 | Licensed under the BSD 2-Clause License. 85 | -------------------------------------------------------------------------------- /linebot/models/template.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/template 3 | (:use #:cl) 4 | (:import-from #:linebot/models/base 5 | #:json-serializable) 6 | (:import-from #:linebot/models/send-message 7 | #:send-message) 8 | (:export #:template-send-message 9 | #:template 10 | #:buttons-template 11 | #:confirm-template 12 | #:carousel-template 13 | #:carousel-column 14 | 15 | #:template-action 16 | #:postback-template-action 17 | #:message-template-action 18 | #:uri-template-action)) 19 | (in-package #:linebot/models/template) 20 | 21 | (defclass template-send-message (send-message) 22 | ((type :initform :template) 23 | (alt-text :type string 24 | :initarg :alt-text) 25 | (template :type template 26 | :initarg :template))) 27 | 28 | (defclass template (json-serializable) 29 | ((type :type keyword 30 | :initarg :type))) 31 | 32 | (defclass buttons-template (template) 33 | ((type :initform :buttons) 34 | (thumbnail-image-url :type (or string null) 35 | :initarg :thumbnail-image-url) 36 | (title :type (or string null) 37 | :initarg :title) 38 | (text :type string 39 | :initarg :text) 40 | (actions :type list 41 | :initarg :actions))) 42 | 43 | (defclass confirm-template (template) 44 | ((type :initform :confirm) 45 | (text :type string 46 | :initarg :text) 47 | (actions :type list 48 | :initarg :actions))) 49 | 50 | (defclass carousel-template (template) 51 | ((type :initform :carousel) 52 | (columns :type list 53 | :initarg :columns))) 54 | 55 | (defclass carousel-column (json-serializable) 56 | ((thumbnail-image-url :type (or string null) 57 | :initarg :thumbnail-image-url) 58 | (title :type (or string null) 59 | :initarg :title) 60 | (text :type string 61 | :initarg :text) 62 | (actions :type list 63 | :initarg :actions))) 64 | 65 | (defclass template-action (json-serializable) 66 | ((type :type keyword 67 | :initarg :type) 68 | (label :type string 69 | :initarg :label))) 70 | 71 | (defclass postback-template-action (template-action) 72 | ((type :initform :postback) 73 | (data :type string 74 | :initarg :data) 75 | (text :type (or string null) 76 | :initarg :text))) 77 | 78 | (defclass message-template-action (template-action) 79 | ((type :initform :message) 80 | (text :type string 81 | :initarg :text))) 82 | 83 | (defclass uri-template-action (template-action) 84 | ((type :initform :uri) 85 | (label :type string 86 | :initarg :label) 87 | (uri :type string 88 | :initarg :uri))) 89 | -------------------------------------------------------------------------------- /tests/webhook.json: -------------------------------------------------------------------------------- 1 | { 2 | "events": [{ 3 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 4 | "type": "message", 5 | "timestamp": 1462629479859, 6 | "source": { 7 | "type": "user", 8 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 9 | }, 10 | "message": { 11 | "id": "325708", 12 | "type": "text", 13 | "text": "Hello, world" 14 | } 15 | }, { 16 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 17 | "type": "message", 18 | "timestamp": 1462629479859, 19 | "source": { 20 | "type": "room", 21 | "roomId": "U206d25c2ea6bd87c17655609a1c37cb8" 22 | }, 23 | "message": { 24 | "id": "325708", 25 | "type": "image" 26 | } 27 | }, { 28 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 29 | "type": "message", 30 | "timestamp": 1462629479859, 31 | "source": { 32 | "type": "user", 33 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 34 | }, 35 | "message": { 36 | "id": "325708", 37 | "type": "video" 38 | } 39 | }, { 40 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 41 | "type": "message", 42 | "timestamp": 1462629479859, 43 | "source": { 44 | "type": "user", 45 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 46 | }, 47 | "message": { 48 | "id": "325708", 49 | "type": "audio" 50 | } 51 | }, { 52 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 53 | "type": "message", 54 | "timestamp": 1462629479859, 55 | "source": { 56 | "type": "user", 57 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 58 | }, 59 | "message": { 60 | "id": "325708", 61 | "type": "location", 62 | "title": "my location", 63 | "address": "Tokyo", 64 | "latitude": 35.65910807942215, 65 | "longitude": 139.70372892916203 66 | } 67 | }, { 68 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 69 | "type": "message", 70 | "timestamp": 1462629479859, 71 | "source": { 72 | "type": "user", 73 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 74 | }, 75 | "message": { 76 | "id": "325708", 77 | "type": "sticker", 78 | "packageId": "1", 79 | "stickerId": "1" 80 | } 81 | }, { 82 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 83 | "type": "follow", 84 | "timestamp": 1462629479859, 85 | "source": { 86 | "type": "user", 87 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 88 | } 89 | }, { 90 | "type": "unfollow", 91 | "timestamp": 1462629479859, 92 | "source": { 93 | "type": "user", 94 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 95 | } 96 | }, { 97 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 98 | "type": "join", 99 | "timestamp": 1462629479859, 100 | "source": { 101 | "type": "group", 102 | "groupId": "cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" 103 | } 104 | }, { 105 | "type": "leave", 106 | "timestamp": 1462629479859, 107 | "source": { 108 | "type": "group", 109 | "groupId": "cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" 110 | } 111 | }, { 112 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 113 | "type": "postback", 114 | "timestamp": 1462629479859, 115 | "source": { 116 | "type": "user", 117 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 118 | }, 119 | "postback": { 120 | "data": "action=buyItem&itemId=123123&color=red" 121 | } 122 | }, { 123 | "replyToken": "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA", 124 | "type": "beacon", 125 | "timestamp": 1462629479859, 126 | "source": { 127 | "type": "user", 128 | "userId": "U206d25c2ea6bd87c17655609a1c37cb8" 129 | }, 130 | "beacon": { 131 | "hwid": "d41d8cd98f", 132 | "type": "enter" 133 | } 134 | }] 135 | } 136 | -------------------------------------------------------------------------------- /linebot/models/message.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/message 3 | (:use #:cl) 4 | (:import-from #:linebot/models/base 5 | #:json-serializable) 6 | (:import-from #:linebot/errors 7 | #:invalid-message-type) 8 | (:import-from #:assoc-utils 9 | #:aget) 10 | (:export #:message 11 | #:text-message 12 | #:image-message 13 | #:video-message 14 | #:audio-message 15 | #:location-message 16 | #:sticker-message 17 | 18 | ;; 19 | ;; Constructor 20 | #:make-message 21 | 22 | ;; 23 | ;; Accessors 24 | #:message-id 25 | #:message-type 26 | #:message-text 27 | 28 | ;; for location-message 29 | #:message-location-title 30 | #:message-location-address 31 | #:message-location-latitude 32 | #:message-location-longitude 33 | 34 | ;; for sticker-message 35 | #:message-sticker-package-id 36 | #:message-sticker-id)) 37 | (in-package #:linebot/models/message) 38 | 39 | (defclass message (json-serializable) 40 | ((id :type (or string null) 41 | :initarg :id 42 | :initform nil 43 | :accessor message-id) 44 | (type :type keyword 45 | :accessor message-type))) 46 | 47 | (defun type-to-class (type) 48 | (cond 49 | ((string= type "text") 'text-message) 50 | ((string= type "image") 'image-message) 51 | ((string= type "video") 'video-message) 52 | ((string= type "audio") 'audio-message) 53 | ((string= type "location") 'location-message) 54 | ((string= type "sticker") 'sticker-message) 55 | (t (error 'invalid-message-type :type type)))) 56 | 57 | (defun make-message (alist) 58 | (make-instance (type-to-class (aget alist "type")) 59 | :alist alist)) 60 | 61 | (defmethod initialize-instance :after ((object message) &key alist &allow-other-keys) 62 | (setf (message-id object) (aget alist "id"))) 63 | 64 | (defclass text-message (message) 65 | ((type :initform :text) 66 | (text :type string 67 | :initarg :text 68 | :accessor message-text))) 69 | 70 | (defmethod initialize-instance ((object text-message) &key alist &allow-other-keys) 71 | (call-next-method object :text (aget alist "text"))) 72 | 73 | (defclass image-message (message) 74 | ((type :initform :image))) 75 | 76 | (defclass video-message (message) 77 | ((type :initform :video))) 78 | 79 | (defclass audio-message (message) 80 | ((type :initform :audio))) 81 | 82 | (defclass location-message (message) 83 | ((type :initform :location) 84 | (title :type string 85 | :initarg :title 86 | :accessor message-location-title) 87 | (address :type string 88 | :initarg :address 89 | :accessor message-location-address) 90 | (latitude :type double-float 91 | :initarg :latitude 92 | :accessor message-location-latitude) 93 | (longitude :type double-float 94 | :initarg :longitude 95 | :accessor message-location-longitude))) 96 | 97 | (defmethod initialize-instance ((object location-message) &key alist &allow-other-keys) 98 | (call-next-method object 99 | :title (aget alist "title") 100 | :address (aget alist "address") 101 | :latitude (aget alist "latitude") 102 | :longitude (aget alist "longitude"))) 103 | 104 | (defclass sticker-message (message) 105 | ((type :initform :sticker) 106 | (package-id :type string 107 | :initarg :package-id 108 | :accessor message-sticker-package-id) 109 | (sticker-id :type string 110 | :initarg :sticker-id 111 | :accessor message-sticker-id))) 112 | 113 | (defmethod initialize-instance ((object sticker-message) &key alist &allow-other-keys) 114 | (call-next-method object 115 | :package-id (aget alist "packageId") 116 | :sticker-id (aget alist "stickerId"))) 117 | -------------------------------------------------------------------------------- /linebot/handler.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/handler 3 | (:use #:cl) 4 | (:import-from #:linebot/webhook 5 | #:validate-signature 6 | #:parse-request) 7 | (:import-from #:linebot/models/event 8 | #:event 9 | #:message-event 10 | #:follow-event 11 | #:unfollow-event 12 | #:join-event 13 | #:leave-event 14 | #:postback-event 15 | #:beacon-event 16 | #:replyable-event 17 | #:event-type 18 | #:event-reply-token 19 | #:event-message 20 | #:event-postback-data 21 | #:beacon 22 | #:event-beacon) 23 | (:import-from #:linebot/models/message 24 | #:message) 25 | (:import-from #:linebot/api 26 | #:*reply-token*) 27 | (:import-from #:linebot/config 28 | #:*channel-secret* 29 | #:*channel-access-token*) 30 | (:import-from #:linebot/errors 31 | #:invalid-signature) 32 | (:export #:webhook-handler 33 | #:handle 34 | #:handle-event 35 | #:handle-message-event 36 | #:handle-follow-event 37 | #:handle-unfollow-event 38 | #:handle-join-event 39 | #:handle-leave-event 40 | #:handle-postback-event 41 | #:handle-beacon-event)) 42 | (in-package #:linebot/handler) 43 | 44 | (defclass webhook-handler () 45 | ((channel-secret :initarg :channel-secret 46 | :initform *channel-secret*) 47 | (channel-access-token :initarg :channel-access-token 48 | :initform *channel-access-token*))) 49 | 50 | (defgeneric handle (handler content signature) 51 | (:method ((handler webhook-handler) content signature) 52 | (let ((*channel-secret* (slot-value handler 'channel-secret)) 53 | (*channel-access-token* (slot-value handler 'channel-access-token))) 54 | (unless (validate-signature content signature) 55 | (error 'invalid-signature :signature signature)) 56 | 57 | (dolist (event (parse-request content)) 58 | (let ((*reply-token* (if (typep event 'replyable-event) 59 | (event-reply-token event) 60 | nil))) 61 | (handle-event handler event)))))) 62 | 63 | (defgeneric handle-event (handler event) 64 | (:method ((handler webhook-handler) (event message-event)) 65 | (handle-message-event handler event (event-message event))) 66 | (:method ((handler webhook-handler) (event follow-event)) 67 | (handle-follow-event handler event)) 68 | (:method ((handler webhook-handler) (event unfollow-event)) 69 | (handle-unfollow-event handler event)) 70 | (:method ((handler webhook-handler) (event join-event)) 71 | (handle-join-event handler event)) 72 | (:method ((handler webhook-handler) (event leave-event)) 73 | (handle-leave-event handler event)) 74 | (:method ((handler webhook-handler) (event postback-event)) 75 | (handle-postback-event handler event (event-postback-data event))) 76 | (:method ((handler webhook-handler) (event beacon-event)) 77 | (handle-beacon-event handler event (event-beacon event)))) 78 | 79 | (defgeneric handle-message-event (handler event message) 80 | (:method ((handler webhook-handler) (event message-event) (message message)))) 81 | 82 | (defgeneric handle-follow-event (handler event) 83 | (:method ((handler webhook-handler) (event follow-event)))) 84 | 85 | (defgeneric handle-unfollow-event (handler event) 86 | (:method ((handler webhook-handler) (event unfollow-event)))) 87 | 88 | (defgeneric handle-join-event (handler event) 89 | (:method ((handler webhook-handler) (event join-event)))) 90 | 91 | (defgeneric handle-leave-event (handler event) 92 | (:method ((handler webhook-handler) (event leave-event)))) 93 | 94 | (defgeneric handle-postback-event (handler event data) 95 | (:method ((handler webhook-handler) (event postback-event) data))) 96 | 97 | (defgeneric handle-beacon-event (handler event beacon) 98 | (:method ((handler webhook-handler) (event beacon-event) (beacon beacon)))) 99 | -------------------------------------------------------------------------------- /linebot/models/event.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/models/event 3 | (:use #:cl) 4 | (:import-from #:linebot/models/message 5 | #:make-message 6 | #:text-message 7 | #:message-text) 8 | (:import-from #:linebot/models/source 9 | #:source 10 | #:make-source) 11 | (:import-from #:linebot/models/base 12 | #:json-serializable) 13 | (:import-from #:linebot/errors 14 | #:invalid-event-type 15 | #:invalid-beacon-type) 16 | (:import-from #:local-time 17 | #:timestamp 18 | #:unix-to-timestamp) 19 | (:import-from #:assoc-utils 20 | #:aget) 21 | (:import-from #:alexandria 22 | #:alist-hash-table) 23 | (:export #:event 24 | #:message-event 25 | #:follow-event 26 | #:unfollow-event 27 | #:join-event 28 | #:leave-event 29 | #:postback-event 30 | #:beacon-event 31 | #:beacon 32 | #:enter-beacon 33 | 34 | ;; 35 | ;; Constructor 36 | #:make-event 37 | 38 | ;; 39 | ;; Accessors 40 | #:event-type 41 | #:event-timestamp 42 | #:event-source 43 | 44 | ;; Only for replyable-event 45 | #:event-reply-token 46 | 47 | ;; for message-event 48 | #:event-message 49 | #:event-message-text 50 | 51 | ;; for postback-event 52 | #:event-postback-data 53 | 54 | ;; for beacon-event 55 | #:event-beacon 56 | #:beacon-type 57 | #:beacon-hwid)) 58 | (in-package #:linebot/models/event) 59 | 60 | (defclass event (json-serializable) 61 | ((type :accessor event-type) 62 | (timestamp :type timestamp 63 | :initarg :timestamp 64 | :accessor event-timestamp) 65 | (source :type source 66 | :initarg :source 67 | :accessor event-source))) 68 | 69 | (defvar *type-to-class* 70 | (alexandria:alist-hash-table 71 | '(("message" . message-event) 72 | ("follow" . follow-event) 73 | ("unfollow" . unfollow-event) 74 | ("join" . join-event) 75 | ("leave" . leave-event) 76 | ("postback" . postback-event) 77 | ("beacon" . beacon-event)) 78 | :test 'equal)) 79 | 80 | (defun type-to-class (type) 81 | (or (gethash type *type-to-class*) 82 | (error 'invalid-event-type :type type))) 83 | 84 | (defun make-event (alist) 85 | (make-instance (type-to-class (aget alist "type")) 86 | :alist alist)) 87 | 88 | (defmethod initialize-instance :after ((object event) &key alist &allow-other-keys) 89 | (setf (event-timestamp object) 90 | (multiple-value-bind (sec millisec) 91 | (floor (aget alist "timestamp") 1000) 92 | (unix-to-timestamp sec :nsec (* millisec 1000 1000)))) 93 | (setf (event-source object) 94 | (make-source (aget alist "source")))) 95 | 96 | (defclass replyable-event () 97 | ((reply-token :type string 98 | :initarg :reply-token 99 | :accessor event-reply-token))) 100 | 101 | (defmethod initialize-instance :after ((object replyable-event) &key alist &allow-other-keys) 102 | (setf (event-reply-token object) 103 | (aget alist "replyToken"))) 104 | 105 | (defclass message-event (event replyable-event) 106 | ((type :initform :message) 107 | (message :type message 108 | :initarg :message 109 | :accessor event-message))) 110 | 111 | (defmethod initialize-instance ((object message-event) &key alist &allow-other-keys) 112 | (call-next-method object :message (make-message (aget alist "message")))) 113 | 114 | (defgeneric event-message-text (event) 115 | (:method ((event message-event)) 116 | (let ((message (event-message event))) 117 | (check-type message text-message) 118 | (message-text message)))) 119 | 120 | (defclass follow-event (event replyable-event) 121 | ((type :initform :follow))) 122 | 123 | (defclass unfollow-event (event) 124 | ((type :initform :unfollow))) 125 | 126 | (defclass join-event (event replyable-event) 127 | ((type :initform :join))) 128 | 129 | (defclass leave-event (event) 130 | ((type :initform :leave))) 131 | 132 | (defclass postback (json-serializable) 133 | ((data :type string 134 | :initarg :data))) 135 | 136 | (defclass postback-event (event replyable-event) 137 | ((type :initform :postback) 138 | (postback :type postback 139 | :initarg :postback))) 140 | 141 | (defmethod initialize-instance ((object postback-event) &key alist &allow-other-keys) 142 | (call-next-method object 143 | :postback 144 | (make-instance 'postback 145 | :data (aget (aget alist "postback") "data")))) 146 | 147 | (defgeneric event-postback-data (event) 148 | (:method ((event postback-event)) 149 | (slot-value (slot-value event 'postback) 'data))) 150 | 151 | (defclass beacon (json-serializable) 152 | ((hwid :type string 153 | :initarg :hwid 154 | :accessor beacon-hwid) 155 | (type :type keyword 156 | :accessor beacon-type))) 157 | 158 | (defclass enter-beacon (beacon) 159 | ((type :initform :enter))) 160 | 161 | (defclass beacon-event (event replyable-event) 162 | ((type :initform :beacon) 163 | (beacon :type beacon 164 | :initarg :beacon 165 | :accessor event-beacon))) 166 | 167 | (defmethod initialize-instance ((object beacon-event) &key alist &allow-other-keys) 168 | (let ((beacon (aget alist "beacon"))) 169 | (unless (string= (aget beacon "type") "enter") 170 | (error 'invalid-beacon-type :type (aget beacon "type"))) 171 | (call-next-method object 172 | :beacon (make-instance 'enter-beacon 173 | :hwid (aget beacon "hwid"))))) 174 | -------------------------------------------------------------------------------- /linebot/tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/tests 3 | (:use #:cl 4 | #:re21) 5 | (:import-from #:linebot/tests/util 6 | #:random-port 7 | #:make-random-string) 8 | (:import-from #:linebot 9 | #:*message-api-endpoint*) 10 | (:import-from #:linebot/handler) 11 | (:import-from #:linebot/app) 12 | (:import-from #:lack.component 13 | #:lack-component 14 | #:call) 15 | (:import-from #:lack.request 16 | #:make-request) 17 | (:import-from #:clack 18 | #:clackup 19 | #:stop) 20 | (:import-from #:jonathan 21 | #:to-json) 22 | (:import-from #:babel 23 | #:string-to-octets) 24 | (:import-from #:dexador 25 | #:post) 26 | (:import-from #:bordeaux-threads 27 | #:*default-special-bindings*) 28 | (:import-from #:ironclad 29 | #:make-hmac 30 | #:ascii-string-to-byte-array 31 | #:update-hmac 32 | #:hmac-digest) 33 | (:import-from #:cl-base64 34 | #:usb8-array-to-base64-string) 35 | (:import-from #:prove 36 | #:subtest) 37 | (:import-from #:local-time 38 | #:timestamp-to-unix 39 | #:now 40 | #:timestamp-millisecond) 41 | (:import-from #:alexandria 42 | #:with-gensyms 43 | #:once-only 44 | #:ensure-list 45 | #:starts-with-subseq) 46 | (:export #:emit-webhook 47 | #:lineapp-requests 48 | #:subtest-lineapp 49 | #:dummy-user-id 50 | #:dummy-reply-token 51 | #:current-timestamp)) 52 | (in-package #:linebot/tests) 53 | 54 | (defun make-buffer () 55 | (make-array 0 :adjustable t :fill-pointer 0)) 56 | 57 | (defclass mock-app (lack.component:lack-component) 58 | ((buffer :initform (make-buffer)) 59 | (channel-secret :initarg :channel-secret) 60 | (channel-access-token :initarg :channel-access-token) 61 | (webhook-url :initarg :webhook-url))) 62 | 63 | (defvar *mock-app*) 64 | (defun lineapp-requests (&optional (app *mock-app*)) 65 | (prog1 (slot-value app 'buffer) 66 | (setf (slot-value app 'buffer) (make-buffer)))) 67 | 68 | (defun emit-webhook (events &optional (app *mock-app*)) 69 | (let* ((hmac (ironclad:make-hmac (ascii-string-to-byte-array (slot-value app 'channel-secret)) :sha256)) 70 | (content (jojo:to-json `(("events" . ,(ensure-list events))))) 71 | (content (babel:string-to-octets content))) 72 | (ironclad:update-hmac hmac content) 73 | (let ((x-line-signature (base64:usb8-array-to-base64-string (ironclad:hmac-digest hmac)))) 74 | (dex:post (slot-value app 'webhook-url) 75 | :headers `(("Content-Type" . "application/json") 76 | ("Content-Length" . ,(length content)) 77 | ("X-Line-Signature" . ,x-line-signature) 78 | ("User-Agent" . "LineBotWebhook/1.0")) 79 | :content content)))) 80 | 81 | (defmethod lack.component:call ((app mock-app) env) 82 | (let ((authorization (gethash "authorization" (getf env :headers)))) 83 | (unless authorization 84 | (return-from lack.component:call 85 | '(400 () ("Invalid authorization header")))) 86 | 87 | (destructuring-bind (&optional token) 88 | (re-groups "^Bearer (.+)$" authorization) 89 | (unless (equal token (slot-value app 'channel-access-token)) 90 | (return-from lack.component:call 91 | '(400 () ("Invalid authorization header")))))) 92 | 93 | (vector-push-extend (make-request env) (slot-value app 'buffer)) 94 | 95 | ;; Get profile 96 | (when (and (starts-with-subseq "/profile/" (getf env :path-info)) 97 | (eq (getf env :request-method) :get)) 98 | (return-from lack.component:call 99 | `(200 (:content-type "application/json") 100 | (,(jojo:to-json 101 | `(("displayName" . "Lisp Alien") 102 | ("userId" . ,(subseq (getf env :path-info) 9)) 103 | ("pictureUrl" . nil) 104 | ("statusMessage" . nil)) 105 | :from :alist))))) 106 | 107 | '(200 () ("ok"))) 108 | 109 | (defmacro subtest-lineapp (desc app &body body) 110 | (with-gensyms (app-port mock-app-port 111 | channel-secret channel-access-token 112 | callback-path acceptor mock-acceptor) 113 | (once-only (app) 114 | `(let* ((,app-port (random-port)) 115 | (,mock-app-port (random-port)) 116 | (,channel-secret (setf (slot-value ,app 'linebot/handler::channel-secret) 117 | (or (slot-value ,app 'linebot/handler::channel-secret) 118 | (make-random-string 32)))) 119 | (,channel-access-token (setf (slot-value ,app 'linebot/handler::channel-access-token) 120 | (or (slot-value ,app 'linebot/handler::channel-access-token) 121 | (make-random-string 128)))) 122 | (,callback-path (slot-value ,app 'linebot/app::callback)) 123 | (*mock-app* (make-instance 'mock-app 124 | :channel-secret ,channel-secret 125 | :channel-access-token ,channel-access-token 126 | :webhook-url 127 | (format nil "http://127.0.0.1:~A~A" 128 | ,app-port 129 | ,callback-path))) 130 | (bt:*default-special-bindings* 131 | `((linebot:*message-api-endpoint* . ,(format nil "http://127.0.0.1:~A/" ,mock-app-port))))) 132 | (let ((,acceptor (clack:clackup ,app :port ,app-port :silent t)) 133 | (,mock-acceptor (clack:clackup *mock-app* :port ,mock-app-port :silent t))) 134 | (unwind-protect (subtest ,desc ,@body) 135 | (clack:stop ,acceptor) 136 | (clack:stop ,mock-acceptor))))))) 137 | 138 | (defun dummy-user-id () 139 | (concatenate 'string '(#\U) (make-random-string 32))) 140 | 141 | (defun dummy-reply-token () 142 | (make-random-string 30)) 143 | 144 | (defun current-timestamp () 145 | (let ((now (local-time:now))) 146 | (+ (* (local-time:timestamp-to-unix now) 1000) 147 | (local-time:timestamp-millisecond now)))) 148 | -------------------------------------------------------------------------------- /tests/webhook.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:linebot/tests/webhook 3 | (:use #:cl 4 | #:linebot 5 | #:prove)) 6 | (in-package #:linebot/tests/webhook) 7 | 8 | (plan nil) 9 | 10 | (subtest "validate-signature" 11 | (ok (let ((*channel-secret* "channel-secret")) 12 | (validate-signature "bodybodybodybody" "sySijT686iD0De1RCBU22/1QAunHoSgCIAtJwDX7t18=")) 13 | "valid signature") 14 | 15 | (ok (not (let ((*channel-secret* "channel-secret")) 16 | (validate-signature "bodybodybodybody" "invalid signature"))) 17 | "invalid signature")) 18 | 19 | (subtest "parse-request" 20 | (let* ((json (uiop:read-file-string (asdf:system-relative-pathname :linebot-tests #P"tests/webhook.json"))) 21 | (events (parse-request json))) 22 | (is (length events) 12) 23 | (subtest "message" 24 | (subtest "text" 25 | (let ((event (nth 0 events))) 26 | (is-type event 'message-event) 27 | (is (event-timestamp event) 28 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 29 | :test #'local-time:timestamp=) 30 | (is-type (event-source event) 'source-user) 31 | (is (source-type (event-source event)) :user) 32 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 33 | (is-type (event-message event) 'text-message) 34 | (is (message-id (event-message event)) "325708") 35 | (is (message-type (event-message event)) :text) 36 | (is (message-text (event-message event)) "Hello, world"))) 37 | 38 | (subtest "image" 39 | (let ((event (nth 1 events))) 40 | (is-type event 'message-event) 41 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 42 | (is (event-type event) :message) 43 | (is (event-timestamp event) 44 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 45 | :test #'local-time:timestamp=) 46 | (is-type (event-source event) 'source-room) 47 | (is (source-type (event-source event)) :room) 48 | (is (room-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 49 | (is-type (event-message event) 'image-message) 50 | (is (message-id (event-message event)) "325708") 51 | (is (message-type (event-message event)) :image))) 52 | 53 | (subtest "video" 54 | (let ((event (nth 2 events))) 55 | (is-type event 'message-event) 56 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 57 | (is (event-type event) :message) 58 | (is (event-timestamp event) 59 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 60 | :test #'local-time:timestamp=) 61 | (is-type (event-source event) 'source-user) 62 | (is (source-type (event-source event)) :user) 63 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 64 | (is-type (event-message event) 'video-message) 65 | (is (message-id (event-message event)) "325708") 66 | (is (message-type (event-message event)) :video))) 67 | 68 | (subtest "audio" 69 | (let ((event (nth 3 events))) 70 | (is-type event 'message-event) 71 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 72 | (is (event-type event) :message) 73 | (is (event-timestamp event) 74 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 75 | :test #'local-time:timestamp=) 76 | (is-type (event-source event) 'source-user) 77 | (is (source-type (event-source event)) :user) 78 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 79 | (is-type (event-message event) 'audio-message) 80 | (is (message-id (event-message event)) "325708") 81 | (is (message-type (event-message event)) :audio))) 82 | 83 | (subtest "location" 84 | (let ((event (nth 4 events))) 85 | (is-type event 'message-event) 86 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 87 | (is (event-type event) :message) 88 | (is (event-timestamp event) 89 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 90 | :test #'local-time:timestamp=) 91 | (is-type (event-source event) 'source-user) 92 | (is (source-type (event-source event)) :user) 93 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 94 | (is-type (event-message event) 'location-message) 95 | (is (message-type (event-message event)) :location) 96 | (is (message-location-title (event-message event)) "my location") 97 | (is (message-location-address (event-message event)) "Tokyo") 98 | (is (message-location-latitude (event-message event)) 35.65910807942215d0) 99 | (is (message-location-longitude (event-message event)) 139.70372892916203d0))) 100 | 101 | (subtest "sticker" 102 | (let ((event (nth 5 events))) 103 | (is-type event 'message-event) 104 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 105 | (is (event-type event) :message) 106 | (is (event-timestamp event) 107 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 108 | :test #'local-time:timestamp=) 109 | (is-type (event-source event) 'source-user) 110 | (is (source-type (event-source event)) :user) 111 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 112 | (is-type (event-message event) 'sticker-message) 113 | (is (message-id (event-message event)) "325708") 114 | (is (message-type (event-message event)) :sticker) 115 | (is (message-sticker-package-id (event-message event)) "1") 116 | (is (message-sticker-id (event-message event)) "1")))) 117 | 118 | (subtest "follow" 119 | (let ((event (nth 6 events))) 120 | (is-type event 'follow-event) 121 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 122 | (is (event-type event) :follow) 123 | (is (event-timestamp event) 124 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 125 | :test #'local-time:timestamp=) 126 | (is-type (event-source event) 'source-user) 127 | (is (source-type (event-source event)) :user) 128 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8"))) 129 | 130 | (subtest "unfollow" 131 | (let ((event (nth 7 events))) 132 | (is-type event 'unfollow-event) 133 | (is (event-type event) :unfollow) 134 | (is (event-timestamp event) 135 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 136 | :test #'local-time:timestamp=) 137 | (is-type (event-source event) 'source-user) 138 | (is (source-type (event-source event)) :user) 139 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8"))) 140 | 141 | (subtest "join" 142 | (let ((event (nth 8 events))) 143 | (is-type event 'join-event) 144 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 145 | (is (event-type event) :join) 146 | (is (event-timestamp event) 147 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 148 | :test #'local-time:timestamp=) 149 | (is-type (event-source event) 'source-group) 150 | (is (source-type (event-source event)) :group) 151 | (is (group-id (event-source event)) "cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) 152 | (subtest "leave" 153 | (let ((event (nth 9 events))) 154 | (is-type event 'leave-event) 155 | (is (event-type event) :leave) 156 | (is (event-timestamp event) 157 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 158 | :test #'local-time:timestamp=) 159 | (is-type (event-source event) 'source-group) 160 | (is (source-type (event-source event)) :group) 161 | (is (group-id (event-source event)) "cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))) 162 | 163 | (subtest "postback" 164 | (let ((event (nth 10 events))) 165 | (is-type event 'postback-event) 166 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 167 | (is (event-type event) :postback) 168 | (is (event-timestamp event) 169 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 170 | :test #'local-time:timestamp=) 171 | (is-type (event-source event) 'source-user) 172 | (is (source-type (event-source event)) :user) 173 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 174 | (is (event-postback-data event) "action=buyItem&itemId=123123&color=red"))) 175 | 176 | (subtest "beacon" 177 | (let ((event (nth 11 events))) 178 | (is-type event 'beacon-event) 179 | (is (event-reply-token event) "nHuyWiB7yP5Zw52FIkcQobQuGDXCTA") 180 | (is (event-type event) :beacon) 181 | (is (event-timestamp event) 182 | (local-time:unix-to-timestamp 1462629479 :nsec 859000000) 183 | :test #'local-time:timestamp=) 184 | (is-type (event-source event) 'source-user) 185 | (is (source-type (event-source event)) :user) 186 | (is (user-id (event-source event)) "U206d25c2ea6bd87c17655609a1c37cb8") 187 | (is (beacon-hwid (event-beacon event)) "d41d8cd98f") 188 | (is (beacon-type (event-beacon event)) :enter))))) 189 | (finalize) 190 | --------------------------------------------------------------------------------