0d570fd · servant-reflex

git.iko.soy/servant-reflex

Fix type errors and example client and server

commit0d570fd84a0465985a09c5795b478aab5ef664f4 authorGreg Hale <imalsogreg@gmail.com> dateThu 18 Feb 2016, 17:56 (11 years ago) parent24b5f87

8 files changed+127−62

compare with master

unifiedsplit

.gitignore+4 exec/API.hs+1 exec/Example.hs+23−5 src/Servant/Common/Req.hs+15−6 src/Servant/Reflex.hs+51−41 testserver/Main.hs+21−10 testserver/static/index.html+11 toSite.sh+1

.gitignore+4

@@ -1,3 +1,7 @@

11.cabal-sandbox

22cabal.sandbox.config

33dist

4+*.js

5+log

6+*.webapp

7+*.stats

exec/API.hs+1

@@ -7,3 +7,4 @@ import Servant.API

88type API = "getunit" :> Get '[JSON] ()

99 :<|> "getint" :> Get '[JSON] Int

10+ :<|> Raw

exec/Example.hs+23−5

@@ -3,6 +3,8 @@

44module Main where

6+import Data.Maybe

7+import Servant.API

68import Servant.Reflex

79import API

810import Data.Proxy

@@ -19,9 +21,25 @@ main = mainWidget run

1921

2022run :: forall t m. MonadWidget t m => m ()

2123run = do

22− let (getUnit :: Event t () -> m (Event t ((),()))) = client api url

23− b :: Event t () <- button "Get unit"

24− res :: Event t ((),()) <- getUnit b

25− c <- foldDyn (\_ (n :: Int) -> succ n) 0 res

26− display c

24+ let (getUnit :<|> getInt :<|> doRaw) = client api (Proxy :: Proxy m) (constDyn url)

25+ b :: Event t () <- button "Get unit"

26+ b' :: Event t () <- button "Get int"

27+ res :: Event t (Maybe (), XhrResponse) <- getUnit b

28+ res' :: Event t (Maybe Int, XhrResponse) <- getInt b'

29+ r <- holdDyn "Waiting" $ leftmost [fmap (showXhrResponse . snd) res

30+ ,fmap (showXhrResponse . snd) res'

31+ ]

32+ dynText r

2733

34+showXhrResponse :: XhrResponse -> String

35+showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

36+ unlines ["stat: " ++ show stat

37+ ,"stattxt: " ++ show stattxt

38+ ,"resp: " ++ maybe "" showRB rbmay

39+ ,"rtext: " ++ show rtmay]

40+

41+showRB :: XhrResponseBody -> String

42+showRB (XhrResponseBody_Default t) = show t

43+showRB (XhrResponseBody_Text t) = show t

44+showRB (XhrResponseBody_Blob t) = "<Blob>"

45+showRB (XhrResponseBody_ArrayBuffer t) = show t

src/Servant/Common/Req.hs+15−6

@@ -10,8 +10,11 @@ module Servant.Common.Req where

1010-- import Control.Monad.IO.Class

1111-- import Control.Monad.Trans.Except

1212import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)

13+import qualified Data.ByteString.Lazy.Char8 as BL

14+import qualified Data.Text.Encoding as TE

1315-- import qualified Data.Foldable as F

1416import qualified Data.List as L

17+import Data.Proxy

1518-- import Data.Monoid

1619-- import Data.String

1720-- import Data.String.Conversions

@@ -26,6 +29,7 @@ import qualified Data.List as L

2629-- import Network.URI hiding (path)

2730-- import Servant.API.ContentTypes

2831import Servant.Common.BaseUrl

32+import Servant.API.ContentTypes

2933import Reflex

3034import Reflex.Dom

3135

@@ -133,19 +137,24 @@ performRequest reqMethod req _ trigger = do

133137

134138-- TODO implement

135139-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]

140+ -- TODO Proxy probably not needed

136141performRequestNoBody ::

137− forall t m .MonadWidget t m => String -> Req t -> Dynamic t BaseUrl

142+ forall t m .MonadWidget t m => Proxy m -> String -> Req t -> Dynamic t BaseUrl

138143 -> Event t () -> m (Event t XhrResponse)

139−performRequestNoBody reqMethod req reqHost trigger = do

144+performRequestNoBody _ reqMethod req reqHost trigger = do

140145 performRequest reqMethod req reqHost trigger

141146 -- return hdrs

142147

143−performRequestCT :: (MonadWidget t m, FromHttpApiData a)

144− => String -> Req t -> Dynamic t BaseUrl

