git.iko.soy/typeable/servant
on master help sign in
get rid of a lot of useless proxies and implement POST requests support on server and client side
8c8bc15Alp Mestanogullari
servant.cabal+1
compare with master
unifiedsplit
@@ -20,6 +20,7 @@ library
20 base >=4 && <5
20 base >=4 && <5
21 , either
21 , either
22 , aeson
22 , aeson
23+ , bytestring
23 , string-conversions
24 , string-conversions
24 , http-client
25 , http-client
25 , http-types
26 , http-types
src/Soenke.hs+48−7
@@ -7,6 +7,7 @@ import Control.Monad
7import Control.Monad.IO.Class
7import Control.Monad.IO.Class
8import Control.Monad.Trans.Either
8import Control.Monad.Trans.Either
9import Data.Aeson
9import Data.Aeson
10+import Data.ByteString.Lazy (ByteString)
10import Data.Proxy
11import Data.Proxy
11import Data.String.Conversions
12import Data.String.Conversions
12import GHC.TypeLits
13import GHC.TypeLits
@@ -32,6 +33,9 @@ import System.IO.Unsafe (unsafePerformIO)
32-- and serves the contained type as JSON.
33-- and serves the contained type as JSON.
33data Get a
34data Get a
34
35
36+-- | Endpoint for POST requests.
37+data Post a
38+
35-- | The contained API (second argument) can be found under @("/" ++ path)@
39-- | The contained API (second argument) can be found under @("/" ++ path)@
36-- (path being the first argument).
40-- (path being the first argument).
37data (path :: k) :> a = Proxy path :> a
41data (path :: k) :> a = Proxy path :> a
@@ -74,18 +78,33 @@ instance ToJSON result => HasServer (Get result) where
74 responseLBS (mkStatus status (cs message)) [] (cs message)
78 responseLBS (mkStatus status (cs message)) [] (cs message)
75 | otherwise = return Nothing
79 | otherwise = return Nothing
76
80
81+instance ToJSON a => HasServer (Post a) where
82+ type Server (Post a) = EitherT (Int, String) IO a
83+
84+ route Proxy action request
85+ | null (pathInfo request) && requestMethod request == methodPost = do
86+ e <- runEitherT action
87+ return $ Just $ case e of
88+ Right out ->
89+ responseLBS status201 [("Content-Type", "application/json")] (encode out)
90+ Left (status, message) ->
91+ responseLBS (mkStatus status (cs message)) [] (cs message)
92+ | otherwise = return Nothing
93+
77instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
94instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
78− type Server (path :> sublayout) = path :> (Server sublayout)
95+ type Server (path :> sublayout) = Server sublayout
79− route Proxy (path :> subserver) request = case pathInfo request of
96+ route Proxy subserver request = case pathInfo request of
80 (first : rest)
97 (first : rest)
81− | first == cs (symbolVal path)
98+ | first == cs (symbolVal proxyPath)
82 -> route (Proxy :: Proxy sublayout) subserver request{
99 -> route (Proxy :: Proxy sublayout) subserver request{
83 pathInfo = rest
100 pathInfo = rest
84 }
101 }
85 _ -> return Nothing
102 _ -> return Nothing
86
103
104+ where proxyPath = Proxy :: Proxy path
105+
87instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
106instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
88− type Server (a :<|> b) = (Server a :<|> Server b)
107+ type Server (a :<|> b) = Server a :<|> Server b
89 route Proxy (a :<|> b) request = do
108 route Proxy (a :<|> b) request = do
90 m <- route (Proxy :: Proxy a) a request
109 m <- route (Proxy :: Proxy a) a request
91 case m of
110 case m of
@@ -124,15 +143,37 @@ instance FromJSON result => HasClient (Get result) where
124 maybe (left "HTTP GET request returned invalid json") return $
143 maybe (left "HTTP GET request returned invalid json") return $
125 decode' (Http.Client.responseBody innerResponse)
144 decode' (Http.Client.responseBody innerResponse)
126
145
146+instance FromJSON a => HasClient (Post a) where
147+ type Client (Post a) = ByteString -> URI -> EitherT String IO a
148+
149+ clientWithRoute Proxy path rqbody uri = do
150+ partialRequest <- liftIO . Http.Client.parseUrl $
151+ show ( nullURI { uriPath = path }
152+ `relativeTo` uri
153+ )
154+
155+ let request = partialRequest
156+ { Http.Client.method = methodPost
157+ , Http.Client.requestBody = Http.Client.RequestBodyLBS rqbody
158+ }
159+
160+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
161+ Http.Client.httpLbs request manager
162+
163+ when (Http.Client.responseStatus innerResponse /= status201) $
164+ left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
165+
166+ maybe (left "HTTP POST request returned invalid json") return $
167+ decode' (Http.Client.responseBody innerResponse)
168+
127instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
169instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
128− type Client (path :> sublayout) = path :> (Client sublayout)
170+ type Client (path :> sublayout) = Client sublayout
129 clientWithRoute Proxy path =
171 clientWithRoute Proxy path =
130− (Proxy :: Proxy path) :>
131 clientWithRoute (Proxy :: Proxy sublayout)
172 clientWithRoute (Proxy :: Proxy sublayout)
132 (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
173 (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
133
174
134instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
175instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
135− type Client (a :<|> b) = (Client a :<|> Client b)
176+ type Client (a :<|> b) = Client a :<|> Client b
136 clientWithRoute Proxy path =
177 clientWithRoute Proxy path =
137 clientWithRoute (Proxy :: Proxy a) path :<|>
178 clientWithRoute (Proxy :: Proxy a) path :<|>
138 clientWithRoute (Proxy :: Proxy b) path
179 clientWithRoute (Proxy :: Proxy b) path