1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
(define-module (qkbox toot)
#:use-module (ice-9 format)
#:use-module (web response)
#:use-module (web client)
#:use-module (json builder)
#:use-module (json parser)
#:use-module (rnrs bytevectors)
#:export (post))
(define current-mastodon-host
(make-parameter (getenv "MASTODON_HOST")))
(define current-mastodon-access-token
(make-parameter (getenv "MASTODON_ACCESS_TOKEN")))
(define* (post status
#:key
spoiler-text
visibility
sensitive?
reply-to)
(define-values (res body)
(/api/v1/statuses #:status status
#:spoiler-text spoiler-text
#:visibility visibility
#:sensitive? sensitive?
#:reply-to reply-to))
(case (response-code res)
((200)
(assoc-ref body "id"))
(else
(error "post: failed" res body))))
(define* (/api/v1/statuses #:key
status
spoiler-text
visibility
sensitive?
reply-to
media-ids)
(post-json
"/api/v1/statuses"
`(,@(if status
`((status . ,(if (string? status)
status
(format #f "~y" status))))
'())
,@(if spoiler-text
`((spoiler_text . ,spoiler-text))
'())
,@(if visibility
(case visibility
((public unlisted private direct)
`((visibility . ,visibility)))
(else
(error "post: invalid visibility (must be one of: public unlisted private direct)")))
'())
,@(if sensitive? `((sensitive . (if sensitive? #t #f)))
'())
,@(if reply-to
`((in_reply_to_id . ,reply-to))
'())
,@(if media-ids
`((media_ids . ,(list->vector (map number->string media-ids))))
'()))
#:authorization? #t))
(define* (post-json path json #:key authorization?)
(define-values (res body)
(http-post (string-append "https://"
(current-mastodon-host)
path)
#:headers `((content-type application/json)
,@(if authorization?
`((authorization
,(string->symbol
(string-append
"Bearer "
(current-mastodon-access-token)))))
'()))
#:decode-body? #t
#:body (scm->json-string json)))
(if (= 200 (response-code res))
(values res (json-string->scm (utf8->string body)))
(values res body)))
|
