ilyakooo0/servant-reflex
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-reflex.git synced 2024-10-10 16:21:20 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #88 from matthewbauer/text-jsstring

Browse Source 
Merge servant updates into text-jsstring
This commit is contained in:
Greg Hale 2020-02-17 21:21:39 -05:00 committed by GitHub
commit 97b0515baa
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
30 changed files with 360 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitmodules vendored
View File

@ -1,12 +0,0 @@
[submodule "deps/http-api-data"]
path = deps/http-api-data
url = https://github.com/fizruk/http-api-data
[submodule "deps/servant"]
path = deps/servant
url = https://github.com/haskell-servant/servant
[submodule "deps/servant-snap"]
path = deps/servant-snap
url = https://github.com/haskell-servant/servant-snap
[submodule "deps/reflex-platform"]
path = deps/reflex-platform
url = https://github.com/reflex-frp/reflex-platform

70
.travis.yml
View File

@ -1,61 +1,17 @@
sudo: required
before_cache:
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
addons:
apt:
- phantomjs
matrix:
include:
- env: CABALVER=1.24 GHCVER=7.10.3
compiler: ": #GHC 7.10.3"
addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=8.0.1
compiler: ": #GHC 8.0.1"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
before_install:
- unset CC
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
- git submodule update --init --recursive
language: nix
nix: 2.1.1
sudo: require
install:
- cabal --version
- BENCH=${BENCH---enable-benchmarks}
- TEST=${TEST---enable-tests}
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
then
zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
$HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
fi
- travis_retry cabal update -v
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"
- deps/reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
- cd testserver && dist/build/back/back -p 8000 &
- sleep 3
- phantomjs --webdriver=127.0.0.1:4444 &
- sleep 3
- sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
before_script:
- git config --global user.email "travis-ci@example.com"
- git config --global user.name "Travis-CI"
script:
- git config --global user.email "travis-ci@example.com"
- git config --global user.name "Travis-CI"
- ./build.sh
# - testdriver/dist/build/spec/spec
cache:
directories:
- /nix
- $HOME/.cabal/packages
- $HOME/.cabal/store
env:
global:
- ENCRYPTION_LABEL: "3c89d919c82e"
- COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"
- nix-env -iA cachix -f https://cachix.org/api/v1/install
- cachix use imalsogreg
- nix-build travis.nix -A build
- nix-build travis.nix -A testserver
- nix-build travis.nix -A testresults

7
changelog.md → ChangeLog.md
View File

@ -1,7 +1,12 @@
0.3.4
-----
Add selenium-based test suite
0.3.3
-----
Explicitly escape reserved characters from path pieces and query parameters
- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
0.3.2

103
README.md
View File

