5d0ef87 · typeable/servant-reflex

.gitignore+1

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

66*.webapp

77*.stats

88out

9+reflex-platform

.travis.yml−1

@@ -20,7 +20,6 @@ matrix:

2020

2121

2222before_install:

23− - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d

2423 - unset CC

2524 - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

2625 - git submodule update --init --recursive

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 #-}

34

45module API where

56

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+13−2

@@ -87,8 +87,8 @@ run = mdo

8787 el "br" (return ())

8888

8989 -- Name the computed API client functions

91− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

91+ client api (Proxy :: Proxy m) url

9292

9393 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do

9494 unitBtn <- divClass "unit-button" $ button "Get unit"

@@ -160,6 +160,17 @@ run = mdo

160160

161161 return ()

162162

163+ el "br" $ return ()

164+

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

166+ text "JSON Unicode encoding test"

167+ txt <- value <$> textInput def

168+ ev <- button "Question"

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

170+ rr <- qna dQ ev

171+ el "p" $

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

173+

163174showXhrResponse :: XhrResponse -> Text

164175showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

165176 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+2−2

@@ -36,7 +36,7 @@ library

3636 reflex >= 0.5 && < 0.6,

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

3838 safe >= 0.3.9 && < 0.4,

39− servant >= 0.5 && < 0.9,

39+ servant >= 0.8 && < 0.11,

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

4141 text >= 1.2 && < 1.3,

4242 transformers >= 0.4 && < 0.6

@@ -46,7 +46,7 @@ library

4646 default-language: Haskell2010

4747

4848executable example

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

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

5050 default-language: Haskell2010

5151 main-is: Example.hs

5252 other-modules: API

src/Servant/Common/Req.hs+62−36

@@ -17,9 +17,10 @@ import Control.Applicative (liftA2, liftA3)

1717import Control.Arrow (second)

1818import Control.Monad (join)

1919import Control.Monad.IO.Class (MonadIO, liftIO)

20+import Data.Bifunctor (first)

2021import qualified Data.ByteString.Lazy.Char8 as BL

2122import qualified Data.Map as Map

22−import Data.Maybe (catMaybes)

23+import Data.Maybe (catMaybes, fromMaybe)

2324import Data.Functor.Compose

2425import Data.Monoid ((<>))

2526import Data.Proxy (Proxy(..))

@@ -279,15 +280,10 @@ performRequest reqMeth req reqHost trigger = do

279280 return (resps, badReqs)

280281

281282

282−#ifdef ghcjs_HOST_OS

283−type XhrPayload = String

284−bytesToPayload :: BL.ByteString -> XhrPayload

285−bytesToPayload = BL.unpack

286−#else

287283type XhrPayload = T.Text

288284bytesToPayload :: BL.ByteString -> XhrPayload

289−bytesToPayload = T.pack . BL.unpack

290−#endif

285+bytesToPayload = TE.decodeUtf8 . BL.toStrict

286+

291287

292288performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

293289 => Text

@@ -296,20 +292,10 @@ performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

296292 -> Event t tag -> m (Event t (tag, ReqResult NoContent))

297293performRequestNoBody reqMeth req reqHost trigger = do

298294 (resp, badReq) <- performRequest reqMeth req reqHost trigger

299− return $ leftmost [ fmap (ResponseSuccess NoContent) <$> resp, fmap RequestFailure <$> badReq]

295+ let decodeResp = const $ Right NoContent

296+ return $ leftmost [ fmap (second (evalResponse decodeResp)) resp,

297+ fmap (second RequestFailure) badReq]

300298

301−performRequestsNoBody :: forall t m f tag. (SupportsServantReflex t m, Traversable f)

302− => Text

303− -> Dynamic t (f (Req t))

304− -> Dynamic t BaseUrl

305− -> Event t tag -> m (Event t (tag, f (ReqResult NoContent)))

306−performRequestsNoBody reqMeth reqs reqHost trigger = do

307− resp <- performRequests reqMeth reqs reqHost trigger

308− return $ (fmap . fmap) aux <$> resp

309− where

310− aux (Right x) = ResponseSuccess NoContent x

311− aux (Left e) = RequestFailure e

312− -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

313299

314300

315301performRequestCT

@@ -323,13 +309,15 @@ performRequestCT

323309 -> m (Event t (tag, ReqResult a))

324310performRequestCT ct reqMeth req reqHost trigger = do

325311 (resp, badReq) <- performRequest reqMeth req reqHost trigger

326− let decodes = ffor resp $ fmap (\xhr ->

327− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)

328− =<< note "No body text" (_xhrResponse_responseText xhr), xhr))

329− reqs = ffor decodes $ fmap (\case

330− (Right a, r) -> ResponseSuccess a r

331− (Left e, r) -> ResponseFailure (T.pack e) r)

332− return $ leftmost [reqs, fmap RequestFailure <$> badReq]

312+ let decodeResp x = first T.pack .

313+ mimeUnrender ct .

314+ BL.fromStrict .

315+ TE.encodeUtf8 =<< note "No body text"

