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

Make functor-dynamic warnings go away - merge req headers

Browse Source
This commit is contained in:
Greg Hale 2016-08-29 18:05:06 -04:00
parent d7614ff76f
commit 44acee362b
6 changed files with 53 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
exec/Example.hs
View File

@ -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

3
overrides-ghc.nix
View File

@ -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 {});
};
}

11
overrides.nix
View File

@ -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 {});
};
}

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

@ -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
let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
0 -> pathWidget
1 -> fullUrlWidget
_ -> error "Surprising value"
joinDyn <$> widgetHold pathWidget (updated bUrlWidget)
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

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

@ -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]

8
src/Servant/Reflex.hs
View File

@ -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