Make functor-dynamic warnings go away - merge req headers

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

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 {});
+    reflex-dom = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom {});
-    servant = pkgs.haskell.lib.dontCheck (self.callPackage (reflex-platform.cabal2nixResult deps/servant/servant) {});
   };
 }

overrides.nix

@@ -1,8 +1,13 @@
 { reflex-platform, ... }:
-let 
+let
-  pkgs = import <nixpkgs> {};
+
-  reflex-platform = import deps/reflex-platform {};
+  nixpkgs = (import <nixpkgs> {});
-in reflex-platform.ghcjs.override {
+  dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;
-  overrides = self: super: {
+  cabal2nixResult = reflex-platform.cabal2nixResult;
+
+in
+reflex-platform.ghcjs.override {
+  overrides = self: super: { 
+     reflex-dom  = dontCheck (self.callPackage deps/reflex-dom {});
   };
 }

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
+  let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
-    0 -> pathWidget
+        0 -> pathWidget
-    1 -> fullUrlWidget
+        1 -> fullUrlWidget
-    _ -> error "Surprising value"
+        _ -> 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
+          return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> 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

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 okReqs
-  resps <- performRequestAsync (fmap LT.toStrict <$> okReqs)
-#else
-  resps <- performRequestAsync (fmap LT.unpack <$> okReqs)
-#endif
 
   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]

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