316+ (_xhrResponse_responseText x)

317+

318+ return $ leftmost [fmap (second (evalResponse decodeResp)) resp,

319+ fmap (second RequestFailure) badReq]

320+

333321

334322performRequestsCT

335323 :: (SupportsServantReflex t m,

@@ -342,14 +330,52 @@ performRequestsCT

342330 -> m (Event t (tag, f (ReqResult a)))

343331performRequestsCT ct reqMeth reqs reqHost trigger = do

344332 resps <- performRequests reqMeth reqs reqHost trigger

345− return $ fmap (second (fmap reqToResult)) resps

346− where

347− reqToResult (Left e) = RequestFailure e

348− reqToResult (Right x) = case _xhrResponse_responseText x of

349− Nothing -> ResponseFailure "No request body" x

350− Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of

351− Left e -> ResponseFailure (T.pack e) x

352− Right v -> ResponseSuccess v x

333+ let decodeResp x = first T.pack .

334+ mimeUnrender ct .

335+ BL.fromStrict .

336+ TE.encodeUtf8 =<< note "No body text"

337+ (_xhrResponse_responseText x)

338+ return $ ffor resps $ \(t, rs) ->

339+ (t, ffor rs $ \r -> case r of

340+ Left e -> RequestFailure e

341+ Right g -> evalResponse decodeResp g

342+ )

343+

344+

345+performRequestsNoBody

346+ :: (SupportsServantReflex t m,

347+ Traversable f)

348+ => Text

349+ -> Dynamic t (f (Req t))

350+ -> Dynamic t BaseUrl

351+ -> Event t tag

352+ -> m (Event t (tag, f (ReqResult NoContent)))

353+performRequestsNoBody reqMeth reqs reqHost trigger = do

354+ resps <- performRequests reqMeth reqs reqHost trigger

355+ let decodeResp = const $ Right NoContent

356+ return $ ffor resps $ \(t, rs) ->

357+ (t, ffor rs $ \r -> case r of

358+ Left e -> RequestFailure e

359+ Right g -> evalResponse decodeResp g

360+ )

361+

362+

363+

364+------------------------------------------------------------------------------

365+evalResponse :: (XhrResponse -> Either Text a) -> XhrResponse -> ReqResult a

366+evalResponse decode xhr =

367+ let okStatus = _xhrResponse_status xhr < 400

368+ errMsg = fromMaybe

369+ ("Empty response with error code " <>

370+ T.pack (show $ _xhrResponse_status xhr))

371+ (_xhrResponse_responseText xhr)

372+ respPayld = if okStatus

373+ then either (flip ResponseFailure xhr)

374+ (flip ResponseSuccess xhr) (decode xhr)

375+ else ResponseFailure errMsg xhr

376+ in respPayld

377+

378+

353379

354380

355381note :: e -> Maybe a -> Either e a

src/Servant/Reflex.hs+24−18

@@ -1,17 +1,24 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

1414{-# LANGUAGE MultiParamTypeClasses #-}

15+{-# LANGUAGE OverloadedStrings #-}

16+{-# LANGUAGE PolyKinds #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

18+{-# LANGUAGE TupleSections #-}

19+{-# LANGUAGE TypeFamilies #-}

20+{-# LANGUAGE TypeOperators #-}

21+{-# LANGUAGE UndecidableInstances #-}

1522

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

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

@@ -70,6 +77,7 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

7077 reqMethod, respHeaders, response,

7178 qParams)

7279

80+

7381-- * Accessing APIs as a Client

7482

7583-- | 'client' allows you to produce operations to query an API from a client.

@@ -177,7 +185,7 @@ instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]

177185

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

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

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

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

181189

182190-- HEADERS Verb (Content) --

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

@@ -260,7 +268,6 @@ instance HasClient t m sublayout tag

260268 clientWithRoute (Proxy :: Proxy sublayout) q t

261269

262270

263−

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

265272-- the corresponding querying function will automatically take

266273-- an additional argument of the type specified by your 'QueryParam',

@@ -345,7 +352,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

345352

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

347354 pname = symbolVal (Proxy :: Proxy sym)

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

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

349356 paramlist

350357

351358

@@ -453,8 +460,7 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient

453460

454461 clientWithRoute Proxy q t req baseurl =

455462 clientWithRoute (Proxy :: Proxy sublayout) q t

456− (prependToPathParts (pure (Right $ T.pack p)) req)

457− baseurl

463+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl

458464

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

460466

testserver/Main.hs+20−10

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

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE TypeOperators #-}

77

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)

5760 | otherwise = T.intercalate ", " (L.init greetings)

5861 <> ", and " <> L.last greetings <> ", "

5962 return . modifier $ greetPart <> n

60− dbl x = return $ x * 2

63+ dbl x = if x `elem` [4,13]

64+ then throwError $ err500 { errBody = "No unlucky numbers please" }

65+ else return $ x * 2

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

67+ qna q = do

68+ liftIO $ do

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

70+ T.putStrLn $ unQuestion q

71+ return $ Answer $ unQuestion q

6272

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

6474-- 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/

33

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