148+performRequestCT :: (MonadWidget t m, FromHttpApiData a, MimeUnrender ct a)

149+ => Proxy ct -> String -> Req t -> Dynamic t BaseUrl

145150 -> Event t () -> m (Event t (Maybe a, XhrResponse))

146−performRequestCT reqMethod req reqHost trigger = do

151+performRequestCT ct reqMethod req reqHost trigger = do

147152 resp <- performRequest reqMethod req reqHost trigger

148− return $ ffor resp $ \xhr -> undefined

153+ return $ ffor resp $ \xhr -> (hushed (mimeUnrender ct . BL.fromStrict . TE.encodeUtf8) =<< _xhrResponse_responseText xhr, xhr)

154+ where hushed :: (x -> Either e y) -> (x -> Maybe y)

155+ hushed f ea = case f ea of

156+ Left e -> Nothing

157+ Right a -> Just a

149158

150159

151160 -- partialRequest <- liftIO $ reqToRequest req reqHost

src/Servant/Reflex.hs+51−41

@@ -18,7 +18,6 @@

1818module Servant.Reflex

1919 ( client

2020 , HasClient(..)

21− , ServantError(..)

2221 , module Servant.Common.BaseUrl

2322 ) where

2423

@@ -29,6 +28,7 @@ import Data.List

2928import Data.Proxy

3029import Data.String.Conversions

3130import Data.Text (unpack)

31+import qualified Data.ByteString.Char8 as BS

3232import GHC.TypeLits

3333-- import Network.HTTP.Media

3434-- import qualified Network.HTTP.Types as H

@@ -36,6 +36,7 @@ import GHC.TypeLits

3636import Servant.API

3737import Servant.Common.BaseUrl

3838import Servant.Common.Req

39+import Servant.API.ContentTypes

3940import Reflex

4041import Reflex.Dom

4142import Reflex.Dom.Xhr

@@ -55,22 +56,23 @@ import Reflex.Dom.Xhr

5556-- -> m (Event t (Either XhrError (Book,Book)))

5657-- > (getAllBooks :<|> postNewBook) = client myApi host

5758-- > where host = constDyn $ BaseUrl Http "localhost" 8080

58−client :: (HasClient t m layout, MonadWidget t m) => Proxy layout -> Dynamic t BaseUrl -> Client t m layout

59−client p baseurl = clientWithRoute p defReq baseurl

59+client :: (HasClient t m layout, MonadWidget t m)

60+ => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

61+client p q baseurl = clientWithRoute p q defReq baseurl

6062

6163-- | This class lets us define how each API combinator

6264-- influences the creation of an HTTP request. It's mostly

6365-- an internal class, you can just use 'client'.

6466class HasClient t m layout where

6567 type Client t m layout :: *

66− clientWithRoute :: Proxy layout -> Req t -> BaseUrl -> Client t m layout

68+ clientWithRoute :: Proxy layout -> Proxy m -> Req t -> Dynamic t BaseUrl -> Client t m layout

6769

6870

6971instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

7072 type Client t m (a :<|> b) = Client t m a :<|> Client t m b

71− clientWithRoute Proxy req baseurl =

72− clientWithRoute (Proxy :: Proxy a) req baseurl :<|>

73− clientWithRoute (Proxy :: Proxy b) req baseurl

73+ clientWithRoute Proxy q req baseurl =

74+ clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>

75+ clientWithRoute (Proxy :: Proxy b) q req baseurl

7476

7577-- Capture. Example:

7678-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

@@ -89,25 +91,26 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s

8991 type Client t m (Capture capture a :> sublayout) =

9092 Behavior t (Maybe a) -> Client t m sublayout

9193

92− clientWithRoute Proxy req baseurl val =

94+ clientWithRoute Proxy q req baseurl val =

9395 clientWithRoute (Proxy :: Proxy sublayout)

96+ q

9497 (prependToPathParts p req)

9598 baseurl

9699

97− where p = fmap (unpack . toUrlPiece) val

100+ where p = (fmap . fmap) (unpack . toUrlPiece) val

98101

99102-- VERB (Returning content) --

