@@ -18,6 +18,7 @@ import Data.Aeson
1818import Data.ByteString.Lazy (ByteString)
1919import Data.Monoid
2020import Data.Proxy
21+import Data.String.Conversions
2122import Data.Text
2223import GHC.Generics
2324import GHC.TypeLits
@@ -29,23 +30,32 @@ import Soenke
2930
3031import qualified Network.HTTP.Client as Http.Client
3132
32−-- * Captures
33−data Capture sym a
34−
3533class FromText a where
36− capture :: Text -> Maybe a
34+ fromText :: Text -> Maybe a
3735
3836class ToText a where
3937 toText :: a -> Text
4038
4139instance FromText Text where
42− capture = Just
40+ fromText = Just
4341
4442instance ToText Text where
4543 toText = id
4644
45+instance FromText Bool where
46+ fromText "true" = Just True
47+ fromText "false" = Just False
48+ fromText _ = Nothing
49+
50+instance ToText Bool where
51+ toText True = "true"
52+ toText False = "false"
53+
54+-- * Captures
55+data Capture sym a
56+
4757captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
48−captured _ = capture
58+captured _ = fromText
4959
5060instance (KnownSymbol capture, FromText a, HasServer sublayout)
5161 => HasServer (Capture capture a :> sublayout) where
@@ -70,9 +80,11 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
7080 type Client (Capture capture a :> sublayout) =
7181 a -> Client sublayout
7282
73− clientWithRoute Proxy path val =
74− clientWithRoute (Proxy :: Proxy sublayout)
75− (path ++ "/" ++ unpack (toText val))
83+ clientWithRoute Proxy req val =
84+ clientWithRoute (Proxy :: Proxy sublayout) $
85+ appendToPath p req
86+
87+ where p = unpack (toText val)
7688
7789-- * Request Body support
7890data RQBody a
@@ -89,39 +101,54 @@ instance (FromJSON a, HasServer sublayout)
89101 Nothing -> return Nothing
90102 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
91103
92−instance (ToJSON a, FromJSON b)
93− => HasClient (RQBody a :> Post b) where
104+instance (ToJSON a, HasClient sublayout)
105+ => HasClient (RQBody a :> sublayout) where
94106
95− type Client (RQBody a :> Post b) =
96− a -> URI -> EitherT String IO b
107+ type Client (RQBody a :> sublayout) =
108+ a -> Client sublayout
97109
98− clientWithRoute Proxy path body uri = do
99− partialRequest <- liftIO . Http.Client.parseUrl $
100− show ( nullURI { uriPath = path }
101− `relativeTo` uri
102− )
110+ clientWithRoute Proxy req body =
111+ clientWithRoute (Proxy :: Proxy sublayout) $
112+ setRQBody (encode body) req
103113
104− let request = partialRequest
105− { Http.Client.method = methodPost
106− , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
107− }
114+-- * GET params support (i.e query string arguments)
115+data GetParam sym a
108116
109− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
110− Http.Client.httpLbs request manager
117+instance (KnownSymbol sym, FromText a, HasServer sublayout)
118+ => HasServer (GetParam sym a :> sublayout) where
111119
112− when (Http.Client.responseStatus innerResponse /= status201) $
113− left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
120+ type Server (GetParam sym a :> sublayout) =
121+ Maybe a -> Server sublayout
114122
115− maybe (left "HTTP POST request returned invalid json") return $
116− decode' (Http.Client.responseBody innerResponse)
123+ route Proxy subserver request = do
124+ let querytext = parseQueryText $ rawQueryString request
125+ param =
126+ case lookup paramName querytext of
127+ Nothing -> Nothing -- param absent from the query string
128+ Just Nothing -> Nothing -- param present with no value -> Nothing
129+ Just (Just v) -> fromText v -- if present, we try to convert to
130+ -- the right type
117131
118−-- * Example
132+ route (Proxy :: Proxy sublayout) (subserver param) request
119133
120−type TestApi = "hello" :> Capture "name" Text :> Get Greet
121− :<|> "greet" :> RQBody Greet :> Post Greet
134+ where paramName = cs $ symbolVal (Proxy :: Proxy sym)
122135
123−testApi :: Proxy TestApi
124−testApi = Proxy
136+instance (KnownSymbol sym, ToText a, HasClient sublayout)
137+ => HasClient (GetParam sym a :> sublayout) where
138+
139+ type Client (GetParam sym a :> sublayout) =
140+ Maybe a -> Client sublayout
141+
142+ -- if mparam = Nothing, we don't add it to the query string
143+ clientWithRoute Proxy req mparam =
144+ clientWithRoute (Proxy :: Proxy sublayout) $
145+ appendToQueryString pname mparamText req
146+
147+ where pname = pack pname'
148+ pname' = symbolVal (Proxy :: Proxy sym)
149+ mparamText = fmap toText mparam
150+
151+-- * Example
125152
126153data Greet = Greet { msg :: Text }
127154 deriving (Generic, Show)
@@ -129,29 +156,47 @@ data Greet = Greet { msg :: Text }
129156instance FromJSON Greet
130157instance ToJSON Greet
131158
159+-- API specification
160+type TestApi =
161+ "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
162+ :<|> "greet" :> RQBody Greet :> Post Greet
163+
164+testApi :: Proxy TestApi
165+testApi = Proxy
166+
167+-- Server-side handlers
132168server :: Server TestApi
133169server = hello :<|> greet
134170
135− where hello = return . Greet . ("Hello, " <>)
171+ where hello name Nothing = hello name (Just False)
172+ hello name (Just False) = return . Greet $ "Hello, " <> name
173+ hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
174+
136175 greet = return
137176
138−getGreet :: Text -> URI -> EitherT String IO Greet
139−postGreet :: Greet -> URI -> EitherT String IO Greet
177+-- Client-side query functions
178+clientApi :: Client TestApi
179+clientApi = client testApi
140180
141−getGreet :<|> postGreet
142− = client testApi
181+getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
182+postGreet :: Greet -> URI -> EitherT String IO Greet
183+getGreet :<|> postGreet = clientApi
143184
185+-- Turn the server into a WAI app
144186test :: Application
145187test = serve testApi server
146188
189+-- Run the server
147190runTestServer :: Port -> IO ()
148191runTestServer port = run port test
149192
193+-- Run some queries against the server
150194runTest :: IO ()
151195runTest = do
152196 tid <- forkIO $ runTestServer 8001
153− let Just uri = parseURI "http://localhost:8001/"
154− print =<< runEitherT (getGreet "alp" uri)
197+ let Just uri = parseURI "http://localhost:8001"
198+ print =<< runEitherT (getGreet "alp" (Just True) uri)
199+ print =<< runEitherT (getGreet "alp" (Just False) uri)
155200 let g = Greet "yo"
156201 print =<< runEitherT (postGreet g uri)
157202 killThread tid