From 44acee362b7042730ca66939bf1dc90a26c497d1 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 29 Aug 2016 18:05:06 -0400 Subject: [PATCH] Make functor-dynamic warnings go away - merge req headers --- exec/Example.hs | 7 +++--- overrides-ghc.nix | 3 +-- overrides.nix | 15 ++++++++----- src/Servant/Common/BaseUrl.hs | 22 ++++++++----------- src/Servant/Common/Req.hs | 40 ++++++++++++++++++++++------------- src/Servant/Reflex.hs | 8 +++---- 6 files changed, 53 insertions(+), 42 deletions(-) diff --git a/exec/Example.hs b/exec/Example.hs index 7a03f8a..508c839 100644 --- a/exec/Example.hs +++ b/exec/Example.hs @@ -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 diff --git a/overrides-ghc.nix b/overrides-ghc.nix index 8416984..b28a210 100644 --- a/overrides-ghc.nix +++ b/overrides-ghc.nix @@ -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 {}); }; } diff --git a/overrides.nix b/overrides.nix index f6cccd0..2bb4866 100644 --- a/overrides.nix +++ b/overrides.nix @@ -1,8 +1,13 @@ { reflex-platform, ... }: -let - pkgs = import {}; - reflex-platform = import deps/reflex-platform {}; -in reflex-platform.ghcjs.override { - overrides = self: super: { +let + + nixpkgs = (import {}); + 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 {}); }; } diff --git a/src/Servant/Common/BaseUrl.hs b/src/Servant/Common/BaseUrl.hs index 2b135fe..4d1a403 100644 --- a/src/Servant/Common/BaseUrl.hs +++ b/src/Servant/Common/BaseUrl.hs @@ -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 diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 0a57d90..773b537 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -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] diff --git a/src/Servant/Reflex.hs b/src/Servant/Reflex.hs index 19dc6cf..40d0a95 100644 --- a/src/Servant/Reflex.hs +++ b/src/Servant/Reflex.hs @@ -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