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

Add some Event Tuple instances toward tuple api

Browse Source
This commit is contained in:
Greg Hale 2017-05-29 23:40:18 -04:00
parent 630a6ebea0
commit a00c3f880e
16 changed files with 399 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -6,5 +6,4 @@ log
*.webapp
*.stats
out
reflex-platform
/.stack-work/

9
.gitmodules vendored
View File

@ -1,9 +1,3 @@
[submodule "deps/reflex-dom"]
path = deps/reflex-dom
url = https://github.com/reflex-frp/reflex-dom.git
[submodule "deps/reflex"]
path = deps/reflex
url = https://github.com/reflex-frp/reflex.git
[submodule "deps/http-api-data"]
path = deps/http-api-data
url = https://github.com/fizruk/http-api-data
@ -13,3 +7,6 @@
[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

5
.travis.yml
View File

@ -35,10 +35,9 @@ install:
$HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
fi
- travis_retry cabal update -v
- git clone https://github.com/reflex-frp/reflex-platform
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"
- reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
- 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 &

2
build.sh
View File

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

1
deps/reflex vendored

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

1
deps/reflex-dom vendored

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

1
deps/reflex-platform vendored Submodule

@ -0,0 +1 @@
Subproject commit 900e8132c43b460a6dd559d1bcc114a89b5ac92c

4
exec/Example.hs
View File

@ -19,10 +19,11 @@ import Servant.API
import API
import Data.Proxy
import Text.Read (readMaybe)
import Reflex.Dom
import Reflex.Dom hiding (run)
------------------------------------------------------------------------------
import Servant.Reflex
import Servant.Reflex.Multi
import qualified TupleExample
api :: Proxy API
@ -33,6 +34,7 @@ main = mainWidget $ do
el "h1" $ text "Wowzers!"
divClass "example-base" run
divClass "example-multi" runMulti
divClass "example-tuple" TupleExample.run
runMulti :: forall t m. (SupportsServantReflex t m,

35
exec/TupleExample.hs Normal file
View File

@ -0,0 +1,35 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module TupleExample where
import Data.Aeson
import Data.Proxy
import Data.Text
import GHC.TypeLits
import Reflex.Dom
import Servant.API
import Servant.Reflex.Tuple
type TestAPI = Get '[JSON] Int
-- :<|> Post '[JSON] Int
:<|> Capture "name" Text :> Post '[JSON] Text
run :: forall t m. (SupportsServantReflex t m, MonadWidget t m) => m ()
run = do
let (getInt :<|> greet) = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")
-- let getInt = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")
b <- button "Go for it"
g <- ("greg" <$) <$> button "Hello"
-- g <- button "Hello"
b' <- getInt b
display =<< holdDyn (Left "Waiting") b'
g' <- greet g
display =<< holdDyn (Left "Waiting") g'

27
overrides-ghc.nix
View File

@ -1,22 +1,11 @@
{ reflex-platform, ... }:
let
dc = reflex-platform.lib.dontCheck;
c2n = reflex-platform.cabal2nixResult;
ghc-mod = (import <nixpkgs> {}).haskellPackages.ghc-mod;
in
reflex-platform.ghc.override {
overrides = self: super: {
servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
snap = dc (self.callPackage (c2n deps/servant-snap/deps/snap) {});
snap-server = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
io-streams = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
io-streams-haproxy = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
snap-core = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
servant = dc (self.callPackage (c2n deps/servant/servant) {});
Glob = dc super.Glob;
http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
ghc-mod = ghc-mod;
};
}
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) {});
};
}

6
overrides.nix
View File

