git.iko.soy/typeable/servant
on master help sign in
get rid of some more proxies, client-side capture support, client and server side request body support
35c9078Alp Mestanogullari
src/Servant.hs+82−22
compare with master
unifiedsplit
@@ -3,95 +3,155 @@
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9module Servant where
10module Servant where
10
11
11import Control.Applicative
12import Control.Applicative
13+import Control.Concurrent (forkIO, killThread)
14+import Control.Monad
15+import Control.Monad.IO.Class
16+import Control.Monad.Trans.Either
12import Data.Aeson
17import Data.Aeson
18+import Data.ByteString.Lazy (ByteString)
13import Data.Monoid
19import Data.Monoid
14import Data.Proxy
20import Data.Proxy
15import Data.Text
21import Data.Text
16import GHC.Generics
22import GHC.Generics
17import GHC.TypeLits
23import GHC.TypeLits
24+import Network.HTTP.Types
25+import Network.URI
18import Network.Wai
26import Network.Wai
19import Network.Wai.Handler.Warp
27import Network.Wai.Handler.Warp
20import Soenke
28import Soenke
21
29
30+import qualified Network.HTTP.Client as Http.Client
31+
22-- * Captures
32-- * Captures
23data Capture sym a
33data Capture sym a
24
34
25class FromText a where
35class FromText a where
26 capture :: Text -> Maybe a
36 capture :: Text -> Maybe a
27
37
38+class ToText a where
39+ toText :: a -> Text
40+
28instance FromText Text where
41instance FromText Text where
29 capture = Just
42 capture = Just
30
43
44+instance ToText Text where
45+ toText = id
46+
31captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
47captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
32captured _ = capture
48captured _ = capture
33
49
34instance (KnownSymbol capture, FromText a, HasServer sublayout)
50instance (KnownSymbol capture, FromText a, HasServer sublayout)
35 => HasServer (Capture capture a :> sublayout) where
51 => HasServer (Capture capture a :> sublayout) where
36
52
37− -- this means that what follows the capture
38− -- must necessarily be a function that expects
39− -- the captured value. :-(
40 type Server (Capture capture a :> sublayout) =
53 type Server (Capture capture a :> sublayout) =
41− Capture capture a :> (a -> Server sublayout)
54+ a -> Server sublayout
42
55
43− route Proxy (capture :> subserver) request = case pathInfo request of
56+ route Proxy subserver request = case pathInfo request of
44 (first : rest)
57 (first : rest)
45− -> case captured capture first of
58+ -> case captured captureProxy first of
46 Nothing -> return Nothing
59 Nothing -> return Nothing
47 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
60 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
48 pathInfo = rest
61 pathInfo = rest
49 }
62 }
50 _ -> return Nothing
63 _ -> return Nothing
51
64
65+ where captureProxy = Proxy :: Proxy (Capture capture a)
66+
67+instance (KnownSymbol capture, ToText a, HasClient sublayout)
68+ => HasClient (Capture capture a :> sublayout) where
69+
70+ type Client (Capture capture a :> sublayout) =
71+ a -> Client sublayout
72+
73+ clientWithRoute Proxy path val =
74+ clientWithRoute (Proxy :: Proxy sublayout)
75+ (path ++ "/" ++ unpack (toText val))
76+
52-- * Request Body support
77-- * Request Body support
53data RQBody a
78data RQBody a
54
79
55instance (FromJSON a, HasServer sublayout)
80instance (FromJSON a, HasServer sublayout)
56 => HasServer (RQBody a :> sublayout) where
81 => HasServer (RQBody a :> sublayout) where
57
82
58− -- same caveat as for the Captures...
59 type Server (RQBody a :> sublayout) =
83 type Server (RQBody a :> sublayout) =
60− RQBody a :> (a -> Server sublayout)
84+ a -> Server sublayout
61
85
62− route Proxy (rqbody :> subserver) request = do
86+ route Proxy subserver request = do
63 mrqbody <- decode' <$> lazyRequestBody request
87 mrqbody <- decode' <$> lazyRequestBody request
64 case mrqbody of
88 case mrqbody of
65 Nothing -> return Nothing
89 Nothing -> return Nothing
66 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
90 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
67
91
92+instance (ToJSON a, FromJSON b)
93+ => HasClient (RQBody a :> Post b) where
94+
95+ type Client (RQBody a :> Post b) =
96+ a -> URI -> EitherT String IO b
97+
98+ clientWithRoute Proxy path body uri = do
99+ partialRequest <- liftIO . Http.Client.parseUrl $
100+ show ( nullURI { uriPath = path }
101+ `relativeTo` uri
102+ )
103+
104+ let request = partialRequest
105+ { Http.Client.method = methodPost
106+ , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
107+ }
108+
109+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
110+ Http.Client.httpLbs request manager
111+
112+ when (Http.Client.responseStatus innerResponse /= status201) $
113+ left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
114+
115+ maybe (left "HTTP POST request returned invalid json") return $
116+ decode' (Http.Client.responseBody innerResponse)
117+
68-- * Example
118-- * Example
69
119
70type TestApi = "hello" :> Capture "name" Text :> Get Greet
120type TestApi = "hello" :> Capture "name" Text :> Get Greet
121+ :<|> "greet" :> RQBody Greet :> Post Greet
71
122
72testApi :: Proxy TestApi
123testApi :: Proxy TestApi
73testApi = Proxy
124testApi = Proxy
74
125
75data Greet = Greet { msg :: Text }
126data Greet = Greet { msg :: Text }
76− deriving Generic
127+ deriving (Generic, Show)
77
128
129+instance FromJSON Greet
78instance ToJSON Greet
130instance ToJSON Greet
79
131
80server :: Server TestApi
132server :: Server TestApi
81−server =
133+server = hello :<|> greet
82− Proxy -- :: Proxy "hello"
134+
83− :> Proxy -- :: Proxy (Capture "name" Text)
135+ where hello = return . Greet . ("Hello, " <>)
84− :> (return . func)
136+ greet = return
85
137
86− where func name = Greet ("Hello, " <> name)
138+getGreet :: Text -> URI -> EitherT String IO Greet
139+postGreet :: Greet -> URI -> EitherT String IO Greet
140+
141+getGreet :<|> postGreet
142+ = client testApi
87
143
88test :: Application
144test :: Application
89test = serve testApi server
145test = serve testApi server
90
146
91−runTest :: Port -> IO ()
147+runTestServer :: Port -> IO ()
92−runTest port = run port test
148+runTestServer port = run port test
93−
149+
94−-- load in ghci, call 'runTest 8000'
150+runTest :: IO ()
95−-- visit http://localhost:8000/hello/world
151+runTest = do
96−-- visit http://localhost:8000/hello/soenke
152+ tid <- forkIO $ runTestServer 8001
97−-- visit http://localhost:8000/hello/alp
153+ let Just uri = parseURI "http://localhost:8001/"
154+ print =<< runEitherT (getGreet "alp" uri)
155+ let g = Greet "yo"
156+ print =<< runEitherT (postGreet g uri)
157+ killThread tid