mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-11-05 03:30:41 +03:00
Make functor-dynamic warnings go away - merge req headers
This commit is contained in:
Greg Hale
parent
d7614ff76f
commit
44acee362b
@ -32,7 +32,7 @@ run = do
|
||||
-- (alternatively we could just `let url = constDyn (BasePath "/")`)
|
||||
url <- baseUrlWidget
|
||||
el "br" (return ())
|
||||
dynText =<< mapDyn showBaseUrl url
|
||||
dynText $ showBaseUrl <$> url
|
||||
el "br" (return ())
|
||||
|
||||
-- Name the computed API client functions
|
||||
@ -95,11 +95,12 @@ run = do
|
||||
dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)
|
||||
|
||||
showXhrResponse :: XhrResponse -> Text
|
||||
showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =
|
||||
showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
|
||||
T.unlines ["stat: " <> tShow stat
|
||||
,"stattxt: " <> tShow stattxt
|
||||
,"resp: " <> maybe "" showRB rbmay
|
||||
,"rtext: " <> tShow rtmay]
|
||||
,"rtext: " <> tShow rtmay
|
||||
,"rHeaders: " <> tShow respHeaders]
|
||||
|
||||
tShow :: Show a => a -> Text
|
||||
tShow = T.pack . show
|
||||
|
||||
@ -4,7 +4,6 @@ let
|
||||
reflex-platform = import deps/reflex-platform {};
|
||||
in reflex-platform.ghc.override {
|
||||
overrides = self: super: {
|
||||
reflex-dom-contrib = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom-contrib {});
|
||||
servant = pkgs.haskell.lib.dontCheck (self.callPackage (reflex-platform.cabal2nixResult deps/servant/servant) {});
|
||||
reflex-dom = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom {});
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,8 +1,13 @@
|
||||
{ reflex-platform, ... }:
|
||||
let
|
||||
pkgs = import <nixpkgs> {};
|
||||
reflex-platform = import deps/reflex-platform {};
|
||||
in reflex-platform.ghcjs.override {
|
||||
|
||||
nixpkgs = (import <nixpkgs> {});
|
||||
dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;
|
||||
cabal2nixResult = reflex-platform.cabal2nixResult;
|
||||
|
||||
in
|
||||
reflex-platform.ghcjs.override {
|
||||
overrides = self: super: {
|
||||
reflex-dom = dontCheck (self.callPackage deps/reflex-dom {});
|
||||
};
|
||||
}
|
||||
|
||||
@ -15,7 +15,8 @@ module Servant.Common.BaseUrl (
|
||||
, showBaseUrl
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
import Control.Monad (join)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
@ -60,17 +61,17 @@ showBaseUrl (BaseFullUrl urlscheme host port path) =
|
||||
baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)
|
||||
baseUrlWidget = elClass "div" "base-url" $ do
|
||||
urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def
|
||||
bUrlWidget <- forDyn (value urlWidget) $ \i -> case i of
|
||||
0 -> pathWidget
|
||||
1 -> fullUrlWidget
|
||||
_ -> error "Surprising value"
|
||||
joinDyn <$> widgetHold pathWidget (updated bUrlWidget)
|
||||
let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
|
||||
0 -> pathWidget
|
||||
1 -> fullUrlWidget
|
||||
_ -> error "Surprising value"
|
||||
join <$> widgetHold pathWidget (updated bUrlWidget)
|
||||
where pathWidget :: m (Dynamic t BaseUrl)
|
||||
pathWidget = do
|
||||
text "Url base path"
|
||||
t <- textInput (def {_textInputConfig_attributes =
|
||||
constDyn ("placeholder" =: "/a/b")})
|
||||
mapDyn BasePath (value t)
|
||||
return $ BasePath <$> value t
|
||||
fullUrlWidget :: m (Dynamic t BaseUrl)
|
||||
fullUrlWidget = do
|
||||
schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
|
||||
@ -79,9 +80,4 @@ baseUrlWidget = elClass "div" "base-url" $ do
|
||||
prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
|
||||
port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
|
||||
path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
|
||||
BaseFullUrl `mapDyn` value schm `myApDyn` value srv `myApDyn` port `myApDyn` value path
|
||||
|
||||
myApDyn :: MonadWidget t m => m (Dynamic t (a -> b)) -> Dynamic t a -> m (Dynamic t b)
|
||||
myApDyn f' a = do
|
||||
f <- f'
|
||||
combineDyn ($) f a
|
||||
return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
|
||||
|
||||
@ -18,8 +18,6 @@ import Data.Proxy (Proxy(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Lazy.Encoding as LTE
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import Reflex
|
||||
import Reflex.Dom
|
||||
import Servant.Common.BaseUrl
|
||||
@ -69,15 +67,15 @@ data Req t = Req
|
||||
, authData :: Maybe (Dynamic t (Maybe BasicAuthData))
|
||||
}
|
||||
|
||||
defReq :: Reflex t => Req t
|
||||
defReq :: Req t
|
||||
defReq = Req "GET" [] [] Nothing [] Nothing
|
||||
|
||||
prependToPathParts :: Reflex t => Dynamic t (Either Text Text) -> Req t -> Req t
|
||||
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) toHeader val) : headers req }
|
||||
addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
|
||||
|
||||
|
||||
-- * performing requests
|
||||
@ -144,26 +142,33 @@ performRequest reqMeth req reqHost trigger = do
|
||||
|
||||
mkConfigBody :: Either Text [(Text,Text)]
|
||||
-> (Either Text (BL.ByteString, Text))
|
||||
-> Either Text (XhrRequestConfig LT.Text)
|
||||
-> Either Text (XhrRequestConfig XhrPayload)
|
||||
mkConfigBody ehs rb = case (ehs, rb) of
|
||||
(_, Left e) -> Left e
|
||||
(Left e, _) -> Left e
|
||||
(Right hs, Right (bBytes, bCT)) ->
|
||||
Right $ XhrRequestConfig
|
||||
{ _xhrRequestConfig_sendData = Just (BL.unpack bBytes)
|
||||
{ _xhrRequestConfig_sendData = bytesToPayload bBytes
|
||||
, _xhrRequestConfig_headers =
|
||||
Map.insert "Content-Type" bCT (Map.fromList hs)
|
||||
, _xhrRequestConfig_user = Nothing
|
||||
, _xhrRequestConfig_password = Nothing
|
||||
, _xhrRequestConfig_responseType = Nothing
|
||||
, _xhrRequestConfig_withCredentials = False
|
||||
, _xhrRequestConfig_responseHeaders = def
|
||||
}
|
||||
|
||||
xhrOpts :: Dynamic t (Either Text (XhrRequestConfig LT.Text))
|
||||
xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
|
||||
xhrOpts = case reqBody req of
|
||||
Nothing -> ffor xhrHeaders $ \case
|
||||
Left e -> Left e
|
||||
Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs }
|
||||
Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
|
||||
, _xhrRequestConfig_user = Nothing
|
||||
, _xhrRequestConfig_password = Nothing
|
||||
, _xhrRequestConfig_responseType = Nothing
|
||||
, _xhrRequestConfig_sendData = ""
|
||||
, _xhrRequestConfig_withCredentials = False
|
||||
}
|
||||
Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
|
||||
|
||||
mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)
|
||||
@ -181,18 +186,23 @@ performRequest reqMeth req reqHost trigger = do
|
||||
|
||||
xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
|
||||
|
||||
let reqs = tagDyn xhrReq trigger
|
||||
let reqs = tagPromptlyDyn xhrReq trigger
|
||||
okReqs = fmapMaybe (either (const Nothing) Just) reqs
|
||||
badReqs = fmapMaybe (either Just (const Nothing)) reqs
|
||||
|
||||
#ifndef ghcjs_HOST_OS
|
||||
resps <- performRequestAsync (fmap LT.toStrict <$> okReqs)
|
||||
#else
|
||||
resps <- performRequestAsync (fmap LT.unpack <$> okReqs)
|
||||
#endif
|
||||
resps <- performRequestAsync okReqs
|
||||
|
||||
return (resps, badReqs)
|
||||
|
||||
#ifdef ghcjs_HOST_OS
|
||||
type XhrPayload = String
|
||||
bytesToPayload :: BL.ByteString -> XhrPayload
|
||||
bytesToPayload = BL.unpack
|
||||
#else
|
||||
type XhrPayload = T.Text
|
||||
bytesToPayload :: BL.ByteString -> XhrPayload
|
||||
bytesToPayload = T.pack . BL.unpack
|
||||
#endif
|
||||
|
||||
-- TODO implement
|
||||
-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
|
||||
|
||||
@ -51,7 +51,7 @@ import Reflex.Dom
|
||||
-- -> m (Event t (Either XhrError (Book,Book)))
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi host
|
||||
-- > where host = constDyn $ BaseUrl Http "localhost" 8080
|
||||
client :: (HasClient t m layout, MonadWidget t m)
|
||||
client :: (HasClient t m layout)
|
||||
=> Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
|
||||
client p q baseurl = clientWithRoute p q defReq baseurl
|
||||
|
||||
@ -80,7 +80,7 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
|
||||
-- -> Event t ()
|
||||
-- -> m (Event t (Either XhrError (Text, Book)))
|
||||
-- > getBook = client myApi (constDyn host)
|
||||
instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m sublayout)
|
||||
instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)
|
||||
=> HasClient t m (Capture capture a :> sublayout) where
|
||||
|
||||
type Client t m (Capture capture a :> sublayout) =
|
||||
@ -183,6 +183,7 @@ instance (KnownSymbol sym, ToHttpApiData a,
|
||||
q
|
||||
(Servant.Common.Req.addHeader hname eVal req)
|
||||
baseurl
|
||||
where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
|
||||
-- functions.
|
||||
@ -337,7 +338,7 @@ instance (MonadWidget t m) => HasClient t m Raw where
|
||||
<> _xhrRequest_url jx})
|
||||
xhrs
|
||||
(showBaseUrl <$> baseurl)
|
||||
reqs = tagDyn xhrs' triggers
|
||||
reqs = tagPromptlyDyn xhrs' triggers
|
||||
okReq = fmapMaybe hush reqs
|
||||
badReq = fmapMaybe tattle reqs
|
||||
resps <- performRequestAsync okReq
|
||||
@ -382,7 +383,6 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
|
||||
where req' = req { reqBody = bodyBytesCT }
|
||||
ctProxy = Proxy :: Proxy ct
|
||||
ctString = T.pack $ show $ contentType ctProxy
|
||||
--ctString = decodeUtf8 . CI.original . M.mainType $ contentType ctProxy
|
||||
bodyBytesCT = Just $ (fmap . fmap)
|
||||
(\b -> (mimeRender ctProxy b, ctString))
|
||||
body
|
||||
|
||||
Loading…
Reference in New Issue
Block a user