fe98db8 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Merge pull request #27 from schell/diacratic-fix

Added support for diacratic chars in json text

commitfe98db84f8a4b18b65e6c3ff77485d452bc828a6 authorGreg Hale <ImAlsoGreg@gmail.com> dateTue 28 Feb 2017, 16:49 (10 years ago) parent6dd8bc7 33266e4

12 files changed+181−107

compare with master

unifiedsplit

.gitignore+1 deps/servant+1−1 deps/servant-snap+1−1 exec/API.hs+28−4 exec/Example.hs+15−4 overrides-ghc.nix+23−1 overrides.nix+21 servant-reflex.cabal+3−3 src/Servant/Common/Req.hs+1−7 src/Servant/Reflex.hs+59−66 testserver/Main.hs+17−9 testserver/testserver.cabal+11−11

.gitignore+1

@@ -6,3 +6,4 @@ log

66*.webapp

77*.stats

88out

9+reflex-platform

deps/servant+1−1

Submodule changed.

deps/servant-snap+1−1

Submodule changed.

exec/API.hs+28−4

@@ -1,10 +1,32 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

45module API where

6−import Data.Text (Text)

7−import Servant.API

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

12+newtype Question = Question { unQuestion :: Text } deriving (Show)

13+

14+instance ToJSON Question where

15+ toJSON (Question txt) = object ["question" .= txt]

16+

17+instance FromJSON Question where

18+ parseJSON (Object v) = Question <$> v .: "question"

19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x

20+

21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22+

23+instance ToJSON Answer where

24+ toJSON (Answer txt) = object ["answer" .= txt]

25+

26+instance FromJSON Answer where

27+ parseJSON (Object v) = Answer <$> v .: "answer"

28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29+

830

931-- | API spec for server, client, and docs

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

@@ -16,6 +38,8 @@ type API = "getunit" :> Get '[JSON] ()

1638 :<|> "double" :> ReqBody '[JSON] Double

1739 :> Post '[JSON] Double

1840 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

41+ :<|> "qna" :> ReqBody '[JSON] Question

42+ :> Post '[JSON] Answer

1943 :<|> Raw

2044

2145type GET = Get '[JSON] ()

exec/Example.hs+15−4

@@ -42,7 +42,7 @@ run = do

4242 el "br" (return ())

4343

4444 -- Name the computed API client functions

4646 client api (Proxy :: Proxy m) url

4747

4848 elClass "div" "demo-group" $ do

@@ -89,11 +89,11 @@ run = do

8989 elClass "div" "demo-group" $ do

9090 text "A Double to double"

9191 el "br" $ return ()

92− dblinp <- fmap value $ divClass "double-input" $ textInput def

93− dblBtn <- divClass "double-button" $ button "Double it"

92+ dblinp <- fmap value $ divClass "double-input" $ textInput def

93+ dblBtn <- divClass "double-button" $ button "Double it"

9494 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

9595 dblinp) dblBtn

96− divClass "double-errors" $ dynText =<<

96+ divClass "double-errors" $ dynText =<<

9797 holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)

9898 el "br" (return ())

9999 divClass "double-result" $ el "p" $ dynText =<<

@@ -109,6 +109,17 @@ run = do

109109 fmapMaybe reqSuccess $

110110 multiResp)

111111

112+ el "br" $ return ()

113+

114+ elClass "div" "demo-group" $ do

115+ text "JSON Unicode encoding test"

116+ txt <- value <$> textInput def

117+ ev <- button "Question"

118+ let dQ = Right . Question <$> traceDyn "will send: " txt

119+ rr <- qna dQ ev

120+ el "p" $

121+ dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

122+

112123showXhrResponse :: XhrResponse -> Text

113124showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

114125 T.unlines ["stat: " <> tShow stat

overrides-ghc.nix+23−1

@@ -1,5 +1,5 @@

11{ reflex-platform, ... }:

2−let

2+let

33 pkgs = import <nixpkgs> {};

44 c2n = reflex-platform.cabal2nixResult;

55in reflex-platform.ghc.override {

@@ -13,6 +13,28 @@ in reflex-platform.ghc.override {

1313 xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});

1414 snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});

1515 servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});

16+ Glob = pkgs.haskell.lib.dontCheck super.Glob;

