31b12d4 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Refactoring: abstracting common parts of method handlers.

31b12d4Andres Loeh11 years ago

servant-server/src/Servant/Server/Internal.hs+65−180

compare with master

unifiedsplit

@@ -120,6 +120,56 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

120 where captureProxy = Proxy :: Proxy (Capture capture a)

121

122

123+methodRouter :: (AllCTRender ctypes a)

124+ => Method -> Proxy ctypes -> Status

125+ -> IO (RouteResult (EitherT ServantErr IO a))

126+ -> Router

127+methodRouter method proxy status action = LeafRouter route'

128+ where

129+ route' request respond

130+ | pathIsEmpty request && requestMethod request == method = do

131+ runAction action respond $ \ output -> do

132+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

133+ case handleAcceptH proxy (AcceptHeader accH) output of

134+ Nothing -> failWith UnsupportedMediaType

135+ Just (contentT, body) -> succeedWith $

136+ responseLBS status [ ("Content-Type" , cs contentT)] body

137+ | pathIsEmpty request && requestMethod request /= method =

138+ respond $ failWith WrongMethod

139+ | otherwise = respond $ failWith NotFound

140+

141+methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)

142+ => Method -> Proxy ctypes -> Status

143+ -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))

144+ -> Router

145+methodRouterHeaders method proxy status action = LeafRouter route'

146+ where

147+ route' request respond

148+ | pathIsEmpty request && requestMethod request == method = do

149+ runAction action respond $ \ output -> do

150+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

151+ headers = getHeaders output

152+ case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of

153+ Nothing -> failWith UnsupportedMediaType

154+ Just (contentT, body) -> succeedWith $

155+ responseLBS status ( ("Content-Type" , cs contentT) : headers) body

156+ | pathIsEmpty request && requestMethod request /= method =

157+ respond $ failWith WrongMethod

158+ | otherwise = respond $ failWith NotFound

159+

160+methodRouterEmpty :: Method

161+ -> IO (RouteResult (EitherT ServantErr IO ()))

162+ -> Router

163+methodRouterEmpty method action = LeafRouter route'

164+ where

165+ route' request respond

166+ | pathIsEmpty request && requestMethod request == method = do

167+ runAction action respond $ \ () ->

168+ succeedWith $ responseLBS noContent204 [] ""

169+ | pathIsEmpty request && requestMethod request /= method =

170+ respond $ failWith WrongMethod

171+ | otherwise = respond $ failWith NotFound

172+

123-- | If you have a 'Delete' endpoint in your API,

173-- | If you have a 'Delete' endpoint in your API,

124-- the handler for this endpoint is meant to delete

174-- the handler for this endpoint is meant to delete

125-- a resource.

175-- a resource.

@@ -140,19 +190,7 @@ instance

140

190

141 type ServerT (Delete ctypes a) m = m a

191 type ServerT (Delete ctypes a) m = m a

142

192

143− route Proxy action = LeafRouter route'

193+ route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200

144− where

145− route' request respond

146− | pathIsEmpty request && requestMethod request == methodDelete = do

147− runAction action respond $ \ output -> do

148− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

149− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

150− Nothing -> failWith UnsupportedMediaType

151− Just (contentT, body) -> succeedWith $

152− responseLBS status200 [ ("Content-Type" , cs contentT)] body

153− | pathIsEmpty request && requestMethod request /= methodDelete =

154− respond $ failWith WrongMethod

155− | otherwise = respond $ failWith NotFound

156

194

157instance

195instance

158#if MIN_VERSION_base(4,8,0)

196#if MIN_VERSION_base(4,8,0)

@@ -162,15 +200,7 @@ instance

162

200

163 type ServerT (Delete ctypes ()) m = m ()

201 type ServerT (Delete ctypes ()) m = m ()

164

202

165− route Proxy action = LeafRouter route'

203+ route Proxy = methodRouterEmpty methodDelete

166− where

167− route' request respond

168− | pathIsEmpty request && requestMethod request == methodDelete = do

169− runAction action respond $ \ () ->

170− succeedWith $ responseLBS noContent204 [] ""

171− | pathIsEmpty request && requestMethod request /= methodDelete =

172− respond $ failWith WrongMethod

173− | otherwise = respond $ failWith NotFound

174

204

175-- Add response headers

205-- Add response headers

176instance

206instance

@@ -182,20 +212,7 @@ instance

182

212

183 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

213 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

184

214

185− route Proxy action = LeafRouter route'

215+ route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200

186− where

187− route' request respond

188− | pathIsEmpty request && requestMethod request == methodDelete = do

189− runAction action respond $ \ output -> do

190− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

191− headers = getHeaders output

192− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

193− Nothing -> failWith UnsupportedMediaType

194− Just (contentT, body) -> succeedWith $

195− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

196− | pathIsEmpty request && requestMethod request /= methodDelete =

197− respond $ failWith WrongMethod

198− | otherwise = respond $ failWith NotFound

199

216

200-- | When implementing the handler for a 'Get' endpoint,