@ -1,13 +1,9 @@
{ reflex-platform, ... }:
let
dc = reflex-platform.lib.dontCheck;
c2n = reflex-platform.cabal2nixResult;
in
reflex-platform.ghcjs.override {
overrides = self: super: {
servant = dc (self.callPackage (c2n deps/servant/servant) {});
http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
overrides = self: super: {
};
}

7
servant-reflex.cabal
View File

@ -1,5 +1,5 @@
Name: servant-reflex
Version: 0.3
Version: 0.3.1
Synopsis: Servant reflex API generator
Description: Servant reflex API generator
License: AllRightsReserved
@ -19,6 +19,7 @@ library
exposed-modules:
Servant.Reflex
Servant.Reflex.Multi
Servant.Reflex.Tuple
other-modules:
Servant.Common.BaseUrl
@ -32,9 +33,10 @@ library
containers >= 0.5.6 && < 0.6,
data-default >= 0.5 && < 0.8,
exceptions >= 0.8 && < 0.9,
ghcjs-dom >= 0.2 && < 0.3,
ghcjs-dom >= 0.2 && < 0.10,
http-api-data >= 0.2 && < 0.4,
http-media >= 0.6 && < 0.7,
jsaddle >= 0.8 && < 0.10,
mtl >= 2.2.1 && < 2.3,
network-uri >= 2.6 && < 2.7,
reflex >= 0.5 && < 0.6,
@ -58,4 +60,5 @@ executable example
default-language: Haskell2010
main-is: Example.hs
other-modules: API
TupleExample
hs-source-dirs: exec

5
src/Servant/Common/BaseUrl.hs
View File

@ -20,18 +20,19 @@ module Servant.Common.BaseUrl (
) where
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO)
-- import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Fix (MonadFix)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics
import Language.Javascript.JSaddle.Monad (MonadJSM)
import Reflex
import Reflex.Dom
import Text.Read
type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))
type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))
-- | URI scheme to use
data Scheme =

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

