mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
Add some Event Tuple instances toward tuple api
This commit is contained in:
parent
630a6ebea0
commit
a00c3f880e
1
.gitignore
vendored
1
.gitignore
vendored
@ -6,5 +6,4 @@ log
|
||||
*.webapp
|
||||
*.stats
|
||||
out
|
||||
reflex-platform
|
||||
/.stack-work/
|
||||
|
9
.gitmodules
vendored
9
.gitmodules
vendored
@ -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
|
||||
|
@ -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
2
build.sh
@ -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
deps/reflex
vendored
@ -1 +0,0 @@
|
||||
Subproject commit 2e9a8de650857424fb93b372c6d00fda5e99d380
|
1
deps/reflex-dom
vendored
1
deps/reflex-dom
vendored
@ -1 +0,0 @@
|
||||
Subproject commit f0d16ecd85474a0f09bf995278453448812796af
|
1
deps/reflex-platform
vendored
Submodule
1
deps/reflex-platform
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 900e8132c43b460a6dd559d1bcc114a89b5ac92c
|
@ -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
35
exec/TupleExample.hs
Normal 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'
|
||||
|
@ -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) {});
|
||||
};
|
||||
}
|
||||
|
@ -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) {});
|
||||
};
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -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
200
src/Servant/Reflex/Tuple.hs
Normal 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)))
|
Loading…
Reference in New Issue
Block a user