バージョン 1 - 履歴 - SourceFifth - Gauche 関連情報 - EY-Office

1

Yuumi Yoshida

＊リスト1：web-server.scm

2

{{{

3

(use gauche.net)

4

(use rfc.uri)

5

(use www.cgi)

6

(use gauche.reload)

7

(use gauche.collection)

8

9

(add-load-path "./")

10

(use application)

11

12

(define error-page

13

  "<html><body><h2>Error</h2></body></html>")

14

15

(define (web-server)

16

  (let1 server-socket (make-server-socket 'inet 3030 :reuse-addr? #t)

17

    (guard (e (else (socket-close server-socket) (raise e)))  ; TODO

18

     (while #t

19

       (let1 client-socket (socket-accept server-socket)

20

         (receive (path params)  (get-request (socket-input-port client-socket))

21

           (reload-modified-modules)

22

           (put-response

23

            (guard (e (else (report-error e) error-page))

24

                   (render path params))

25

            (socket-output-port client-socket)))

26

         (socket-close client-socket))))))

27

28

(define (get-request in-port)

29

  (cond ((rxmatch #/^GET\s+(\S+)\s/ (read-line in-port))

30

         => (lambda (m)

31

              (parse-uri (rxmatch-substring m 1))))

32

        (else (values "" ()))))

33

34

(define (parse-uri uri)

35

  (receive (host path query fragment) (uri-decompose-hierarchical uri)

36

    (values path (cgi-parse-parameters :query-string (or query "")))))

37

38

(define (put-response content out-port)

39

  (display "HTTP/1.1 200 OK\r\n" out-port)

40

  (display "Content-Type: text/html; charset=utf-8\r\n" out-port)

41

  (display #`"Content-Length: ,(string-size content)\r\n" out-port)

42

  (display "\r\n" out-port)

43

  (display content out-port))

44

45

(web-server)

46

}}}

47

48

＊リスト2：simple-template.scm

49

{{{

50

(define-module simple-template

51

  (use file.util)

52

  (export template templ-render))

53

(select-module simple-template)

54

55

(define-macro (template tmpl-file . args)

56

  `(templ-render ,tmpl-file (quote ,args) (list ,@args)))

57

58

(define (templ-render templ-file vars args)

59

  (apply (eval (templ-func templ-file vars) (interaction-environment))

60

         args))

61

62

(define (templ-func templ-file vars)

63

  (read-from-string

64

   #`"(lambda ,vars

65

        (let1 port (open-output-string)

66

              ,(expand-templ (file->string templ-file))

67

              (get-output-string port)))"))

68

69

(define (expand-templ templ)

70

  (cond ((#/(.*?)<%25=(.*?)%25>(.*)/ templ)

71

         => (lambda(m)

72

              #`",(expand-templ (m 1)) (display ,(m 2) port) ,(expand-templ (m 3))"))

73

        ((#/(.*?)<%25(.*?)%25>(.*)/ templ)

74

         => (lambda(m)

75

              #`",(expand-templ (m 1)) ,(m 2) ,(expand-templ (m 3))"))

76

        (else (format "(display ~s port)" templ))))

77

78

(provide "simple-template")

79

}}}

80

81

＊リスト3：application.scm

82

{{{

83

(define-module application

84

  (use srfi-13)

85

  (use www.cgi)

86

  (use dbi)

87

  (use gauche.collection)

88

  (use simple-template)

89

  (export render))

90

(select-module application)

91

92

(define *db-name* "dbi:sqlite3:alih.db")

93

94

(define-macro (db-let* db-conn vars . body)

95

  `(let1 ,db-conn (dbi-connect *db-name*)

96

     (guard

97

      (e (else (dbi-close ,db-conn) (raise e)))

98

      (let* (,@vars

99

             (ret-value (begin ,@body)))

100

        (dbi-close ,db-conn)

101

        ret-value))))

102

103

(define (render path params)

104

  (cond ((string= path "/edit") (edit params))

105

        ((string= path "/update") (update params))

106

        (else (index params))))

107

108

(define (index params)

109

  (db-let* conn

110

           ((res (dbi-do conn

111

                         "SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no"))

112

            (getter (relation-accessor res)))

113

           (template "list.tmpl" res getter)))

114

115

(define (edit params)

116

  (db-let* conn

117

           ((id (cgi-get-parameter "id" params))

118

            (res (dbi-do conn

119

                         "SELECT id, no, name, g FROM player WHERE id=?"

120

'()

121

                         id))

122

            (getter (relation-accessor res)))

123

           (template "edit.tmpl" res getter)))

124

125

(define (update params)

126

  (db-let* conn ()

127

           (dbi-do conn

128

                   "UPDATE player SET no=?, name=?, g=? WHERE id=?"

129

'()

130

                   (cgi-get-parameter "no" params)

131

                   (cgi-get-parameter "name" params)

132

                   (cgi-get-parameter "g" params)

133

                   (cgi-get-parameter "id" params))

134

           (template "update.tmpl")))

135

136

(provide "application")

137

}}}

138

139

＊リスト4：list.tmpl

140

{{{

141

<html>

142

  <body>

143

    <h2>Asia League Ice Hockey</h2>

144

    <table border="1">

145

    <form action="edit">

146

    <%25 (for-each (lambda (row) %25>

147

      <tr>

148

        <td><input type="radio" name="id" value="<%25= (getter row "id")%25>"></td>

149

        <td><%25= (getter row "no") %25></td>

150

        <td><%25= (getter row "name") %25></td>

151

        <td><%25= (getter row "g") %25></td>

152

      </tr>

153

     <%25 ) res) %25>

154

    </table>

155

    <input type="submit" value="Edit">

156

    </form>

157

  </body>

158

</html>

159

}}}

160

161

＊リスト5：edit.tmpl

162

{{{

163

<html>

164

  <body>

165

    <h2>Edit</h2>

166

    <form action="update">

167

    <%25 (let1 row (find (lambda (x) #t) res)  %25>

168

    <input type="hidden" name="id" value="<%25= (getter row "id")%25>">

169

    <table border="0">

170

      <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr>

171

      <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr>

172

      <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr>

173

     <%25 ) %25>

174

    </table>

175

<input type="submit" value="Update">

176

    </form>

177

  </body>

178

</html>

179

}}}

180

181

＊リスト6：update.tmpl

182

{{{

183

<html>

184

  <head>

185

    <meta http-equiv="refresh" content="0;URL=/">

186

  </head>

187

  <body></body>

188

</html>

189

}}}

190

191

＊リスト7：application.scm

192

{{{

193

(define-module application

194

  (use srfi-13)

195

  (use srfi-27)

196

  (use www.cgi)

197

  (use dbi)

198

  (use gauche.collection)

199

  (use simple-template)

200

  (export render))

201

(select-module application)

202

203

(define *db-name* "dbi:sqlite3:alih.db")

204

(define *conts* (make-hash-table 'eqv?))

205

(define *max-cid* (expt 2 64))

206

207

208

(define (get-cont params)

209

  (hash-table-get *conts*

210

                  (cgi-get-parameter "@cont@" params :convert string->number)

211

                  #f))

212

213

(define (push-cont! cont)

214

  (let1 cid (random-integer *max-cid*)

215

    (cond ((hash-table-get *conts* cid #f) (push-cont! cont))

216

          (else (hash-table-put! *conts* cid cont) cid))))

217

218

(define-macro (db-let* db-conn vars . body)

219

  `(let1 ,db-conn (dbi-connect *db-name*)

220

     (guard

221

      (e (else (dbi-close ,db-conn) (raise e)))

222

      (let* (,@vars

223

             (ret-value (begin ,@body)))

224

        (dbi-close ,db-conn)

225

        ret-value))))

226

227

(define-macro (define-continuation args . body)

228

  `(push-cont! (lambda ,args ,@body)))

229

230

231

(define (render path params)

232

  (cond ((get-cont params) => (lambda(c) (c params)))

233

        ((string= path "/edit") (edit params))

234

        ((string= path "/update") (update params))

235

        (else (index params))))

236

237

(define (index params)

238

  (db-let* conn

239

           ((res (dbi-do conn

240

                         "SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no"))

241

            (getter (relation-accessor res)))

242

           (template "list.tmpl" res getter)))

243

244

245

(define (edit params)

246

  (db-let* conn

247

           ((id (cgi-get-parameter "id" params))

248

            (res (dbi-do conn

249

                         "SELECT id, no, name, g FROM player WHERE id=?"

250

'()

251

                         id))

252

            (getter (relation-accessor res))

253

            (cid (define-continuation (params)

254

                   (db-let* conn ()

255

                            (dbi-do conn

256

                                    "UPDATE player SET no=?, name=?, g=? WHERE id=?"

257

'()

258

                                    (cgi-get-parameter "no" params)

259

                                    (cgi-get-parameter "name" params)

260

                                    (cgi-get-parameter "g" params)

261

id)

262

                            (template "update.tmpl")))))

263

   (template "edit.tmpl" res getter cid)))

264

265

(provide "application")

266

}}}

267

268

＊リスト8：edit.tmpl

269

{{{

270

<html>

271

  <body>

272

    <h2>Edit</h2>

273

    <form action="update">

274

    <%25 (let1 row (find (lambda (x) #t) res)  %25>

275

    <input type="hidden" name="@cont@" value="<%25= cid %25>">

276

    <table border="0">

277

      <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr>

278

      <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr>

279

      <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr>

280

     <%25 ) %25>

281

    </table>

282

    <input type="submit" value="Update">

283

    </form>

284

  </body>

285

</html>

286

}}}

プロジェクト

全般

プロフィール

Gauche 関連情報

SourceFifth » 履歴 » バージョン 1