@ -25,8 +25,9 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Traversable (forM)
import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
import Reflex.Dom hiding (tag)
import Reflex.Dom.Xhr (newXMLHttpRequest)
import Reflex.Dom.Xhr (newXMLHttpRequest)
import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
SupportsServantReflex)
import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@ -139,13 +140,25 @@ data ReqIO = ReqIO
defReq :: Req t
defReq = Req "GET" [] [] Nothing [] def Nothing
defReqIO :: ReqIO
defReqIO = ReqIO "GET" [] [] Nothing [] def Nothing
prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
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) (TE.decodeUtf8 . toHeader) val) : headers req }
prependToPathPartsIO :: Text -> ReqIO -> ReqIO
prependToPathPartsIO p req =
req { reqPathPartsIO = p : reqPathPartsIO req }
addHeaderIO :: (ToHttpApiData a) => Text -> a -> ReqIO -> ReqIO
addHeaderIO name val req = req { headersIO = (name, (TE.decodeUtf8 . toHeader) val) : headersIO req }
reqToReflexRequest
:: forall t. Reflex t
@ -362,9 +375,25 @@ performRequests reqMeth rs reqHost trigger = do
resps <- performSomeRequestsAsync reqs
return $ getCompose <$> resps
performRequestsIO :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
=> Text
-> Event t (f ReqIO)
-> BaseUrl
-> m (Event t (f XhrResponse))
performRequestsIO reqMeth rs reqHost = do
-- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
-- let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
let xhrReqs :: (Event t (f (XhrRequest XhrPayload))) = fmap (reqToReflexRequestIO reqMeth reqHost) <$> rs
-- let reqs = attachPromptlyDynWith (\fxhr t -> fxhr) xhrReqs trigger
resps <- performRequestsAsync xhrReqs
return $ resps
-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
performSomeRequestsAsync
:: (MonadIO (Performable m),
:: (MonadJSM (Performable m),
MonadJSM (Performable m),
HasWebView (Performable m),
PerformEvent t m,
TriggerEvent t m,
@ -377,10 +406,10 @@ performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap re
------------------------------------------------------------------------------
-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
-- that accepts 'f (Either e (XhrRequestb))' events
-- that accepts 'f (Either e (XhrRequest))' events
performSomeRequestsAsync'
:: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
=> (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
:: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
=> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
-> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
rs <- hrs
@ -415,30 +444,30 @@ performRequest reqMeth req reqHost trigger = do
return (resps, badReqs)
-- | This function actually performs the request.
performRequestIO :: forall t m tag. (SupportsServantReflex t m)
=> Text
-> ReqIO
-> BaseUrl
-> tag
-> m (Either (tag, XhrResponse) (tag, Text))
performRequestIO reqMeth req reqHost trigger = do
-- -- | This function actually performs the request.
-- performRequestIO :: forall t m tag. (SupportsServantReflex t m)
-- => Text
-- -> ReqIO
-- -> BaseUrl
-- -> tag
-- -> m (Either (tag, XhrResponse) (tag, Text))
-- performRequestIO reqMeth req reqHost trigger = do
let xhrReq = reqToReflexRequestIO reqMeth reqHost req
let reqs = (trigger ,xhrReq )
-- let xhrReq = reqToReflexRequestIO reqMeth reqHost req
-- let reqs = (trigger ,xhrReq )
-- resps <- performRequestsAsync okReqs
-- -- resps <- performRequestsAsync okReqs
-- let x :: _ = newXMLHttpRequestWithError
-- -- let x :: _ = newXMLHttpRequestWithError
-- return (resps, badReqs)
undefined
-- -- return (resps, badReqs)
-- undefined
doThing :: (IsXhrPayload a, HasWebView IO) => XhrRequest a -> IO XhrResponse
doThing req = do
v <- newEmptyMVar
newXMLHttpRequest req $ putMVar v
takeMVar v
-- doThing :: (IsXhrPayload a, MonadJSM m, HasJSContext m) => XhrRequest a -> m XhrResponse
-- doThing req = do
-- v <- liftIO newEmptyMVar
-- r <- newXMLHttpRequest req (liftIO . putMVar v)
-- liftIO $ takeMVar v
type XhrPayload = T.Text
@ -510,23 +539,23 @@ performRequestsCTIO
MimeUnrender ct a, Traversable f)
=> Proxy ct
-> Text
-> Dynamic t (f (Req t))
-> Dynamic t BaseUrl
-> Event t tag
-> m (Event t (f (ReqResult tag a)))
performRequestsCTIO ct reqMeth reqs reqHost trigger = do
resps <- performRequests reqMeth reqs reqHost trigger
-> Event t (f ReqIO)
-> BaseUrl
-> m (Event t (f (Either Text a)))
performRequestsCTIO ct reqMeth reqs reqHost = do
resps <- performRequestsIO reqMeth reqs reqHost
let decodeResp x = first T.pack .
mimeUnrender ct .
BL.fromStrict .
TE.encodeUtf8 =<< note "No body text"
(_xhrResponse_responseText x)
return $ fmap
(\(t,rs) -> ffor rs $ \r -> case r of
Left e -> RequestFailure t e
Right g -> evalResponse decodeResp (t,g)
)
resps
return $ fmap (fmap decodeResp) resps
-- return $ fmap
-- (\(t,rs) -> ffor rs $ \r -> case r of
-- Left e -> RequestFailure t e
-- Right g -> evalResponse decodeResp (t,g)
-- )
-- resps
performRequestsNoBody
@ -564,6 +593,25 @@ evalResponse decode (tag, xhr) =
else ResponseFailure tag errMsg xhr
in respPayld
-- ------------------------------------------------------------------------------
-- evalResponseIO
-- :: (XhrResponse -> Either Text a)
-- -> (XhrResponse)
-- -> ReqResult tag a
-- evalResponseIO decode (tag, xhr) =
-- let okStatus = _xhrResponse_status xhr < 400
-- errMsg = fromMaybe
-- ("Empty response with error code " <>
-- T.pack (show $ _xhrResponse_status xhr))
-- (_xhrResponse_responseText xhr)
-- respPayld = if okStatus
-- then either
-- (\e -> ResponseFailure tag e xhr)
-- (\v -> ResponseSuccess tag v xhr)
-- (decode xhr)
-- else ResponseFailure tag errMsg xhr
-- in respPayld

69
src/Servant/Reflex.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@ -38,7 +39,7 @@ import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.TypeLits
import Servant.API ((:<|>) (..), (:>), BasicAuth,
BasicAuthData, BuildHeadersTo (..),
Capture, Header, Headers (..),
@ -60,12 +61,13 @@ import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
SupportsServantReflex, baseUrlWidget,
showBaseUrl)
import Servant.Common.Req (QParam (..), QueryPart (..), Req,
ReqIO, ReqResult (..), addHeader,
ReqIO(..), ReqResult (..), addHeader, addHeaderIO,
authData, defReq, evalResponse,
performRequestsCT,
performRequestsCTIO,
performRequestsNoBody,
performSomeRequestsAsync,
prependToPathParts, qParamToQueryPart,
prependToPathParts, prependToPathPartsIO, qParamToQueryPart,
qParams, reqBody, reqFailure,
reqMethod, reqSuccess, reqTag,
respHeaders, response)
@ -97,6 +99,7 @@ client p q t = clientWithRoute p q t defReq
class HasClient t m layout (tag :: *) | m -> t where
type Client t m layout tag :: *
type ClientIO m layout tag :: *
type Inp m layout tag :: k
clientWithRoute
:: Proxy layout
-> Proxy m
@ -112,8 +115,32 @@ class HasClient t m layout (tag :: *) | m -> t where
-> BaseUrl
-> ClientIO m layout tag
data HList :: [*] -> * where
HNil :: HList '[]
HCons :: a -> HList xs -> HList (a ': xs)
type family ToTuple xs :: *
type instance ToTuple (HList '[]) = ()
type instance ToTuple (HList (a ': '[])) = a
type instance ToTuple (HList (a ': b ': '[])) = (a,b)
type instance ToTuple (HList (a ': b ': c ': '[])) = (a,b,c)
type instance ToTuple (HList (a ': b ': c ': d ': '[])) = (a,b,c,d)
type instance ToTuple (HList (a ': b ': c ': d ': e ': '[])) = (a,b,c,d,e)
type instance ToTuple (HList (a ': b ': c ': d ': e ': f ': '[])) = (a,b,c,d,e,f)
type instance ToTuple (a :> ()) = a
type instance ToTuple (a :> b :> ()) = (a,b)
type instance ToTuple (a :> b :> c :> ()) = (a,b,c)
type instance ToTuple (a :> b :> c :> d :> ()) = (a,b,c,d)
type instance ToTuple (a :> b :> c :> d :> e :> ()) = (a,b,c,d,e)
type instance ToTuple (a :> b :> c :> d :> e :> f :> ()) = (a,b,c,d,e,f)
instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
type Inp m (a :<|> b) tag = Inp m a tag :<|> Inp m b tag
type ClientIO m (a :<|> b) tag = ClientIO m a tag :<|> ClientIO m b tag
clientWithRoute Proxy q pTag req baseurl =
@ -143,8 +170,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
type Client t m (Capture capture a :> sublayout) tag =
Dynamic t (Either Text a) -> Client t m sublayout tag
type ClientIO m (Capture capture a :> sublayout) tag =
a -> ClientIO m sublayout tag
-- type ClientIO m (Capture capture a :> sublayout) tag =
-- ToTuple (Inp m (Capture capture a :> sublayout) -> ClientIO m sublayout tag
-- type Inp m (Capture capture a :> sublayout) tag =
-- a :> Inp m sublayout tag
clientWithRoute Proxy q t req baseurl val =
clientWithRoute (Proxy :: Proxy sublayout)
@ -153,12 +183,13 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
baseurl
where p = (fmap . fmap) toUrlPiece val
clientWithRouteIO Proxy q t req baseurl val =
clientWithRouteIO (Proxy :: Proxy sublayout)
q t
(prependToPathParts p req)
baseurl
where p = (fmap . fmap) toUrlPiece val
-- clientWithRouteIO Proxy q t req baseurl val =
-- clientWithRouteIO (Proxy :: Proxy sublayout)
-- q t
-- req
-- -- (prependToPathPartsIO p req)
-- baseurl
-- where p = toUrlPiece val
-- VERB (Returning content) --
@ -181,11 +212,10 @@ instance {-# OVERLAPPABLE #-}
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
req' = req { reqMethod = method }
clientWithRouteIO Proxy _ _ req baseurl tag =
-- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl tag
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
req' = req { reqMethod = method }
-- clientWithRouteIO Proxy _ _ req baseurl tag =
-- performRequestsCTIO (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl tag
-- where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
-- req' = req { reqMethodIO = method }
-- -- VERB (No content) --
@ -286,6 +316,13 @@ instance (KnownSymbol sym, ToHttpApiData a,
baseurl
where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
-- clientWithRouteIO Proxy q t req baseurl eVal =
-- clientWithRouteIO (Proxy :: Proxy sublayout)
-- q t
-- (Servant.Common.Req.addHeaderIO hname eVal req)
-- baseurl
-- where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

200
src/Servant/Reflex/Tuple.hs Normal file
View File

@ -0,0 +1,200 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- #include "overlapping-compat.h"
-- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your
-- API.
module Servant.Reflex.Tuple
( client
, BuildHeaderKeysTo(..)
, toHeaders
, HasClient(..)
, module Servant.Common.Req
, module Servant.Common.BaseUrl
) where
------------------------------------------------------------------------------
import Control.Applicative
import Data.CaseInsensitive (mk)
import Data.Functor.Identity
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import GHC.TypeLits (KnownSymbol, symbolVal)
import Servant.API ((:<|>) (..), (:>), BasicAuth,
BasicAuthData, BuildHeadersTo (..),
Capture, Header, Headers (..),
HttpVersion, IsSecure, MimeRender (..),
MimeUnrender, NoContent, QueryFlag,
QueryParam, QueryParams, Raw,
ReflectMethod (..), RemoteHost,
ReqBody, ToHttpApiData (..), Vault,
Verb, contentType)
import Reflex.Dom (Dynamic, Event, Reflex,
XhrRequest (..), XhrResponse (..),
XhrResponseHeaders (..),
attachPromptlyDynWith, constDyn, ffor,
fmapMaybe, leftmost,
performRequestsAsync)
------------------------------------------------------------------------------
import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
SupportsServantReflex, baseUrlWidget,
showBaseUrl)
import Servant.Common.Req (QParam (..), QueryPart (..), Req,
ReqIO, ReqResult (..), addHeaderIO,
authData, defReqIO, evalResponse,
performRequestsCT,
performRequestsNoBody,
performSomeRequestsAsync,
prependToPathPartsIO, qParamToQueryPart,
qParams, reqBody, reqFailure,
reqMethodIO, reqSuccess, reqTag,
respHeadersIO, response)
type family ToTuple a :: *
type instance ToTuple () = ()
type instance ToTuple (a,()) = a
type instance ToTuple (a,(b,())) = (a,b)
type instance ToTuple (a,(b,(c,()))) = (a,b,c)
type instance ToTuple (a,(b,(c,(d,())))) = (a,b,c)
type instance ToTuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)
client :: (HasClient layout t m, HasInp layout) => Proxy layout -> Proxy m -> BaseUrl -> Client layout t m
client = undefined
class HasInp layout where
type Inp layout :: *
type Out layout :: *
inpToReq :: Proxy layout -> Inp layout -> ReqIO
class HasClient layout (t :: *) (m :: * -> *) where
type Client layout t m :: *
instance (HasClient a t m,
HasClient b t m,
HasInp a,
HasInp b
) => HasClient (a :<|> b) t m where
type Client (a :<|> b) t m = Client a t m :<|> Client b t m
instance (ToHttpApiData a, HasInp sublayout) => HasInp (Capture capture a :> sublayout) where
type Inp (Capture capture a :> sublayout) = (a, Inp sublayout)
type Out (Capture capture a :> sublayout) = Out sublayout
inpToReq _ (a, otherInp) = prependToPathPartsIO (toUrlPiece a) $ inpToReq (Proxy :: Proxy sublayout) otherInp
instance (HasInp (Capture capture a :> sublayout)) => HasClient (Capture capture a :> sublayout) t m where
type Client (Capture capture a :> sublayout) t m =
Event t (ToTuple (Inp (Capture capture a :> sublayout))) ->
m (Event t (Out (Capture capture a :> sublayout)))
instance {-# OVERLAPPABLE #-}
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasInp (Verb method status cts' a) where
type Inp (Verb method status cts' a) = ()
type Out (Verb method status cts' a) = Either Text a
inpToReq _ _ = defReqIO
instance {-# OVERLAPPABLE #-}
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) t m where
type Client (Verb method status cts' a) t m = Event t (ToTuple (Inp (Verb method status cts' a))) ->
m (Event t (Out (Verb method status cts' a)))
instance {-# OVERLAPPING #-}
(ReflectMethod method) => HasInp (Verb method status cts NoContent) where
type Inp (Verb method status cts NoContent) = ()
type Out (Verb method status cts NoContent) = Either Text NoContent
instance {-# OVERLAPPING #-}
(ReflectMethod method, SupportsServantReflex t m)
=> HasClient (Verb method status cts NoContent) t m where
type Client (Verb method status cts NoContent) t m =
Event t (ToTuple (Inp (Verb method status cts NoContent))) ->
m (Event t (Out (Verb method status cts NoContent)))
instance {-# OVERLAPPABLE #-}
(MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
ReflectMethod method, cts' ~ (ct ': cts)
) => HasInp (Verb method status cts' (Headers ls a)) where
type Inp (Verb method status cts' (Headers ls a)) = ()
type Out (Verb method status cts' (Headers ls a)) = Either Text (Headers ls a)
inpToReq _ _ = defReqIO { respHeadersIO = OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))}
instance {-# OVERLAPPABLE #-}
HasInp (Verb method status cts' (Headers ls a))
=> HasClient (Verb method status cts' (Headers ls a)) t m where
type Client (Verb method status cts' (Headers ls a)) t m =
Event t (ToTuple (Inp (Verb method status cts' (Headers ls a)))) ->
m (Event t (Out (Verb method status cts' (Headers ls a))))
instance {-# OVERLAPPING #-}
(BuildHeadersTo ls,
BuildHeaderKeysTo ls) => HasInp (Verb method status cts' (Headers ls NoContent)) where
type Inp (Verb method status cts' (Headers ls NoContent)) = ()
type Out (Verb method status cts' (Headers ls NoContent)) = Either Text (Headers ls NoContent)
inpToReq _ _ = defReqIO { respHeadersIO = OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))}
instance {-# OVERLAPPING #-}
(BuildHeadersTo ls,
BuildHeaderKeysTo ls,
SupportsServantReflex t m) => HasClient (Verb method status cts' (Headers ls NoContent)) t m where
type Client (Verb method status cts' (Headers ls NoContent)) t m =
Event t (ToTuple (Inp (Verb method status cts' (Headers ls NoContent)))) ->
m (Event t (Out (Verb method status cts' (Headers ls NoContent))))
toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
toHeaders r =
let toBS = E.encodeUtf8
hdrs = maybe []
(\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
(Map.toList $ _xhrResponse_headers xhr))
(response r)
in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
class BuildHeaderKeysTo hs where
buildHeaderKeysTo :: Proxy hs -> [T.Text]
instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
where buildHeaderKeysTo _ = []
instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
=> BuildHeaderKeysTo ((Header h v) ': xs) where
buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
instance (KnownSymbol sym, ToHttpApiData a, HasInp sublayout) => HasInp (Header sym a :> sublayout) where
type Inp (Header sym a :> sublayout) = (Maybe a, Inp sublayout)
type Out (Header sym a :> sublayout) = Out sublayout
inpToReq _ (h, vs) = (addHeaderIO hname h) (inpToReq (Proxy :: Proxy sublayout) vs)
where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout t m) => HasClient (Header sym a :> sublayout) t m where
type Client (Header sym a :> sublayout) t m = Event t (ToTuple (Inp (Header sym a :> sublayout))) -> m (Event t (Out (Header sym a :> sublayout)))