17+ natural-transformation = self.callPackage (

18+ { mkDerivation, base, containers, fetchgit, quickcheck-instances

19+ , stdenv, tasty, tasty-quickcheck

20+ }:

21+ mkDerivation {

22+ pname = "natural-transformation";

23+ version = "0.4";

24+ src = fetchgit {

25+ url = "https://github.com/ku-fpg/natural-transformation";

26+ sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";

27+ rev = "b1200c09dcafd034e32846413913b74735c8ba56";

28+ };

29+ libraryHaskellDepends = [ base ];

30+ testHaskellDepends = [

31+ base containers quickcheck-instances tasty tasty-quickcheck

32+ ];

33+ homepage = "https://github.com/ku-fpg/natural-transformation";

34+ description = "A natural transformation package";

35+ license = stdenv.lib.licenses.bsd3;

36+ }

37+ ) {};

1638 http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});

1739 };

1840}

overrides.nix+21

@@ -10,5 +10,26 @@ reflex-platform.ghcjs.override {

1010 overrides = self: super: {

1111 servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});

1212 http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});

13+ natural-transformation = self.callPackage (

14+ { mkDerivation, base, containers, fetchgit, quickcheck-instances

15+ , stdenv, tasty, tasty-quickcheck

16+ }:

17+ mkDerivation {

18+ pname = "natural-transformation";

19+ version = "0.4";

20+ src = fetchgit {

21+ url = "https://github.com/ku-fpg/natural-transformation";

22+ sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";

23+ rev = "b1200c09dcafd034e32846413913b74735c8ba56";

24+ };

25+ libraryHaskellDepends = [ base ];

26+ testHaskellDepends = [

27+ base containers quickcheck-instances tasty tasty-quickcheck

28+ ];

29+ homepage = "https://github.com/ku-fpg/natural-transformation";

30+ description = "A natural transformation package";

31+ license = stdenv.lib.licenses.bsd3;

32+ }

33+ ) {};

1334 };

1435}

servant-reflex.cabal+3−3

@@ -1,5 +1,5 @@

11Name: servant-reflex

2−Version: 0.2

2+Version: 0.2.1

33Synopsis: Servant reflex API generator

44Description: Servant reflex API generator

55License: AllRightsReserved

@@ -35,7 +35,7 @@ library

3535 reflex >= 0.5 && < 0.6,

3636 reflex-dom == 0.4 && < 0.5,

3737 safe >= 0.3.9 && < 0.4,

38− servant >= 0.5 && < 0.9,

38+ servant >= 0.8 && < 0.11,

3939 string-conversions >= 0.4 && < 0.5,

4040 text >= 1.2 && < 1.3,

4141 transformers >= 0.4 && < 0.6

@@ -45,7 +45,7 @@ library

4545 default-language: Haskell2010

4646

4747executable example

48− build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom, text

48+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

4949 default-language: Haskell2010

5050 main-is: Example.hs

5151 other-modules: API

src/Servant/Common/Req.hs+1−7

@@ -210,15 +210,9 @@ performRequest reqMeth req reqHost trigger = do

210210

211211 return (resps, badReqs)

212212

213−#ifdef ghcjs_HOST_OS

214−type XhrPayload = String

215−bytesToPayload :: BL.ByteString -> XhrPayload

216−bytesToPayload = BL.unpack

217−#else

218213type XhrPayload = T.Text

219214bytesToPayload :: BL.ByteString -> XhrPayload

220−bytesToPayload = T.pack . BL.unpack

221−#endif

215+bytesToPayload = TE.decodeUtf8 . BL.toStrict

222216

223217performRequestNoBody :: forall t m .(SupportsServantReflex t m)

224218 => Text

src/Servant/Reflex.hs+59−66

@@ -1,16 +1,16 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE InstanceSigs #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE InstanceSigs #-}

136{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

1414

1515-- #include "overlapping-compat.h"

1616-- | This module provides 'client' which can automatically generate

@@ -25,42 +25,40 @@ module Servant.Reflex

2525

2626-------------------------------------------------------------------------------

2727import Control.Applicative

28−import Data.Monoid ((<>))

29−import qualified Data.Set as Set

30−import qualified Data.Text.Encoding as E

31−import Data.CaseInsensitive (mk)

32−import Data.Proxy (Proxy (..))

33−import qualified Data.Map as Map

34−import Data.Text (Text)

35−import qualified Data.Text as T

36−import GHC.TypeLits (KnownSymbol, symbolVal)

37−import Servant.API ((:<|>)(..),(:>), BasicAuth,

38− BasicAuthData, BuildHeadersTo(..),

39− Capture, contentType, Header,

40− Headers(..), HttpVersion, IsSecure,

41− MimeRender(..), MimeUnrender,

42− NoContent, QueryFlag, QueryParam,

43− QueryParams, Raw, ReflectMethod(..),

44− RemoteHost, ReqBody,

45− ToHttpApiData(..), Vault, Verb)

46−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

47− showBaseUrl,

48− SupportsServantReflex)

