git.iko.soy/servant
on 641ee69 help sign in
servant/src/Servant/Server.hs
82 lines 2.6 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
4-- | This module lets you implement 'Server's for defined APIs. You will
5-- probably need 'serve' (and look at the 'HasServer' type family), but
6-- 'toApplication' and 'route' are rather internals.
8module Servant.Server where
10import Data.Monoid
11import Data.Proxy
12import Network.HTTP.Types
13import Network.Wai
15-- * Implementing Servers
17-- | 'serve' allows you to implement an API and produce a wai 'Application'.
18serve :: HasServer layout => Proxy layout -> Server layout -> Application
19serve p server = toApplication (route p server)
21toApplication :: RoutingApplication -> Application
22toApplication ra request respond = do
23 ra request (routingRespond . routeResult)
24 where
25 routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
26 routingRespond (Left NotFound) =
27 respond $ responseLBS notFound404 [] "not found"
28 routingRespond (Left WrongMethod) =
29 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
30 routingRespond (Right response) =
31 respond response
33-- * Route mismatch
34data RouteMismatch =
35 NotFound -- ^ the usual "not found" error
36 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
37 deriving (Eq, Show)
39-- |
40-- @
41-- 'NotFound' <> x = x
42-- 'WrongMethod' <> _ = 'WrongMethod'
43-- @
44instance Monoid RouteMismatch where
45 mempty = NotFound
47 NotFound `mappend` x = x
48 WrongMethod `mappend` _ = WrongMethod
50-- | A wrapper around @'Either' 'RouteMismatch' a@.
51newtype RouteResult a =
52 RR { routeResult :: Either RouteMismatch a }
53 deriving (Eq, Show)
55failWith :: RouteMismatch -> RouteResult a
56failWith = RR . Left
58succeedWith :: a -> RouteResult a
59succeedWith = RR . Right
61isMismatch :: RouteResult a -> Bool
62isMismatch (RR (Left _)) = True
63isMismatch _ = False
65-- | If we get a `Right`, it has precedence over everything else.
66--
67-- This in particular means that if we could get several 'Right's,
68-- only the first we encounter would be taken into account.
69instance Monoid (RouteResult a) where
70 mempty = RR $ Left mempty
72 RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
73 RR (Left _) `mappend` RR (Right y) = RR $ Right y
74 r `mappend` _ = r
76type RoutingApplication =
77 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
78 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
80class HasServer layout where
81 type Server layout :: *
82 route :: Proxy layout -> Server layout -> RoutingApplication