git.iko.soy/servant
on 0802221 help sign in
servant/src/Servant/Server.hs
91 lines 3.1 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 (Left InvalidBody) =
31 respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
32 routingRespond (Right response) =
33 respond response
35-- * Route mismatch
36data RouteMismatch =
37 NotFound -- ^ the usual "not found" error
38 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
39 | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
40 deriving (Eq, Show)
42-- |
43-- @
44-- > mempty = NotFound
45-- >
46-- > NotFound `mappend` x = x
47-- > WrongMethod `mappend` InvalidBody = InvalidBody
48-- > WrongMethod `mappend` _ = WrongMethod
49-- > InvalidBody `mappend` _ = InvalidBody
50-- @
51instance Monoid RouteMismatch where
52 mempty = NotFound
54 NotFound `mappend` x = x
55 WrongMethod `mappend` InvalidBody = InvalidBody
56 WrongMethod `mappend` _ = WrongMethod
57 InvalidBody `mappend` _ = InvalidBody
59-- | A wrapper around @'Either' 'RouteMismatch' a@.
60newtype RouteResult a =
61 RR { routeResult :: Either RouteMismatch a }
62 deriving (Eq, Show)
64failWith :: RouteMismatch -> RouteResult a
65failWith = RR . Left
67succeedWith :: a -> RouteResult a
68succeedWith = RR . Right
70isMismatch :: RouteResult a -> Bool
71isMismatch (RR (Left _)) = True
72isMismatch _ = False
74-- | If we get a `Right`, it has precedence over everything else.
75--
76-- This in particular means that if we could get several 'Right's,
77-- only the first we encounter would be taken into account.
78instance Monoid (RouteResult a) where
79 mempty = RR $ Left mempty
81 RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
82 RR (Left _) `mappend` RR (Right y) = RR $ Right y
83 r `mappend` _ = r
85type RoutingApplication =
86 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
87 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
89class HasServer layout where
90 type Server layout :: *
91 route :: Proxy layout -> Server layout -> RoutingApplication