49−import Servant.Common.Req (Req, ReqResult(..), QParam(..),

50− QueryPart(..), addHeader, authData,

51− defReq, prependToPathParts,

52− performRequestCT,

53− performRequestNoBody,

54− qParamToQueryPart, reqBody,

55− reqSuccess, reqFailure,

56− reqMethod, respHeaders, response,

57− qParams)

58−import Reflex.Dom (Dynamic, Event, Reflex,

59− XhrRequest(..),

60− XhrResponseHeaders(..),

61− XhrResponse(..), ffor, fmapMaybe,

62− leftmost, performRequestAsync,

63− tagPromptlyDyn )

28+import Data.CaseInsensitive (mk)

29+import qualified Data.Map as Map

30+import Data.Monoid ((<>))

31+import Data.Proxy (Proxy (..))

32+import qualified Data.Set as Set

33+import Data.Text (Text)

34+import qualified Data.Text as T

35+import qualified Data.Text.Encoding as E

36+import GHC.TypeLits (KnownSymbol, symbolVal)

37+import Reflex.Dom (Dynamic, Event, Reflex,

38+ XhrRequest (..), XhrResponse (..),

39+ XhrResponseHeaders (..), ffor,

40+ fmapMaybe, leftmost,

41+ performRequestAsync, tagPromptlyDyn)

42+import Servant.API ((:<|>) (..), (:>), BasicAuth,

43+ BasicAuthData, BuildHeadersTo (..),

44+ Capture, Header, Headers (..),

45+ HttpVersion, IsSecure, MimeRender (..),

46+ MimeUnrender, NoContent, QueryFlag,

47+ QueryParam, QueryParams, Raw,

48+ ReflectMethod (..), RemoteHost,

49+ ReqBody, ToHttpApiData (..), Vault,

50+ Verb, contentType)

51+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

52+ SupportsServantReflex, baseUrlWidget,

53+ showBaseUrl)

54+import Servant.Common.Req (QParam (..), QueryPart (..), Req,

55+ ReqResult (..), addHeader, authData,

56+ defReq, performRequestCT,

57+ performRequestNoBody,

58+ prependToPathParts, qParamToQueryPart,

59+ qParams, reqBody, reqFailure,

60+ reqMethod, reqSuccess, respHeaders,

61+ response)

6462

6563-- * Accessing APIs as a Client

6664

@@ -79,7 +77,7 @@ import Reflex.Dom (Dynamic, Event, Reflex,

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

8078client :: (HasClient t m layout)

8179 => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

82−client p q baseurl = clientWithRoute p q defReq baseurl

80+client p q = clientWithRoute p q defReq

8381

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

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

@@ -118,7 +116,7 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

118116 (prependToPathParts p req)

119117 baseurl

120118

121− where p = (fmap . fmap) (toUrlPiece) val

119+ where p = (fmap . fmap) toUrlPiece val

122120

123121-- VERB (Returning content) --

124122instance {-# OVERLAPPABLE #-}

@@ -129,8 +127,8 @@ instance {-# OVERLAPPABLE #-}

129127 Event t () -> m (Event t (ReqResult a))

130128 -- TODO how to access input types here?

131129 -- ExceptT ServantError IO a

132− clientWithRoute Proxy _ req baseurl =

133− performRequestCT (Proxy :: Proxy ct) method req' baseurl

130+ clientWithRoute Proxy _ req =

131+ performRequestCT (Proxy :: Proxy ct) method req'

134132 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

135133 req' = req { reqMethod = method }

136134

@@ -142,8 +140,8 @@ instance {-# OVERLAPPING #-}

142140 Event t () -> m (Event t (ReqResult NoContent))

143141 -- TODO: how to access input types here?

144142 -- ExceptT ServantError IO NoContent

145− clientWithRoute Proxy _ req baseurl =

146− performRequestNoBody method req baseurl

143+ clientWithRoute Proxy _ =

144+ performRequestNoBody method

147145 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

148146

149147toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

@@ -163,7 +161,7 @@ instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]

163161

164162instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

165163 => BuildHeaderKeysTo '[(Header h v) ': xs] where

166− buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

164+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

167165

168166-- HEADERS Verb (Content) --

169167-- Headers combinator not treated in fully general case,

@@ -237,8 +235,7 @@ instance HasClient t m sublayout

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

238236 Client t m sublayout

239237

240− clientWithRoute Proxy q =

241− clientWithRoute (Proxy :: Proxy sublayout) q

238+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy sublayout)

242239

243240

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

@@ -323,7 +320,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

323320

324321 where req' = req { qParams = (T.pack pname, params') : qParams req }