100103instance {-# OVERLAPPABLE #-}

101104 -- Note [Non-Empty Content Types]

102− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m

105+ (MimeUnrender ct a, FromHttpApiData a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m

103106 ) => HasClient t m (Verb method status cts' a) where

104107 type Client t m (Verb method status cts' a) =

105108 Event t () -> m (Event t (Maybe a, XhrResponse))

106109 -- TODO how to access input types here?

107110 -- ExceptT ServantError IO a

108− clientWithRoute Proxy req baseurl =

111+ clientWithRoute Proxy q req baseurl =

109112 performRequestCT (Proxy :: Proxy ct) method req baseurl

110− where method = reflectMethod (Proxy :: Proxy method)

113+ where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)

111114

112115-- TODO Overlapping error??

113116-- -- VERB (No content) --

@@ -180,12 +183,14 @@ instance (KnownSymbol sym, ToHttpApiData a,

180183 type Client t m (Header sym a :> sublayout) =

181184 Behavior t (Maybe a) -> Client t m sublayout

182185

183− clientWithRoute Proxy req baseurl mval =

186+ clientWithRoute Proxy q req baseurl mval =

184187 clientWithRoute (Proxy :: Proxy sublayout)

185− (maybe req

186− (\value -> Servant.Common.Req.addHeader hname value req)

187− mval

188− )

188+ q

189+ req

190+ -- (maybe req -- TODO Need to pass the header in

191+ -- (\value -> Servant.Common.Req.addHeader hname value req)

192+ -- mval

193+ -- )

189194 baseurl

190195

191196 where hname = symbolVal (Proxy :: Proxy sym)

@@ -198,8 +203,8 @@ instance HasClient t m sublayout

198203 type Client t m (HttpVersion :> sublayout) =

199204 Client t m sublayout

200205

201− clientWithRoute Proxy =

202− clientWithRoute (Proxy :: Proxy sublayout)

206+ clientWithRoute Proxy q =

207+ clientWithRoute (Proxy :: Proxy sublayout) q

203208

204209-- | If you use a 'QueryParam' in one of your endpoints in your API,

205210-- the corresponding querying function will automatically take

@@ -235,14 +240,16 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

235240 Behavior t (Maybe a) -> Client t m sublayout

236241

237242 -- if mparam = Nothing, we don't add it to the query string

238− clientWithRoute Proxy req baseurl mparam =

243+ clientWithRoute Proxy q req baseurl mparam =

239244 clientWithRoute (Proxy :: Proxy sublayout)

240− (req {qParams = (pname', map show mparam) : qParams req})

245+ q

246+ req -- TODO Must pass in the query param

247+ -- (req {qParams = (pname', map show mparam) : qParams req})

241248 baseurl

242249

243− where pname = cs pname'

244− pname' = symbolVal (Proxy :: Proxy sym)

245− mparamText = fmap toQueryParam mparam

250+ -- where pname = cs pname'

251+ -- pname' = symbolVal (Proxy :: Proxy sym)

252+ -- mparamText = fmap toQueryParam mparam

246253

247254-- | If you use a 'QueryParams' in one of your endpoints in your API,

248255-- the corresponding querying function will automatically take

@@ -278,7 +285,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

278285 type Client t m (QueryParams sym a :> sublayout) =

279286 [a] -> Client t m sublayout

280287

281− clientWithRoute Proxy req baseurl paramlist = undefined

288+ clientWithRoute Proxy _ req baseurl paramlist = undefined

282289 -- clientWithRoute (Proxy :: Proxy sublayout)

283290 -- (foldl' prependPathParts req paramlist')

284291 -- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))

@@ -335,12 +342,15 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

335342-- | Pick a 'Method' and specify where the server you want to query is. You get

336343-- back the full `Response`.

337344-- TODO redo

338−-- instance HasClient Raw where

339−-- type Client Raw = String -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)

345+instance (MonadWidget t m) => HasClient t m Raw where

346+ type Client t m Raw = Behavior t (Maybe XhrRequest)

347+ -> Event t ()

348+ -> m (Event t XhrResponse)

340349

341−-- clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw

342−-- clientWithRoute Proxy req baseurl httpMethod = do

343−-- performRequest httpMethod req baseurl

350+ -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw

351+ clientWithRoute p q req baseurl xhrs triggers = do

352+ let okReq = fmapMaybe id $ tag xhrs triggers

353+ performRequestAsync okReq

344354

345355-- | If you use a 'ReqBody' in one of your endpoints in your API,

346356-- the corresponding querying function will automatically take

@@ -379,12 +389,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)

379389-- baseurl

380390

381391-- | Make the querying function append @path@ to the request path.

382−instance (KnownSymbol path, HasClient t m sublayout) => HasClient t m (path :> sublayout) where

392+instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where

383393 type Client t m (path :> sublayout) = Client t m sublayout

384394

385− clientWithRoute Proxy req baseurl =

386− clientWithRoute (Proxy :: Proxy sublayout)

387− (prependToPathParts (constant p) req)

395+ clientWithRoute Proxy q req baseurl =

396+ clientWithRoute (Proxy :: Proxy sublayout) q

397+ (prependToPathParts (constant (Just p)) req)

388398 baseurl

389399

390400 where p = symbolVal (Proxy :: Proxy path)

@@ -392,26 +402,26 @@ instance (KnownSymbol path, HasClient t m sublayout) => HasClient t m (path :> s

392402instance HasClient t m api => HasClient t m (Vault :> api) where

393403 type Client t m (Vault :> api) = Client t m api

394404

395− clientWithRoute Proxy req baseurl =

396− clientWithRoute (Proxy :: Proxy api) req baseurl

405+ clientWithRoute Proxy q req baseurl =

406+ clientWithRoute (Proxy :: Proxy api) q req baseurl

397407

398408instance HasClient t m api => HasClient t m (RemoteHost :> api) where

399409 type Client t m (RemoteHost :> api) = Client t m api

400410

401− clientWithRoute Proxy req baseurl =

402− clientWithRoute (Proxy :: Proxy api) req baseurl

411+ clientWithRoute Proxy q req baseurl =

412+ clientWithRoute (Proxy :: Proxy api) q req baseurl

403413

404414instance HasClient t m api => HasClient t m (IsSecure :> api) where

405415 type Client t m (IsSecure :> api) = Client t m api

406416

407− clientWithRoute Proxy req baseurl =

408− clientWithRoute (Proxy :: Proxy api) req baseurl

417+ clientWithRoute Proxy q req baseurl =

418+ clientWithRoute (Proxy :: Proxy api) q req baseurl

409419

410420instance HasClient t m subapi =>

411421 HasClient t m (WithNamedConfig name config subapi) where

412422

413423 type Client t m (WithNamedConfig name config subapi) = Client t m subapi

414− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

424+ clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q

415425

416426

417427{- Note [Non-Empty Content Types]

testserver/Main.hs+21−10

@@ -14,9 +14,11 @@ import Snap.Http.Server

1414import Snap.Core

1515import Servant.Server.Internal.SnapShims

1616

17−import Servant

17+import Servant -- hiding (serveDirectory)

1818import Servant.Server

19+-- import Snap.Util.FileServe

1920import API

21+import Snap

2022

2123-- * Example

2224

@@ -30,28 +32,37 @@ instance ToJSON Greet

3032testApi :: Proxy API

3133testApi = Proxy

3234

35+data App = App

36+

3337-- Server-side handlers.

3438--

3539-- There's one handler per endpoint, which, just like in the type

3640-- that represents the API, are glued together using :<|>.

3741--

3842-- Each handler runs in the 'ExceptT ServantErr IO' monad.

39−server :: Server API Snap

40−server = return () :<|> return 100

43+server :: Server API (Handler App App)

44+server = return () :<|> return 100 :<|> serveDirectory "static"

4145

42− where helloH name Nothing = helloH name (Just False)

43− helloH name (Just False) = return . Greet $ "Hello, " <> name

44− helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

46+ -- where helloH name Nothing = helloH name (Just False)

47+ -- helloH name (Just False) = return . Greet $ "Hello, " <> name

48+ -- helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

4549

46− postGreetH greet = return greet

50+ -- postGreetH greet = return greet

4751

48− deleteGreetH _ = return ()

52+ -- deleteGreetH _ = return ()

4953

5054-- Turn the server into a WAI app. 'serve' is provided by servant,

5155-- more precisely by the Servant.Server module.

52−test :: Application Snap

56+test :: Application (Handler App App)

5357test = serve testApi server

5458

59+initApp :: SnapletInit App App

60+initApp = makeSnaplet "myapp" "example" Nothing $ do

61+ addRoutes [("", applicationToSnap test)

62+ -- ,("", serveDirectory "static")

63+ ]

64+ return App

65+

5566-- Put this all to work!

5667main :: IO ()

57−main = quickHttpServe $ applicationToSnap (serve testApi server)

68+main = serveSnaplet mempty initApp

testserver/static/index.htmlnew file+11

@@ -0,0 +1,11 @@

1+<!DOCTYPE html>

2+<html>

3+ <head>

4+ <script language="javascript" src="rts.js"></script>

5+ <script language="javascript" src="lib.js"></script>

6+ <script language="javascript" src="out.js"></script>

7+ </head>

8+ <body>

9+ </body>

10+ <script language="javascript" src="runmain.js" defer></script>

11+</html>

toSite.shnew file+1

@@ -0,0 +1 @@

1+cp dist/build/example/example.jsexe/* testserver/static