Return to Question

#lang typed/racket/base
(provide
 (prefix-out fchat- (combine-out request-ticket!
 connect
 send!
 recv!
 close!
 conn-character))
 FChatConn
 fchat-conn?)
;; ---------------------------------------------------------------------------------------------------
(require racket/match
 racket/list
 typed/racket/async-channel
 typed/net/http-client
 typed/net/uri-codec
 fchat/typed/json)
(require/typed net/url-structs
 [#:struct path/param ([path : (U String 'up 'same)]
 [param : (Listof String)])
 #:extra-constructor-name make-path/param]
 [#:struct url ([scheme : (Option String)]
 [user : (Option String)]
 [host : (Option String)]
 [port : (Option Nonnegative-Integer)]
 [path-absolute? : Boolean]
 [path : (Listof path/param)]
 [query : (Listof (Pair Symbol (Option String)))]
 [fragment : (Option String)])
 #:extra-constructor-name make-url])
(require/typed net/url
 [string->url (String -> url)])
(require/typed web-server/http
 [#:struct header ([field : Bytes] [value : Bytes])
 #:extra-constructor-name make-header])
(require/typed net/rfc6455
 [#:opaque WSConn ws-conn?]
 [ws-connect (->* (url)
 (#:headers (Listof header) #:protocol (U 'rfc6455 'hybi00))
 WSConn)]
 [ws-send! (->* (WSConn (U String Bytes Input-Port))
 (#:final-fragment? Boolean
 #:payload-type (U 'continuation 'text 'binary)
 #:flush? Boolean)
 Void)]
 [ws-recv (->* (WSConn)
 (#:stream? Boolean #:payload-type (U 'auto 'text 'binary))
 (U EOF String Bytes Input-Port))]
 [ws-close! (->* (WSConn)
 (#:status Integer #:reason String)
 Void)])
(require/typed srfi/13
 [string-index (->* (String (U Char (Char -> Boolean)))
 (Integer Integer)
 (Option Integer))])
;; ---------------------------------------------------------------------------------------------------
;; Represents a single connection to the F-chat servers.
(struct fchat-conn ([socket : (Boxof (Option WSConn))]
 [message-channel : (Async-Channelof (List String (Option JSExpr)))]
 [character : String]))
(define-type FChatConn fchat-conn)
;; Requests a new API ticket from the server, invalidating all previous tickets for the account.
;; The data is returned as a JSExpr containing the ticket and other server-provided data.
(: request-ticket! (String String -> JSExpr))
(define (request-ticket! username password)
 (define-values (response headers data)
 (http-sendrecv "www.f-list.net"
 "/json/getApiTicket.php"
 #:method "POST"
 #:data (alist->form-urlencoded
 (list (cons 'account username)
 (cons 'password password)))
 #:headers (list "Content-type: application/x-www-form-urlencoded")))
 (define json-data (read-json data))
 (cond
 [(eof-object? json-data) (error "failed to retrieve F-list API ticket")]
 [else json-data]))
;; Connects to the F-chat server with username and password, and logs in as character.
;; If debug is #t, connects to the debug server instead.
;; Returns two values, a connection handler and a synchronizable event that becomes ready
;; when the connection becomes usable.
(: connect (->*
 (#:ticket String #:username String #:character String)
 (#:debug Boolean #:client-name String #:client-version String)
 (values fchat-conn Semaphore)))
(define (connect
 #:ticket ticket
 #:username username
 #:character character
 #:debug [debug #f]
 #:client-name [client-name "chat-racket"]
 #:client-version [client-version "0.0.0"])
 ; Perform connection asynchronously
 (define ready-sem (make-semaphore))
 (define fcc (fchat-conn (box #f) (make-async-channel) character))
 (thread
 (λ ()
 ; Connect to chat server
 (define ws (ws-connect (string->url (format "ws://chat.f-list.net:~a/"
 (if debug "8722" "9722")))))
 (set-box! (fchat-conn-socket fcc) ws)
 ; Authorize with chat server
 (send! fcc "IDN" (make-hasheq `((method . "ticket")
 (account . ,username)
 (ticket . ,ticket)
 (character . ,character)
 (cname . ,client-name)
 (cversion . ,client-version))))
 ; Start worker thread
 (thread
 (λ ()
 (with-handlers ([exn:fail? void])
 (let loop ()
 (define-values (command payload) (recv-raw! fcc))
 (match command
 ["PIN"
 (send! fcc "PIN")]
 ["IDN"
 (semaphore-post ready-sem)]
 [_
 (async-channel-put (fchat-conn-message-channel fcc) (list command payload))])
 (loop)))))))
 (values fcc ready-sem))
;; Sends a command to the F-chat server. If a payload is specified,
;; its JSON-encoded value is sent with the command.
(: send! (->* (fchat-conn String) ((Option JSExpr)) Void))
(define (send! fcc command [payload #f])
 (define data (if payload
  (format "~a ~a" command (jsexpr->string payload))
 command))
 (ws-send! (unbox (fchat-conn-socket fcc)) data))
(: recv-raw! (fchat-conn -> (values String (Option JSExpr))))
(define (recv-raw! fcc)
 (define data (ws-recv (unbox (fchat-conn-socket fcc))))
 (cond
 [(string? data)
 (define space-index (string-index data #\space))
 (cond
 [space-index
 (define command (substring data 0 space-index))
 (define payload (string->jsexpr (substring data (add1 space-index))))
 (values command payload)]
 [else
 (values data #f)
 ])]
 [else (error "error recieving F-chat data")]))
;; Recieves a single command from the server. The commands are internally queued,
;; so this will return immediately if a command is on the queue, otherwise it will
;; block until a command arrives.
;; Returns the command and its accompanying payload, if it exists, otherwise #f.
(: recv! (fchat-conn -> (values String (Option JSExpr))))
(define (recv! fcc)
 (define data (async-channel-get (fchat-conn-message-channel fcc)))
 (values (first data) (second data)))
;; Closes the connection. Once the connection has been closed,
;; it cannot be reopened or otherwise reused.
(: close! (fchat-conn -> Void))
(define (close! fcc)
 (ws-close! (unbox (fchat-conn-socket fcc))))
;; Gets the name of the character associated with the given connection.
(: conn-character (fchat-conn -> String))
(define (conn-character fcc)
 (fchat-conn-character fcc))

#lang typed/racket/base
(provide
 (prefix-out fchat- (combine-out request-ticket!
 connect
 send!
 recv!
 close!
 conn-character))
 FChatConn
 fchat-conn?)
;; ---------------------------------------------------------------------------------------------------
(require racket/match
 racket/list
 typed/racket/async-channel
 typed/net/http-client
 typed/net/uri-codec
 fchat/typed/json)
(require/typed net/url-structs
 [#:struct path/param ([path : (U String 'up 'same)]
 [param : (Listof String)])
 #:extra-constructor-name make-path/param]
 [#:struct url ([scheme : (Option String)]
 [user : (Option String)]
 [host : (Option String)]
 [port : (Option Nonnegative-Integer)]
 [path-absolute? : Boolean]
 [path : (Listof path/param)]
 [query : (Listof (Pair Symbol (Option String)))]
 [fragment : (Option String)])
 #:extra-constructor-name make-url])
(require/typed net/url
 [string->url (String -> url)])
(require/typed web-server/http
 [#:struct header ([field : Bytes] [value : Bytes])
 #:extra-constructor-name make-header])
(require/typed net/rfc6455
 [#:opaque WSConn ws-conn?]
 [ws-connect (->* (url)
 (#:headers (Listof header) #:protocol (U 'rfc6455 'hybi00))
 WSConn)]
 [ws-send! (->* (WSConn (U String Bytes Input-Port))
 (#:final-fragment? Boolean
 #:payload-type (U 'continuation 'text 'binary)
 #:flush? Boolean)
 Void)]
 [ws-recv (->* (WSConn)
 (#:stream? Boolean #:payload-type (U 'auto 'text 'binary))
 (U EOF String Bytes Input-Port))]
 [ws-close! (->* (WSConn)
 (#:status Integer #:reason String)
 Void)])
(require/typed srfi/13
 [string-index (->* (String (U Char (Char -> Boolean)))
 (Integer Integer)
 (Option Integer))])
;; ---------------------------------------------------------------------------------------------------
;; Represents a single connection to the F-chat servers.
(struct fchat-conn ([socket : (Boxof (Option WSConn))]
 [message-channel : (Async-Channelof (List String (Option JSExpr)))]
 [character : String]))
(define-type FChatConn fchat-conn)
;; Requests a new API ticket from the server, invalidating all previous tickets for the account.
;; The data is returned as a JSExpr containing the ticket and other server-provided data.
(: request-ticket! (String String -> JSExpr))
(define (request-ticket! username password)
 (define-values (response headers data)
 (http-sendrecv "www.f-list.net"
 "/json/getApiTicket.php"
 #:method "POST"
 #:data (alist->form-urlencoded
 (list (cons 'account username)
 (cons 'password password)))
 #:headers (list "Content-type: application/x-www-form-urlencoded")))
 (define json-data (read-json data))
 (cond
 [(eof-object? json-data) (error "failed to retrieve F-list API ticket")]
 [else json-data]))
;; Connects to the F-chat server with username and password, and logs in as character.
;; If debug is #t, connects to the debug server instead.
;; Returns two values, a connection handler and a synchronizable event that becomes ready
;; when the connection becomes usable.
(: connect (->*
 (#:ticket String #:username String #:character String
 #:client-name String #:client-version String)
 (#:debug Boolean)
 (values fchat-conn Semaphore)))
(define (connect
 #:ticket ticket
 #:username username
 #:character character
 #:client-name client-name
 #:client-version client-version
 #:debug [debug #f])
 ; Perform connection asynchronously
 (define ready-sem (make-semaphore))
 (define fcc (fchat-conn (box #f) (make-async-channel) character))
 (thread
 (λ ()
 ; Connect to chat server
 (define ws (ws-connect (string->url (format "ws://chat.f-list.net:~a/"
 (if debug "8722" "9722")))))
 (set-box! (fchat-conn-socket fcc) ws)
 ; Authorize with chat server
 (send! fcc "IDN" (make-hasheq `((method . "ticket")
 (account . ,username)
 (ticket . ,ticket)
 (character . ,character)
 (cname . ,client-name)
 (cversion . ,client-version))))
 ; Start worker thread
 (thread
 (λ ()
 (with-handlers ([exn:fail? void])
 (let loop ()
 (define-values (command payload) (recv-raw! fcc))
 (match command
 ["PIN"
 (send! fcc "PIN")]
 ["IDN"
 (semaphore-post ready-sem)]
 [_
 (async-channel-put (fchat-conn-message-channel fcc) (list command payload))])
 (loop)))))))
 (values fcc ready-sem))
;; Sends a command to the F-chat server. If a payload is specified,
;; its JSON-encoded value is sent with the command.
(: send! (->* (fchat-conn String) ((Option JSExpr)) Void))
(define (send! fcc command [payload #f])
 (ws-send! (cast (unbox (fchat-conn-socket fcc)) WSConn)
 (encode-message command payload)))
;; Encodes a command + json payload into a single string to be
;; sent to the F-chat servers.
(: encode-message (String (Option JSExpr) -> String))
(define (encode-message command payload)
 (if payload
  (format "~a ~a" command (jsexpr->string payload))  command))
;; Internal command to actually recieve and parse data from the F-chat servers.
(: recv-raw! (fchat-conn -> (values String (Option JSExpr))))
(define (recv-raw! fcc)
 (define data (ws-recv (cast (unbox (fchat-conn-socket fcc)) WSConn)))
 (if (string? data)
 (decode-message data)
 (error "error recieving F-chat data")))
;; Decodes a message from the F-chat server into a command + json payload.
(: decode-message (String -> (values String (Option JSExpr))))
(define (decode-message message)
 (define space-index (string-index message #\space))
 (cond
 [space-index
 (define command (substring message 0 space-index))
 (define payload (string->jsexpr (substring message (add1 space-index))))
 (values command payload)]
 [else
 (values message #f)]))
;; Recieves a single command from the server. The commands are internally queued,
;; so this will return immediately if a command is on the queue, otherwise it will
;; block until a command arrives.
;; Returns the command and its accompanying payload, if it exists, otherwise #f.
(: recv! (fchat-conn -> (values String (Option JSExpr))))
(define (recv! fcc)
 (define data : (List String (Option JSExpr)) (async-channel-get (fchat-conn-message-channel fcc)))
 (values (first data) (second data)))
;; Closes the connection. Once the connection has been closed,
;; it cannot be reopened or otherwise reused.
(: close! (fchat-conn -> Void))
(define (close! fcc)
 (ws-close! (cast (unbox (fchat-conn-socket fcc)) WSConn)))
;; Gets the name of the character being used with the given connection.
(: conn-character (fchat-conn -> String))
(define (conn-character fcc)
 (fchat-conn-character fcc))

(module+ test
 (require typed/rackunit)
 
 (test-case
 "Encode a join channel message with a payload"
 (let ([command "JCH"]
 [payload : JSExpr (make-hasheq '((channel . "Frontpage")))]
 [result "JCH {\"channel\":\"Frontpage\"}"])
 (check-equal? (encode-message command payload) result
 "encoded JCH message not equal?")))
 
 (test-case
 "Encode a ping message without a payload"
 (let ([command "PIN"]
 [result "PIN"])
 (check-equal? (encode-message command #f) result
 "encoded PIN message not equal?")))
 
 (test-case
 "Decode an identification message with a payload"
 (let ([message "IDN {\"character\":\"Racket\"}"]
 [command "IDN"]
 [payload : JSExpr (make-immutable-hasheq '((character . "Racket")))])
 (define-values (c p) (decode-message message))
 (check-equal? c command "decoded IDN command not equal?")
 (check-equal? p payload "decoded IDN payload not equal?")))
 
 (test-case
 "Decode a ping message without a payload"
 (let ([message "PIN"]
 [command "PIN"])
 (define-values (c p) (decode-message message))
 (check-equal? c command "decoded PIN command not equal?")
 (check-false p "decoded PIN payload not #f"))))