217-- | When implementing the handler for a 'Get' endpoint,

201-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

218-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

@@ -218,19 +235,7 @@ instance

218

235

219 type ServerT (Get ctypes a) m = m a

236 type ServerT (Get ctypes a) m = m a

220

237

221− route Proxy action = LeafRouter route'

238+ route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200

222− where

223− route' request respond

224− | pathIsEmpty request && requestMethod request == methodGet = do

225− runAction action respond $ \ output -> do

226− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

227− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

228− Nothing -> failWith UnsupportedMediaType

229− Just (contentT, body) -> succeedWith $

230− responseLBS ok200 [ ("Content-Type" , cs contentT)] body

231− | pathIsEmpty request && requestMethod request /= methodGet =

232− respond $ failWith WrongMethod

233− | otherwise = respond $ failWith NotFound

234

239

235-- '()' ==> 204 No Content

240-- '()' ==> 204 No Content

236instance

241instance

@@ -241,15 +246,7 @@ instance

241

246

242 type ServerT (Get ctypes ()) m = m ()

247 type ServerT (Get ctypes ()) m = m ()

243

248

244− route Proxy action = LeafRouter route'

249+ route Proxy = methodRouterEmpty methodGet

245− where

246− route' request respond

247− | pathIsEmpty request && requestMethod request == methodGet = do

248− runAction action respond $ \ () ->

249− succeedWith $ responseLBS noContent204 [] ""

250− | pathIsEmpty request && requestMethod request /= methodGet =

251− respond $ failWith WrongMethod

252− | otherwise = respond $ failWith NotFound

253

250

254-- Add response headers

251-- Add response headers

255instance

252instance

@@ -261,20 +258,7 @@ instance

261

258

262 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

259 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

263

260

264− route Proxy action = LeafRouter route'

261+ route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200

265− where

266− route' request respond

267− | pathIsEmpty request && requestMethod request == methodGet = do

268− runAction action respond $ \ output -> do

269− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

270− headers = getHeaders output

271− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

272− Nothing -> failWith UnsupportedMediaType

273− Just (contentT, body) -> succeedWith $

274− responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

275− | pathIsEmpty request && requestMethod request /= methodGet =

276− respond $ failWith WrongMethod

277− | otherwise = respond $ failWith NotFound

278

262

279-- | If you use 'Header' in one of the endpoints for your API,

263-- | If you use 'Header' in one of the endpoints for your API,

280-- this automatically requires your server-side handler to be a function

264-- this automatically requires your server-side handler to be a function

@@ -329,19 +313,7 @@ instance

329

313

330 type ServerT (Post ctypes a) m = m a

314 type ServerT (Post ctypes a) m = m a

331

315

332− route Proxy action = LeafRouter route'

316+ route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201

333− where

334− route' request respond

335− | pathIsEmpty request && requestMethod request == methodPost = do

336− runAction action respond $ \ output -> do

337− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

338− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

339− Nothing -> failWith UnsupportedMediaType

340− Just (contentT, body) -> succeedWith $

341− responseLBS status201 [ ("Content-Type" , cs contentT)] body

342− | pathIsEmpty request && requestMethod request /= methodPost =

343− respond $ failWith WrongMethod

344− | otherwise = respond $ failWith NotFound

345

317

346instance

318instance

347#if MIN_VERSION_base(4,8,0)

319#if MIN_VERSION_base(4,8,0)

@@ -351,15 +323,7 @@ instance

351

323

352 type ServerT (Post ctypes ()) m = m ()

324 type ServerT (Post ctypes ()) m = m ()

353

325

354− route Proxy action = LeafRouter route'

326+ route Proxy = methodRouterEmpty methodPost

355− where

356− route' request respond

357− | pathIsEmpty request && requestMethod request == methodPost = do

358− runAction action respond $ \ () ->

359− succeedWith $ responseLBS noContent204 [] ""

360− | pathIsEmpty request && requestMethod request /= methodPost =

361− respond $ failWith WrongMethod

362− | otherwise = respond $ failWith NotFound

363

327

364-- Add response headers

328-- Add response headers

365instance

329instance

@@ -371,20 +335,7 @@ instance

371

335

372 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

336 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

373

337

374− route Proxy action = LeafRouter route'

338+ route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201

375− where

376− route' request respond

377− | pathIsEmpty request && requestMethod request == methodPost = do

378− runAction action respond $ \ output -> do

379− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

380− headers = getHeaders output

381− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

382− Nothing -> failWith UnsupportedMediaType

383− Just (contentT, body) -> succeedWith $

384− responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

385− | pathIsEmpty request && requestMethod request /= methodPost =

386− respond $ failWith WrongMethod

387− | otherwise = respond $ failWith NotFound

388

339

389-- | When implementing the handler for a 'Put' endpoint,

340-- | When implementing the handler for a 'Put' endpoint,

390-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

341-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

@@ -407,19 +358,7 @@ instance

407

358

408 type ServerT (Put ctypes a) m = m a

359 type ServerT (Put ctypes a) m = m a

409

360