@ -4,14 +4,19 @@
## `servant-reflex` lets you share your `servant` APIs with the frontend
Keeping your frontend in sync with your API server can be difficult - when the API changes its input parameters or return type, XHR requests from the frontend will fail at runtime. If your API is defined by [servant](haskell-servant.readthedocs.io) combinators, you can use `servant-reflex` to share the API between the server and frontend.
Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
Keeping your frontend in sync with your API server can be difficult - when the
API changes its input parameters or return type, XHR requests from the
frontend will fail at runtime. If your API is defined by
[servant](haskell-servant.readthedocs.io) combinators, you can use
`servant-reflex` to share the API between the server and frontend.
Syncronization between is checked at compile time, and rather than building XHR
requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
## Example
We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:
We have a webservice API defined in a module where both the server (compiled
with ghc) and the frontend (compiled with ghcjs) can see it:
```haskell
type API = "getint" :> Get '[JSON] Int
@ -24,7 +29,8 @@ type API = "getint" :> Get '[JSON] Int
:<|> Raw
```
`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
`servant-reflex` then computes client functions that can query the API through
an `XhrRequest`.
```haskell
@ -37,7 +43,16 @@ type API = "getint" :> Get '[JSON] Int
(constDyn (BasePath "/"))
```
These client functions are computed from your API type. They manage serialization, `XhrRequest` generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)` respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.
These client functions are computed from your API type. They manage
serialization, `XhrRequest` generation, and deserialization for you. `a`
parameters used in URL captures become `Dynamic t (Either Text a)` parameters
in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API
parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`
respectively. These parameters to the client function are wrapped with failure
possibility to allow you to indicate at any time whether input validation for
that parameter has failed and no valid XHR request can be generated. The final
parameter is a trigger event for the XHR request. The return value
`Event t (ReqResult a)` contains responses from the API server.
```haskell
-- No need to write these functions. servant-reflex creates them for you!
@ -62,7 +77,13 @@ These client functions are computed from your API type. They manage serializatio
-> m (Event t (ReqResult () Double))
```
`ReqResult tag a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:
`ReqResult tag a` is defined in
[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)
and reports whether or not your request was sent (if validation fails, the
request won't be sent), and how decoding of the response went. You can pattern
match on these explicitly, but usually you'll want to use
`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the
elimination functions to filter the result type you care about, like this:
```haskell
-- ... continued ...
@ -80,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio
dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
```
This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
This example builds some input fields to enter API parameters, buttons to
trigger the API calls, and text elements to show the results:
```haskell
elClass "div" "int-demo" $ do
@ -103,47 +125,53 @@ This example builds some input fields to enter API parameters, buttons to trigge
display =<< holdDyn Nothing outputDouble
```
For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.
For a great introduction to recative DOM building, see the
[README](https://github.com/reflex-frp/reflex-platform) for the
`reflex-platform`. For more information about servant, see their
[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to
the respective authors of these fabulous libraries.
## Building the library and test server
This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:
First build the library:
This repository comes with a small example of an API shared between a
ghcjs-compiled frontend
([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a
ghc-compiled backend
([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).
To build these components, we will use the nix packages for the testserver. It
manages the frontend build as a dependency.
```
git submodule update --init --recursive
./build.sh
nix build -f travis.nix testserver -o server
```
Then build the test server:
Point it at the static directory and run it:
```
deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"
STATIC_DIR=server/static server/back -p 8000
```
Browse to [http://localhost:8000](http://localhost:8000) and click around.
Open the firefox or chrome developer tools and examine the XHR activity
under the Network tab.
## Running the example site
The server must be run from the directory where static assets live:
```
cd testserver
dist/build/back/back -p 8001
```
And simply browse to `localhost:8001`
**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
**For a larger example of a project that shares types between backend and
frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
## Tagging requests
The input and the return type of a client function like `getDouble` are both event streams. The individual input events and responses occur at different times and aren't automatically paired up, but you can recover the relationship by tagging the requests.
The input and the return type of a client function like `getDouble` are both
event streams. The individual input events and responses occur at different
times and aren't automatically paired up, but you can recover the
relationship by tagging the requests.
So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:
So far we have used an `Event t ()` to trigger sending a request. If we choose
e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`
will be used to trigger requests, and each `ReqResult` will carry the tag of
its request. Imagine we wanted to display not just the last "double" from
`doubleIt`, but a whole table of valid inputs and their doubled responses:
```haskell
...
@ -173,7 +201,10 @@ So far we have used an `Event t ()` to trigger sending a request. If we choose e
## Simultaneous requests
`Servant.Reflex.Multi` provides an alternative client-generation function called `clientA` (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another `Proxy`. Our `sayHi` client function will then have this type:
`Servant.Reflex.Multi` provides an alternative client-generation function
called `clientA` (client applicative). Choose a container type that has both
`Applicative` and `Traversable` instances, and pass it to `clientA` through
another `Proxy`. Our `sayHi` client function will then have this type:
```haskell
sayHi
@ -184,4 +215,10 @@ sayHi
-> m (Event t (f (ReqResult tag Text)))
```
The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s `Applicative` instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is `ZipList`, the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.
The dynamic params are each wrapped in `f`. For every firing of the trigger
event `tag`, all of these parameters will be combined according to `f`'s
`Applicative` instance (when `f` is `[]`, you will get all combinations of
all parameters taken together as a request; when `f` is `ZipList`, the Nth
elemens of each parameters list will be taken together as a request). Using
this interface, you can trigger many XHR's from a single event occurence, and
expect the responses to be structured the same way as the requests.

3
build.sh
View File

@ -1,3 +0,0 @@
#!/usr/bin/env bash
deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"

25
default.nix Normal file
View File

@ -0,0 +1,25 @@
{ mkDerivation, aeson, base, bytestring, case-insensitive
, containers, data-default, exceptions, ghcjs-dom, http-api-data
, http-media, jsaddle, mtl, network-uri, reflex, reflex-dom-core
, safe, servant, servant-auth, servant-checked-exceptions, stdenv
, string-conversions, text, transformers
}:
mkDerivation {
pname = "servant-reflex";
version = "0.3.4";
configureFlags = [ "-fexample" ];
src = builtins.filterSource
(path: type:
baseNameOf path != "result"
&& baseNameOf path != "nix") ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson base bytestring case-insensitive containers data-default
exceptions ghcjs-dom http-api-data http-media jsaddle mtl
network-uri reflex reflex-dom-core safe servant servant-auth
servant-checked-exceptions string-conversions text transformers
];
description = "servant API generator for reflex apps";
license = stdenv.lib.licenses.bsd3;
}

1
deps/http-api-data vendored

@ -1 +0,0 @@
Subproject commit dde6af363d2be6521d1d085ffbab0ea8dbe14f5d

1
deps/reflex-platform vendored

@ -1 +0,0 @@
Subproject commit 1670c5b899658babeda58329d3df6b943cf6aeca

1
deps/servant vendored

@ -1 +0,0 @@
Subproject commit 2a21e14e6e4ec01a7eed2f0c617162adaa803ab7

1
deps/servant-snap vendored

@ -1 +0,0 @@
Subproject commit 31acff4641c228fe5295388166bda485d583295d

3
exec/Example.hs
View File

@ -21,7 +21,7 @@ import Servant.API
import API
import Data.Proxy
import Text.Read (readMaybe)
import Reflex.Dom hiding (run)
import Reflex.Dom.Core hiding (run)
------------------------------------------------------------------------------
import Servant.Reflex
import Servant.Reflex.Multi
@ -97,7 +97,6 @@ run = mdo
-- Name the computed API client functions
let tweakRequest = ClientOptions $ \r -> do
putStrLn ("Got req: " ++ show r)
return $ r & withCredentials .~ True
let (getUnit :<|> getInt :<|> sayhi :<|> dbl
:<|> multi :<|> qna :<|> secret :<|> doRaw) =

2
nix/nix.conf Normal file
View File

@ -0,0 +1,2 @@
substituters = https://cache.nixos.org https://nixcache.reflex-frp.org
trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=

7
nix/reflex-platform.nix Normal file
View File

@ -0,0 +1,7 @@
let
rev = "a15d3a2411e7ca7d4ee4853b57c72fe83faee272";
in import (builtins.fetchTarball
{
url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
sha256 = "1dsvw0lah7761vndip1hqal4fjpjv84ravinnfhy83jgfav5ivna";
}) {}

9
nix/servant-snap.nix Normal file
View File

@ -0,0 +1,9 @@
# Servant-snap is stuck a bit behind atm. But we have a fork that mostly works
# except for streaming, which is good enough for this test server. See:
# https://github.com/haskell-servant/servant-snap/issues/20
{ nixpkgs ? import <nixpkgs> {}}: self: super:
self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
url = "https://github.com/antislava/servant-snap.git";
rev = "fc9658e8f52ebce9e4f304ea0c6705d697d4fa84";
sha256 = "0zlipmx1fb73mhpnndwmdmigxxrsdnsnb1157pgsrxpx89l9pjig";
}) {}

17
nix/testresults.nix Normal file
View File

@ -0,0 +1,17 @@
{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
echo About to phantom
${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
sleep 3
echo About to Server
STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
sleep 3
${curl}/bin/curl localhost:8000
${curl}/bin/curl localhost:8000/runmain.js
echo About to testdrive
${testdriver}/bin/spec > $out 2>&1
echo Done
trap "exit" INT TERM
trap "kill 0" EXIT
''

9
nix/testserver.nix Normal file
View File

@ -0,0 +1,9 @@
servant-reflex: self: super:
(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
postInstall = ''
cp dist/build/back/back $out/back
mkdir $out/static
cp ${servant-reflex}/bin/example.jsexe/* $out/static/
'';
})

11
overrides-ghc.nix
View File

@ -1,11 +0,0 @@
{ reflex-platform, ... }:
let
c2n = reflex-platform.cabal2nixResult;
dc = reflex-platform.lib.dontCheck;
in reflex-platform.ghc.override {
overrides = self: super: {
servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
};
}

9
overrides.nix
View File

@ -1,9 +0,0 @@
{ reflex-platform, ... }:
let
dc = reflex-platform.lib.dontCheck;
c2n = reflex-platform.cabal2nixResult;
in
reflex-platform.ghcjs.override {
overrides = self: super: {
};
}

30
servant-reflex.cabal
View File

@ -1,7 +1,7 @@
Name: servant-reflex
Version: 0.3.3
Synopsis: Servant reflex API generator
Description: Servant reflex API generator
Version: 0.3.4
Synopsis: servant API generator for reflex apps
Description: Generate reflex-compatible client functions from servant API descriptions
License: BSD3
License-file: LICENSE.md
Author: Greg Hale, Doug Beardsley
@ -17,39 +17,37 @@ Flag Example
library
exposed-modules:
Servant.Common.BaseUrl
Servant.Common.Req
Servant.Reflex
Servant.Reflex.Multi
other-modules:
Servant.Common.BaseUrl
Servant.Common.Req
hs-source-dirs: src
build-depends:
base >= 4.8 && < 4.10,
aeson >= 0.11 && < 1.3,
aeson >= 0.11 && < 1.5,
base >= 4.8 && < 5,
bytestring >= 0.10 && < 0.11,
case-insensitive >= 1.2.0.4 && < 1.3,
containers >= 0.5.6 && < 0.6,
data-default >= 0.5 && < 0.8,
exceptions >= 0.8 && < 0.9,
exceptions >= 0.8 && < 0.11,
ghcjs-dom >= 0.2 && < 0.10,
http-api-data >= 0.3.6 && < 0.4,
http-media >= 0.6 && < 0.8,
jsaddle >= 0.8 && < 0.10,
mtl >= 2.2.1 && < 2.3,
network-uri >= 2.6 && < 2.7,
reflex >= 0.5 && < 0.6,
reflex-dom-core == 0.4 && < 0.5,
reflex >= 0.5 && < 0.7,
reflex-dom-core >= 0.4 && < 0.6,
safe >= 0.3.9 && < 0.4,
servant >= 0.13 && < 0.14,
servant-checked-exceptions >= 1.1.0.0 && < 1.2,
servant >= 0.13 && < 0.16,
servant-checked-exceptions >= 2.0 && < 2.2,
servant-auth >= 0.2.1 && < 0.4,
string-conversions >= 0.4 && < 0.5,
text >= 1.2 && < 1.3,
transformers >= 0.4 && < 0.6
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
default-language: Haskell2010
@ -58,7 +56,7 @@ executable example
buildable: True
else
buildable: False
build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom-core, text
default-language: Haskell2010
main-is: Example.hs
other-modules: API

1
shell.nix Normal file
View File

@ -0,0 +1 @@
(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env

42
src/Servant/Common/Req.hs
View File

@ -18,13 +18,14 @@ module Servant.Common.Req where
-------------------------------------------------------------------------------
import Control.Applicative (liftA2, liftA3)
import Control.Arrow ((&&&))
import Control.Concurrent
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import Data.Bifunctor (first)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder as Builder
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Functor.Compose
@ -35,7 +36,7 @@ import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Traversable (forM)
import qualified Language.Javascript.JSaddle as JS
@ -112,6 +113,13 @@ reqFailure (ResponseFailure _ s _) = Just s
reqFailure (RequestFailure _ s) = Just s
reqFailure _ = Nothing
------------------------------------------------------------------------------
-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
reqFailure' (ResponseFailure tag s _) = Just (tag,s)
reqFailure' (RequestFailure tag s) = Just (tag,s)
reqFailure' _ = Nothing
------------------------------------------------------------------------------
-- | Simple filter/accessor for the raw XHR response
@ -173,7 +181,7 @@ prependToPathParts p req =
req { reqPathParts = p : reqPathParts req }
addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
reqToReflexRequest
:: forall t. Reflex t
@ -267,8 +275,8 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
mkAuth _ (Left e) = Left e
mkAuth Nothing r = r
mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
{ _xhrRequestConfig_user = Just $ T.decodeUtf8 u
, _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
{ _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
, _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
-> Dynamic t (Either Text (XhrRequestConfig x))
@ -415,6 +423,18 @@ evalResponse decodeRes (tag, xhr) =
else ResponseFailure tag errMsg xhr
in respPayld
------------------------------------------------------------------------------
-- | Utility for simultaneously accessing/filtering Success and Failure
-- response 'Event's,
fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
------------------------------------------------------------------------------
-- | Utility for simultaneously accessing/filtering Success and Failure
-- response 'Event's, but keeping the request tag
fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
-- the second argument expects a JSString instead of ByteString.
@ -429,7 +449,7 @@ instance FromJSON a => MimeUnrender JSON a where
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromForm a => MimeUnrender FormUrlEncoded a where
mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
mimeUnrender _ = first T.unpack . urlDecodeAsForm . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString
-- | @left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TL.Text where
@ -445,11 +465,11 @@ instance MimeUnrender PlainText String where
-- | @Right . id@
instance MimeUnrender OctetStream ByteString where
mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
mimeUnrender _ = pure . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString
-- | @Right . toStrict@
instance MimeUnrender OctetStream BS.ByteString where
mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
mimeUnrender _ = pure . TE.encodeUtf8 . JS.textFromJSString
note :: e -> Maybe a -> Either e a
note e Nothing = Left e
@ -459,8 +479,8 @@ fmapL :: (e -> e') -> Either e a -> Either e' a
fmapL _ (Right a) = Right a
fmapL f (Left e) = Left (f e)
builderToText :: BB.Builder -> T.Text
builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
builderToText :: Builder.Builder -> T.Text
builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
escape :: T.Text -> T.Text
escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

2
src/Servant/Reflex.hs
View File

@ -105,7 +105,7 @@ import Reflex.Dom.Core (Dynamic,
leftmost,
performRequestsAsync)
------------------------------------------------------------------------------
import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
import Servant.Checked.Exceptions.Internal (Envelope)
import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
Throwing,
ThrowingNonterminal,

2
src/Servant/Reflex/Multi.hs
View File

@ -79,7 +79,7 @@ import Reflex.Dom.Core (Dynamic,
attachPromptlyDynWith,
constDyn)
------------------------------------------------------------------------------
import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
import Servant.Checked.Exceptions.Internal (Envelope)
import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
Throwing,
ThrowingNonterminal,

3
testdriver/test/Servant/ReflexSpec.hs
View File

@ -9,6 +9,7 @@ import qualified Data.Text as T
import Data.Foldable
import Test.WebDriver.Commands.Wait
import Test.Hspec.WebDriver
import Test.Hspec.WebDriver (chromeCaps)
clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@ -28,7 +29,7 @@ spec :: Spec
spec = do
describe "servant-reflex tests" $ do
session "test page" $ using Chrome $ do
session "test page" $ using [chromeCaps] $ do
it "opens the page" $ runWD $
openPage "http://localhost:8000"

1
testserver/API.hs
View File

@ -1 +0,0 @@
../exec/API.hs

69
testserver/API.hs Normal file
View File

@ -0,0 +1,69 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module API where
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Text (Text)
import Servant.API
newtype Question = Question { unQuestion :: Text } deriving (Show)
instance ToJSON Question where
toJSON (Question txt) = object ["question" .= txt]
instance FromJSON Question where
parseJSON (Object v) = Question <$> v .: "question"
parseJSON x = typeMismatch "Couldn't find key 'question'" x
newtype Answer = Answer { unAnswer :: Text } deriving (Show)
instance ToJSON Answer where
toJSON (Answer txt) = object ["answer" .= txt]
instance FromJSON Answer where
parseJSON (Object v) = Answer <$> v .: "answer"
parseJSON x = typeMismatch "Couldn't find key 'answer'" x
-- | API spec for server, client, and docs
type API = "getunit" :> Get '[JSON] ()
:<|> "getint" :> Get '[JSON] Int
:<|> "sayhi" :> QueryParam "username" Text
:> QueryParams "greetings" Text
:> QueryFlag "gusto"
:> Get '[JSON] Text
:<|> "double" :> ReqBody '[JSON] Double
:> Post '[JSON] Double
:<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
:<|> "qna" :> ReqBody '[JSON] Question
:> Post '[JSON] Answer
:<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
:<|> Raw
type GET = Get '[JSON] ()
-- Imported the comprehensive API example for testing.
-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
type ComprehensiveAPI =
GET :<|>
Get '[JSON] Int :<|>
Capture "foo" Int :> GET :<|>
Header "foo" Int :> GET :<|>
HttpVersion :> GET :<|>
IsSecure :> GET :<|>
QueryParam "foo" Int :> GET :<|>
QueryParams "foo" Int :> GET :<|>
QueryFlag "foo" :> GET :<|>
-- Raw :<|>
RemoteHost :> GET :<|>
ReqBody '[JSON] Int :> GET :<|>
Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
"foo" :> GET :<|>
Vault :> GET :<|>
Verb 'POST 204 '[JSON] () :<|>
Verb 'POST 204 '[JSON] Int
-- This one isn't in scope
-- :<|> WithNamedContext "foo" '[] GET

13
testserver/Main.hs
View File

@ -7,10 +7,12 @@
{-# LANGUAGE TypeOperators #-}
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (reader)
import Data.Aeson
import Data.Bool
import Data.Char (toUpper)
import qualified Data.List as L
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Proxy
import Data.Text hiding (head, length, map,
@ -25,6 +27,7 @@ import Snap.Http.Server
import Servant
import Servant.Server
-- import Snap.Util.FileServe
import System.Environment (lookupEnv)
import API
import Snap
@ -40,7 +43,7 @@ instance ToJSON Greet
testApi :: Proxy API
testApi = Proxy
data App = App
data App = App { appStaticDir :: String }
-- Server-side handlers.
--
@ -51,7 +54,7 @@ data App = App
server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
server = return () :<|> return 100 :<|> sayhi :<|> dbl
:<|> multi :<|> qna :<|> serveSecret
:<|> serveDirectory "static"
:<|> statics
where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
sayhi nm greetings withGusto = case nm of
Nothing -> return ("Sorry, who are you?" :: Text)
@ -76,6 +79,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
req <- getRequest
liftIO $ putStrLn (show req)
return 101
statics = do
staticDir <- reader appStaticDir
serveDirectory staticDir
-- Turn the server into a WAI app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module.
@ -85,10 +91,11 @@ test = serveSnapWithContext testApi
initApp :: SnapletInit App App
initApp = makeSnaplet "myapp" "example" Nothing $ do
staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
addRoutes [("", test)
,("", serveDirectory "static")
]
return App
return (App staticDir)
-- Put this all to work!
main :: IO ()

5
testserver/run-wd-tests.sh
View File

@ -1,5 +0,0 @@
#!/usr/bin/env bash
dist/build/back/back -p 8000 &
phantomjs --webdriver=127.0.0.1:4444 &
dist/build/spec/spec

7
testserver/testserver.cabal
View File

@ -20,11 +20,12 @@ executable back
-- other-modules:
-- other-extensions:
build-depends: aeson >= 0.9 && < 1.4
, base >=4.8 && <4.11
, base >=4.8 && <4.12
, mtl
, snap >= 1.0 && < 1.2
, snap-server >= 1.0 && < 1.1
, snap-server >= 1.0 && < 1.2
, snap-core >= 1.0 && < 1.1
, servant >= 0.8 && < 0.12
, servant >= 0.8 && < 0.15
, servant-snap >= 0.8 && < 0.9
, text >= 1.0 && < 1.3
-- hs-source-dirs:

32
testserver/tr.nix
View File

@ -1,32 +0,0 @@
{ reflex-platform, ... }:
let
dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
cabal2nixResult = reflex-platform.cabal2nixResult;
nixpkgs = (import <nixpkgs> {});
in
reflex-platform.ghc.override {
overrides = self: super: {
servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
# servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
# servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
# servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
# servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
# servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
# servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
# servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
# servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
};
}

68
travis.nix Normal file
View File

@ -0,0 +1,68 @@
{
nativeCompiler ? "ghc",
# ^ Choose a GHC for compiling backend components (web server, selenium)
# (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
jsCompiler ? "ghcjs"
# ^ Choose a GHCJS for compiling the frontend
# (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
}:
let
reflexPlatform = import ./nix/reflex-platform.nix;
lib = reflexPlatform.nixpkgs.haskell.lib;
do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
overrides = self: super: {
http-media = dontCheck super.http-media;
servant = dontCheck super.servant;
lens-aeson = dontCheck super.lens-aeson;
servant-reflex = self.callPackage ./default.nix {};
};
};
ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
overrides = self: super: {
servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
testdriver = self.callCabal2nix "testdriver" ./testdriver {};
testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
servant-reflex = self.callPackage ./default.nix {};
};
};
testresults = import ./nix/testresults.nix
{ inherit reflexPlatform;
inherit (ghcPkgs) testserver testdriver;
inherit (reflexPlatform.nixpkgs) curl;
phantomjs = reflexPlatform.nixpkgs.phantomjs2;
};
in
rec {
inherit reflexPlatform ghcPkgs ghcjsPkgs;
build = ghcjsPkgs.servant-reflex;
testserver = ghcPkgs.testserver;
testdriver = ghcPkgs.testdriver;
inherit testresults;
cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
name = "servant-reflex-cabal-builder";
packages = p: [
build
];
shellHook = ''
cabal configure --ghcjs -f Example
cabal build
exec/toSite.sh
exit $?
'';
};
}