src/discourse/client.sgl — sigil-discourse

1;;; (discourse client) - Shared Discourse API client utilities.

2;;;

3;;; Provides authentication headers and URL construction used by all

4;;; other discourse modules.

6(define-library (discourse client)

7 (import (sigil core)

8 (sigil dict)

9 (sigil string)

10 (sigil json)

11 (sigil http client))

13 (export discourse-auth-headers

14 discourse-url

15 discourse-url/query

16 url-encode-string

17 build-query-string

18 discourse-get/json

19 discourse-post/json

20 discourse-put/json

21 discourse-delete

22 discourse-delete/json)

24 (begin

26 ;;; Build authentication headers for the Discourse API.

27 ;;;

28 ;;; Discourse uses Api-Key and Api-Username headers rather than

29 ;;; a bearer token.

30 (define (discourse-auth-headers api-key username)

31 #{ Api-Key: api-key

32 Api-Username: username })

34 ;;; Build an API URL from a base URL and path segments.

35 ;;;

36 ;;; Unlike Forgejo, Discourse has no /api/v1 prefix.

37 ;;; (discourse-url "https://forum.example.com" "latest.json")

38 ;;; => "https://forum.example.com/latest.json"

39 (define (discourse-url base-url . parts)

40 (apply string-append base-url

41 (map (lambda (p) (string-append "/" p)) parts)))

43 ;; True when c is an unreserved URI character (RFC 3986 §2.3).

44 (define (url-unreserved? c)

45 (let ((code (char->integer c)))

46 (or (and (>= code 65) (<= code 90))

47 (and (>= code 97) (<= code 122))

48 (and (>= code 48) (<= code 57))

49 (memv c '(#\- #\_ #\. #\~)))))

51 ;;; Percent-encode a string for use in URL query values.

52 ;;;

53 ;;; Unreserved characters (A-Z, a-z, 0-9, -, _, ., ~) pass through;

54 ;;; everything else is encoded as %XX.

55 (define (url-encode-string s)

56 (apply string-append

57 (reverse

58 (let loop ((i 0) (acc '()))

59 (if (>= i (string-length s))

60 acc

61 (let ((c (string-ref s i)))

62 (loop (+ i 1)

63 (cons (if (url-unreserved? c)

64 (string c)

65 (let ((hex (number->string (char->integer c) 16)))

66 (string-append "%"

67 (string-upcase

68 (if (< (char->integer c) 16)

69 (string-append "0" hex)

70 hex)))))

71 acc))))))))

73 ;;; Build a URL query string from an association list.

74 ;;;

75 ;;; Takes a list of (key . value) pairs and returns "?k1=v1&k2=v2".

76 ;;; Values are percent-encoded. Pairs with #f values are omitted.

77 ;;; Returns "" if no pairs remain after filtering.

78 (define (build-query-string params)

79 (let ((pairs (filter (lambda (p) (cdr p)) params)))

80 (if (null? pairs)

81 ""

82 (string-append "?"

83 (string-join

84 (map (lambda (p)

85 (string-append (symbol->string (car p))

86 "="

87 (url-encode-string

88 (if (string? (cdr p))

89 (cdr p)

90 (number->string (cdr p))))))

91 pairs)

92 "&")))))

94 ;;; Build an API URL with path segments and optional query parameters.

95 ;;;

96 ;;; params is an association list of (key . value) pairs.

97 ;;; (discourse-url/query "https://forum.example.com" '((email . "[email protected]"))

98 ;;; "admin" "users" "list" "active.json")

99 ;;; => "https://forum.example.com/admin/users/list/active.json?email=a%40b.com"

100 (define (discourse-url/query base-url params . parts)

101 (string-append (apply discourse-url base-url parts)

102 (build-query-string params)))

103

104 ;; JSON headers for requests with a body.

105 (define (discourse-json-headers api-key username)

106 (dict-merge (discourse-auth-headers api-key username)

107 #{ content-type: "application/json" }))

108

109 ;; Check an HTTP response and return parsed JSON, or raise an error

110 ;; with the status code and response body.

111 (define (check-response response)

112 (if (not (http-response? response))

113 (error "Discourse API request failed: no response"))

114 (let ((status (http-response-status response))

115 (body (http-response-body response)))

116 (if (>= status 400)

117 (error (string-append "Discourse API error " (number->string status)

118 ": " (or body "")))

119 (if (and body (not (string=? body "")))

120 (json-decode body)

121 #t))))

122

123 ;;; Authenticated JSON GET request.

124 (define (discourse-get/json api-key username url)

125 (check-response

126 (http-get url headers: (discourse-auth-headers api-key username))))

127

128 ;;; Authenticated JSON POST request.

129 (define (discourse-post/json api-key username url body)

130 (check-response

131 (http-post url (json-encode body)

132 headers: (discourse-json-headers api-key username))))

133

134 ;;; Authenticated JSON PUT request.

135 (define (discourse-put/json api-key username url body)

136 (check-response

137 (http-put url (json-encode body)

138 headers: (discourse-json-headers api-key username))))

139

140 ;;; Authenticated DELETE request.

141 (define (discourse-delete api-key username url)

142 (check-response

143 (http-delete url headers: (discourse-auth-headers api-key username))))

144

145 ;;; Authenticated DELETE request with JSON body.

146 ;;;

147 ;;; Some Discourse endpoints (e.g., remove group members) require a

148 ;;; body on DELETE requests. http-delete does not support a body,

149 ;;; so we use http-request directly.

150 (define (discourse-delete/json api-key username url body)

151 (check-response

152 (http-request 'DELETE url

153 headers: (discourse-json-headers api-key username)

154 body: (json-encode body))))

155

156 ))