410− route Proxy action = LeafRouter route'

361+ route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200

411− where

412− route' request respond

413− | pathIsEmpty request && requestMethod request == methodPut = do

414− runAction action respond $ \ output -> do

415− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

416− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

417− Nothing -> failWith UnsupportedMediaType

418− Just (contentT, body) -> succeedWith $

419− responseLBS status200 [ ("Content-Type" , cs contentT)] body

420− | pathIsEmpty request && requestMethod request /= methodPut =

421− respond $ failWith WrongMethod

422− | otherwise = respond $ failWith NotFound

423

362

424instance

363instance

425#if MIN_VERSION_base(4,8,0)

364#if MIN_VERSION_base(4,8,0)

@@ -429,15 +368,7 @@ instance

429

368

430 type ServerT (Put ctypes ()) m = m ()

369 type ServerT (Put ctypes ()) m = m ()

431

370

432− route Proxy action = LeafRouter route'

371+ route Proxy = methodRouterEmpty methodPut

433− where

434− route' request respond

435− | pathIsEmpty request && requestMethod request == methodPut = do

436− runAction action respond $ \ () ->

437− succeedWith $ responseLBS noContent204 [] ""

438− | pathIsEmpty request && requestMethod request /= methodPut =

439− respond $ failWith WrongMethod

440− | otherwise = respond $ failWith NotFound

441

372

442-- Add response headers

373-- Add response headers

443instance

374instance

@@ -449,20 +380,7 @@ instance

449

380

450 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

381 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

451

382

452− route Proxy action = LeafRouter route'

383+ route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200

453− where

454− route' request respond

455− | pathIsEmpty request && requestMethod request == methodPut = do

456− runAction action respond $ \ output -> do

457− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

458− headers = getHeaders output

459− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

460− Nothing -> failWith UnsupportedMediaType

461− Just (contentT, body) -> succeedWith $

462− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

463− | pathIsEmpty request && requestMethod request /= methodPut =

464− respond $ failWith WrongMethod

465− | otherwise = respond $ failWith NotFound

466

384

467-- | When implementing the handler for a 'Patch' endpoint,

385-- | When implementing the handler for a 'Patch' endpoint,

468-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

386-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

@@ -483,19 +401,7 @@ instance

483

401

484 type ServerT (Patch ctypes a) m = m a

402 type ServerT (Patch ctypes a) m = m a

485

403

486− route Proxy action = LeafRouter route'

404+ route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200

487− where

488− route' request respond

489− | pathIsEmpty request && requestMethod request == methodPatch = do

490− runAction action respond $ \ output -> do

491− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

492− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

493− Nothing -> failWith UnsupportedMediaType

494− Just (contentT, body) -> succeedWith $

495− responseLBS status200 [ ("Content-Type" , cs contentT)] body

496− | pathIsEmpty request && requestMethod request /= methodPatch =

497− respond $ failWith WrongMethod

498− | otherwise = respond $ failWith NotFound

499

405

500instance

406instance

501#if MIN_VERSION_base(4,8,0)

407#if MIN_VERSION_base(4,8,0)

@@ -505,15 +411,7 @@ instance

505

411

506 type ServerT (Patch ctypes ()) m = m ()

412 type ServerT (Patch ctypes ()) m = m ()

507

413

508− route Proxy action = LeafRouter route'

414+ route Proxy = methodRouterEmpty methodPatch

509− where

510− route' request respond

511− | pathIsEmpty request && requestMethod request == methodPatch = do

512− runAction action respond $ \ () ->

513− succeedWith $ responseLBS noContent204 [] ""

514− | pathIsEmpty request && requestMethod request /= methodPatch =

515− respond $ failWith WrongMethod

516− | otherwise = respond $ failWith NotFound

517

415

518-- Add response headers

416-- Add response headers

519instance

417instance

@@ -525,20 +423,7 @@ instance

525

423

526 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

424 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

527

425

528− route Proxy action = LeafRouter route'

426+ route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200

529− where

530− route' request respond

531− | pathIsEmpty request && requestMethod request == methodPatch = do

532− runAction action respond $ \ outpatch -> do

533− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

534− headers = getHeaders outpatch

535− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

536− Nothing -> failWith UnsupportedMediaType

537− Just (contentT, body) -> succeedWith $

538− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

539− | pathIsEmpty request && requestMethod request /= methodPatch =

540− respond $ failWith WrongMethod

541− | otherwise = respond $ failWith NotFound

542

427

543-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

428-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

544-- this automatically requires your server-side handler to be a function

429-- this automatically requires your server-side handler to be a function

servant-server/src/Servant/Server/Internal/RoutingApplication.hs−1

@@ -46,7 +46,6 @@ instance Monoid (RouteResult a) where

47-- Note that the ordering of the constructors has great significance! It

48-- determines the Ord instance and, consequently, the monoid instance.

49−-- * Route mismatch

50data RouteMismatch =

49data RouteMismatch =

51 NotFound -- ^ the usual "not found" error

50 NotFound -- ^ the usual "not found" error

52 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

51 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error