@@ -1,213 +0,0 @@
1−{-# LANGUAGE DataKinds, FlexibleInstances, OverloadedStrings, PolyKinds,
2− ScopedTypeVariables, TypeFamilies, TypeOperators #-}
3−module Soenke where
4−
5−import Control.Concurrent
6−import Control.Monad
7−import Control.Monad.Catch
8−import Control.Monad.IO.Class
9−import Control.Monad.Trans.Either
10−import Data.Aeson
11−import Data.ByteString.Lazy (ByteString)
12−import Data.Proxy
13−import Data.String.Conversions
14−import Data.Text (Text)
15−import GHC.TypeLits
16−import Network.HTTP.Client (Manager, defaultManagerSettings,
17− newManager)
18−import qualified Network.HTTP.Client as Http.Client
19−import Network.HTTP.Types
20−import Network.URI
21−import Network.Wai
22−import System.IO.Unsafe (unsafePerformIO)
23−
24−
25−-- * Url Layout
26−
27−-- $url_layout
28−-- These types allow you to specify a url layout for a REST API using a type
29−-- alias. The defined API doesn't really have value. It is convenient to define
30−-- a Proxy for every API.
31−--
32−-- The provided constructors are used in 'HasServer' and 'HasClient'.
33−
34−-- | Endpoint for simple GET requests. The server doesn't receive any arguments
35−-- and serves the contained type as JSON.
36−data Get a
37−
38−-- | Endpoint for POST requests.
39−data Post a
40−
41−-- | The contained API (second argument) can be found under @("/" ++ path)@
42−-- (path being the first argument).
43−data (path :: k) :> a = Proxy path :> a
44−infixr 9 :>
45−
46−-- | Union of two APIs, first takes precedence in case of overlap.
47−data a :<|> b = a :<|> b
48−infixr 8 :<|>
49−
50−
51−-- * Implementing Servers
52−
53−-- | 'serve' allows you to implement an API and produce a wai 'Application'.
54−serve :: HasServer layout => Proxy layout -> Server layout -> Application
55−serve p server = toApplication (route p server)
56−
57−toApplication :: RoutingApplication -> Application
58−toApplication ra = \ request respond -> do
59− m <- ra request
60− case m of
61− Nothing -> respond $ responseLBS notFound404 [] "not found"
62− Just response -> respond response
63−
64−type RoutingApplication =
65− Request -> IO (Maybe Response)
66−
67−class HasServer layout where
68− type Server layout :: *
69− route :: Proxy layout -> Server layout -> RoutingApplication
70−
71−instance ToJSON result => HasServer (Get result) where
72− type Server (Get result) = EitherT (Int, String) IO result
73− route Proxy action request
74− | null (pathInfo request) && requestMethod request == methodGet = do
75− e <- runEitherT action
76− return $ Just $ case e of
77− Right output ->
78− responseLBS ok200 [("Content-Type", "application/json")] (encode output)
79− Left (status, message) ->
80− responseLBS (mkStatus status (cs message)) [] (cs message)
81− | otherwise = return Nothing
82−
83−instance ToJSON a => HasServer (Post a) where
84− type Server (Post a) = EitherT (Int, String) IO a
85−
86− route Proxy action request
87− | null (pathInfo request) && requestMethod request == methodPost = do
88− e <- runEitherT action
89− return $ Just $ case e of
90− Right out ->
91− responseLBS status201 [("Content-Type", "application/json")] (encode out)
92− Left (status, message) ->
93− responseLBS (mkStatus status (cs message)) [] (cs message)
94− | otherwise = return Nothing
95−
96−instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
97− type Server (path :> sublayout) = Server sublayout
98− route Proxy subserver request = case pathInfo request of
99− (first : rest)
100− | first == cs (symbolVal proxyPath)
101− -> route (Proxy :: Proxy sublayout) subserver request{
102− pathInfo = rest
103− }
104− _ -> return Nothing
105−
106− where proxyPath = Proxy :: Proxy path
107−
108−instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
109− type Server (a :<|> b) = Server a :<|> Server b
110− route Proxy (a :<|> b) request = do
111− m <- route (Proxy :: Proxy a) a request
112− case m of
113− Nothing -> route (Proxy :: Proxy b) b request
114− Just response -> return $ Just response
115−
116−
117−-- * Accessing APIs as a Client
118−
119−-- | 'client' allows you to produce operations to query an API from a client.
120−client :: forall layout . HasClient layout => Proxy layout -> Client layout
121−client Proxy = clientWithRoute (Proxy :: Proxy layout) defReq
122−
123−class HasClient layout where
124− type Client layout :: *
125− clientWithRoute :: Proxy layout -> Req -> Client layout
126−
127−data Req = Req
128− { reqPath :: String
129− , qs :: QueryText
130− , reqBody :: ByteString
131− }
132−
133−defReq :: Req
134−defReq = Req "" [] ""
135−
136−appendToPath :: String -> Req -> Req
137−appendToPath p req =
138− req { reqPath = reqPath req ++ "/" ++ p }
139−
140−appendToQueryString :: Text -- ^ param name
141− -> Maybe Text -- ^ param value
142− -> Req
143− -> Req
144−appendToQueryString pname pvalue req
145− | pvalue == Nothing = req
146− | otherwise = req { qs = qs req ++ [(pname, pvalue)]
147− }
148−
149−setRQBody :: ByteString -> Req -> Req
150−setRQBody b req = req { reqBody = b }
151−
152−reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Http.Client.Request
153−reqToRequest req uri = fmap (setrqb . setQS ) $ Http.Client.parseUrl url
154−
155− where url = show $ nullURI { uriPath = reqPath req }
156− `relativeTo` uri
157−
158− setrqb r = r { Http.Client.requestBody = Http.Client.RequestBodyLBS (reqBody req) }
159− setQS = Http.Client.setQueryString $ queryTextToQuery (qs req)
160−
161−{-# NOINLINE __manager #-}
162−__manager :: MVar Manager
163−__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
164−
165−__withGlobalManager :: (Manager -> IO a) -> IO a
166−__withGlobalManager action = modifyMVar __manager $ \ manager -> do
167− result <- action manager
168− return (manager, result)
169−
170−instance FromJSON result => HasClient (Get result) where
171− type Client (Get result) = URI -> EitherT String IO result
172− clientWithRoute Proxy req uri = do
173− innerRequest <- liftIO $ reqToRequest req uri
174−
175− innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
176− Http.Client.httpLbs innerRequest manager
177− when (Http.Client.responseStatus innerResponse /= ok200) $
178− left ("HTTP GET request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
179− maybe (left "HTTP GET request returned invalid json") return $
180− decode' (Http.Client.responseBody innerResponse)
181−
182−instance FromJSON a => HasClient (Post a) where
183− type Client (Post a) = URI -> EitherT String IO a
184−
185− clientWithRoute Proxy req uri = do
186− partialRequest <- liftIO $ reqToRequest req uri
187−
188− let request = partialRequest { Http.Client.method = methodPost
189− }
190−
191− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
192− Http.Client.httpLbs request manager
193−
194− when (Http.Client.responseStatus innerResponse /= status201) $
195− left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
196−
197− maybe (left "HTTP POST request returned invalid json") return $
198− decode' (Http.Client.responseBody innerResponse)
199−
200−instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
201− type Client (path :> sublayout) = Client sublayout
202−
203− clientWithRoute Proxy req =
204− clientWithRoute (Proxy :: Proxy sublayout) $
205− appendToPath p req
206−
207− where p = symbolVal (Proxy :: Proxy path)
208−
209−instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
210− type Client (a :<|> b) = Client a :<|> Client b
211− clientWithRoute Proxy req =
212− clientWithRoute (Proxy :: Proxy a) req :<|>
213− clientWithRoute (Proxy :: Proxy b) req