325322 pname = symbolVal (Proxy :: Proxy sym)

326− params' = QueryPartParams $ (fmap . fmap) (toQueryParam)

323+ params' = QueryPartParams $ (fmap . fmap) toQueryParam

327324 paramlist

328325

329326

@@ -434,30 +431,26 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

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

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

436433

437− clientWithRoute Proxy q req baseurl =

434+ clientWithRoute Proxy q req =

438435 clientWithRoute (Proxy :: Proxy sublayout) q

439436 (prependToPathParts (pure (Right $ T.pack p)) req)

440− baseurl

441437

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

443439

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

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

446442

447− clientWithRoute Proxy q req baseurl =

448− clientWithRoute (Proxy :: Proxy api) q req baseurl

443+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

449444

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

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

452447

453− clientWithRoute Proxy q req baseurl =

454− clientWithRoute (Proxy :: Proxy api) q req baseurl

448+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

455449

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

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

458452

459− clientWithRoute Proxy q req baseurl =

460− clientWithRoute (Proxy :: Proxy api) q req baseurl

453+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

461454

462455instance (HasClient t m api, Reflex t)

463456 => HasClient t m (BasicAuth realm usr :> api) where

testserver/Main.hs+17−9

@@ -5,24 +5,27 @@

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE TypeOperators #-}

8+import Control.Monad.IO.Class (liftIO)

89import Data.Aeson

910import Data.Bool

10−import Data.Char (toUpper)

11−import qualified Data.List as L

11+import Data.Char (toUpper)

12+import qualified Data.List as L

1213import Data.Monoid

1314import Data.Proxy

14−import Data.Text hiding (length, null, map, head, toUpper)

15−import qualified Data.Text as T

15+import Data.Text hiding (head, length, map,

16+ null, toUpper)

17+import qualified Data.Text as T

18+import qualified Data.Text.IO as T

1619import GHC.Generics

17−import Snap.Http.Server

18−import Snap.Core

1920import Servant.Server.Internal.SnapShims

21+import Snap.Core

22+import Snap.Http.Server

2023

21−import Servant -- hiding (serveDirectory)

24+import Servant

2225import Servant.Server

2326-- import Snap.Util.FileServe

2427import API

25−import Snap

28+import Snap

2629

2730-- * Example

2831

@@ -45,7 +48,7 @@ data App = App

4548--

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

4750server :: Server API (Handler App App)

4952 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

5053 sayhi nm greetings withGusto = case nm of

5154 Nothing -> return ("Sorry, who are you?" :: Text)

5962 return . modifier $ greetPart <> n

6063 dbl x = return $ x * 2

6164 multi = return . bool "Box unchecked" "Box Checked"

65+ qna q = do

66+ liftIO $ do

67+ putStrLn $ "qna got: " ++ show q

68+ T.putStrLn $ unQuestion q

69+ return $ Answer $ unQuestion q

6270

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

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

testserver/testserver.cabal+11−11

@@ -1,31 +1,31 @@

1−-- Initial back.cabal generated by cabal init. For further documentation,

1+-- Initial back.cabal generated by cabal init. For further documentation,

22-- see http://haskell.org/cabal/users-guide/

44name: testserver

55version: 0.1.0.0

6−-- synopsis:

7−-- description:

6+-- synopsis:

7+-- description:

88license: BSD3

99license-file: LICENSE

1010author: Greg Hale

1111maintainer: imalsogreg@gmail.com

12−-- copyright:

13−-- category:

12+-- copyright:

13+-- category:

1414build-type: Simple

15−-- extra-source-files:

15+-- extra-source-files:

1616cabal-version: >=1.10

1717

1818executable back

1919 main-is: Main.hs

20− -- other-modules:

21− -- other-extensions:

20+ -- other-modules:

21+ -- other-extensions:

2222 build-depends: aeson >= 0.9 && < 1.1

2323 , base >=4.8 && <4.10

2424 , snap >= 1.0 && < 1.1

2525 , snap-server >= 1.0 && < 1.1

2626 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.7.1 && < 0.9

28− , servant-snap >= 0.7 && < 0.8

27+ , servant >= 0.8 && < 0.11

28+ , servant-snap >= 0.7.2 && < 0.8

2929 , text >= 1.2 && < 1.3

30− -- hs-source-dirs:

30+ -- hs-source-dirs:

3131 default-language: Haskell2010