Merge branch 'develop' into ts-ssr-value

cabal.project

@@ -1 +1 @@
-packages: reflex-dom-core, reflex-dom
+packages: chrome-test-utils, reflex-dom-core, reflex-dom, reflex-dom-test-selenium

dep/reflex-platform/default.nix

@@ -1,7 +1,2 @@
 # DO NOT HAND-EDIT THIS FILE
-import ((import <nixpkgs> {}).fetchFromGitHub (
-  let json = builtins.fromJSON (builtins.readFile ./github.json);
-  in { inherit (json) owner repo rev sha256;
-       private = json.private or false;
-     }
-))
+import (import ./thunk.nix)

dep/reflex-platform/github.json

@@ -1,7 +1,8 @@
 {
   "owner": "reflex-frp",
   "repo": "reflex-platform",
-  "branch": "master",
-  "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
-  "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
+  "branch": "aa-bump-some",
+  "private": false,
+  "rev": "fd5acecb50474f795734db9fb924cc3b2fd2b508",
+  "sha256": "0wsdd67g42klsf9n3pxb3pndjdz36nzf8gp7pfm8j6nyyy2qribk"
 }

dep/reflex-platform/thunk.nix

@@ -0,0 +1,9 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import <nixpkgs> {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

reflex-dom-core/ChangeLog.md

@@ -1,5 +1,16 @@
 # Revision history for reflex-dom-core
 
+## 0.6.1.0
+
+* Bump version bounds
+* Update for new dependent-map and dependent-sum version (after the "some" package split)
+* Add `MonadAtomicRef` instance for `UnrunnableT`
+* Fix ([#467](https://github.com/reflex-frp/reflex-dom/issues/467)): Prevent multiple firings of XHR response event
+* Updates for GHC 8.10
+* Move `HasSetValue` from Reflex.Dom.Widget.Input to Reflex.Dom.Builder.Class and add an instance for `TextAreaElementConfig`
+* Add `now` to the `MonadHold` instance for `UnrunnableT`
+
+
 ## 0.6.0.0
 
 * ([#375](https://github.com/reflex-frp/reflex-dom/pull/375)) **(Breaking change)** Expose resized dimensions from `resizeDetector`, `resizeDetectorWithStyle`, and `resizeDetectorWithAttrs` from `Reflex.Dom.Widget.Resize`.

reflex-dom-core/reflex-dom-core.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.24
 Name: reflex-dom-core
-Version: 0.6.0.0
+Version: 0.6.1.0
 Synopsis: Functional Reactive Web Apps with Reflex
 Description:
   Web applications without callbacks or side-effects.
@@ -83,7 +83,7 @@ library
     primitive >= 0.5 && < 0.8,
     random >= 1.1 && < 1.2,
     ref-tf == 0.4.*,
-    reflex >= 0.6.2 && < 0.8,
+    reflex >= 0.8 && < 0.9,
     semigroups >= 0.16 && < 0.20,
     stm >= 2.4 && < 2.6,
     text == 1.2.*,

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs

@@ -744,3 +744,11 @@ instance HasDocument m => HasDocument (DynamicWriterT t w m)
 instance HasDocument m => HasDocument (PostBuildT t m)
 instance HasDocument m => HasDocument (RequesterT t request response m)
 instance HasDocument m => HasDocument (QueryT t q m)
+
+class HasSetValue a where
+  type SetValue a :: *
+  setValue :: Lens' a (SetValue a)
+  
+instance Reflex t => HasSetValue (TextAreaElementConfig er t m) where
+  type SetValue (TextAreaElementConfig er t m) = Event t Text
+  setValue = textAreaElementConfig_setValue

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs

@@ -135,6 +135,7 @@ import Data.Functor.Compose
 import Data.Functor.Constant
 import Data.Functor.Misc
 import Data.Functor.Product
+import Data.GADT.Compare (GCompare)
 import Data.IORef
 import Data.IntMap.Strict (IntMap)
 import Data.Maybe

reflex-dom-core/src/Reflex/Dom/Widget/Input.hs

@@ -629,9 +629,6 @@ instance HasAttributes (FileInputConfig t) where
   type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)
   attributes = fileInputConfig_attributes
 
-class HasSetValue a where
-  type SetValue a :: *
-  setValue :: Lens' a (SetValue a)
 
 instance HasSetValue (TextAreaConfig t) where
   type SetValue (TextAreaConfig t) = Event t Text

reflex-dom-test-selenium/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for reflex-dom-core-selenium
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

reflex-dom-test-selenium/LICENSE

@@ -0,0 +1,12 @@
+Copyright (c) 2020, Obsidian Systems LLC
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

reflex-dom-test-selenium/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

reflex-dom-test-selenium/add-overrides.nix

@@ -0,0 +1,20 @@
+{ nixpkgs }: testPackage:
+  nixpkgs.haskell.lib.overrideCabal testPackage  
+    (drv: {
+
+      # The headless browser run as part of the tests will exit without this
+      preBuild = ''
+        export HOME="$PWD"
+      '';
+
+      testSystemDepends = with nixpkgs; (drv.testSystemDepends or []) ++ [
+        selenium-server-standalone which
+        chromium
+        nixpkgs.iproute
+      ];
+
+      # The headless browser run as part of gc tests would hang/crash without this
+      preCheck = ''
+        export FONTCONFIG_PATH=${nixpkgs.fontconfig.out}/etc/fonts
+      '';
+    })

reflex-dom-test-selenium/reflex-dom-test-selenium.cabal

@@ -0,0 +1,41 @@
+cabal-version: 1.24
+Name: reflex-dom-test-selenium
+Version: 0.0.0.1
+Synopsis: Testing framework for selenium tests
+Description:
+License: BSD3
+License-file: LICENSE
+Author: Ryan Trinkle
+Maintainer: ryan.trinkle@gmail.com
+Stability: Experimental
+Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
+Build-type: Simple
+
+library
+  hs-source-dirs: src
+  build-depends:
+    async,
+    base >= 4.7 && < 4.14,
+    bytestring == 0.10.*,
+    chrome-test-utils,
+    exceptions,
+    hspec-core,
+    hspec-webdriver >= 1.2.1,
+    http-types,
+    jsaddle >= 0.9.0.0 && < 0.10,
+    jsaddle-warp,
+    network,
+    process,
+    reflex-dom-core,
+    silently,
+    text == 1.2.*,
+    wai,
+    warp,
+    webdriver,
+    websockets
+
+  exposed-modules:
+    Reflex.Dom.Test.Selenium
+
+  default-language: Haskell98
+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively

reflex-dom-test-selenium/src/Reflex/Dom/Test/Selenium.hs

@@ -0,0 +1,249 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | Utilities for testing reflex-dom widgets with Selenium.
+--
+-- Any uses of the 'testWidget' functions will start a jsaddle warp server and
+-- serve the given widget in an otherwise empty page. Webdriver commands can run
+-- on the statically rendered page, and on the hydrated page.
+module Reflex.Dom.Test.Selenium
+  ( TestWidget
+  , TestWidgetConfig (..)
+  , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
+  , withSeleniumSpec
+  , embedSpec
+  , SeleniumSetupConfig (..)
+  ) where
+
+import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
+import Control.Exception (throwIO)
+import Control.Monad (when)
+import Control.Monad.Catch (MonadMask, handle)
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Text (Text)
+import Language.Javascript.JSaddle
+import Language.Javascript.JSaddle.Warp
+import Network.HTTP.Types (status200)
+import Network.Socket (PortNumber)
+import Network.Wai (responseLBS)
+import Network.WebSockets (defaultConnectionOptions)
+import Reflex.Dom.Core
+import System.IO (stderr)
+import System.IO.Silently (hSilence)
+import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
+import Test.Hspec.WebDriver (Spec, SpecWith, WdTestSession, sessionWith, using)
+import Test.Util.ChromeFlags
+import Test.Util.UnshareNetwork
+import Test.WebDriver (WD)
+
+import qualified Control.Concurrent.Async as Async
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Test.Hspec.Core.Spec as Hspec
+import qualified Test.WebDriver as WD
+import qualified Test.WebDriver.Capabilities as WD
+
+deriving instance MonadMask WD
+
+data SeleniumSetupConfig = SeleniumSetupConfig
+  { _seleniumSetupConfig_chromiumPath :: FilePath
+  -- ^ Path to the chromium executable
+  , _seleniumSetupConfig_headless :: Bool
+  -- ^ True means that the browser is invoked in headless mode, False means that
+  -- the user can see the interaction happening on the browser (useful for debugging).
+  , _seleniumSetupConfig_seleniumPort :: PortNumber
+  -- ^ The port number used by selenium
+  }
+
+-- | Setup a selenium server and use it to run some hspec tests.
+--
+-- withSeleniumSpec config $ \runSession -> hspec $ do
+--  describe "tests using webdriver session" $ runSession $ do
+--    webdriver tests here
+withSeleniumSpec :: SeleniumSetupConfig -> ((forall multi. SpecWith (WdTestSession multi) -> Spec) -> IO a) -> IO a
+withSeleniumSpec config runSpec = do
+  liftIO $ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
+  withSandboxedChromeFlags (_seleniumSetupConfig_headless config) $ \chromeFlags -> do
+    withSeleniumServer (_seleniumSetupConfig_seleniumPort config) $ do
+      let browserPath = T.strip $ T.pack $ _seleniumSetupConfig_chromiumPath config
+      when (T.null browserPath) $ fail "No browser found"
+      let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }
+          chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
+      runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]
+
+startSeleniumServer :: PortNumber -> IO (IO ())
+startSeleniumServer port = do
+  (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
+    { std_in = NoStream
+    , std_out = NoStream
+    , std_err = NoStream
+    }
+  return $ terminateProcess ph
+
+withSeleniumServer :: PortNumber -> IO a -> IO a
+withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do
+  threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
+  f
+
+chromeConfig :: Text -> [Text] -> WD.WDConfig
+chromeConfig fp flags =
+  WD.useBrowser
+    (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags })
+    WD.defaultConfig
+
+--------------------------------------------------------------------------------
+-- Function to test widgets
+--------------------------------------------------------------------------------
+
+-- | The environment in which your widgets can be tested
+type TestWidget js t m =
+  (DomBuilder t m, MonadHold t m, PostBuild t m
+  , Prerender js t m, PerformEvent t m, TriggerEvent t m
+  , MonadFix m, MonadIO (Performable m), MonadIO m)
+
+-- | Configuration of individual tests
+data TestWidgetConfig = TestWidgetConfig
+  { _testWidgetConfig_debug :: Bool
+  -- ^ If this flag is set to True, during the test we will emit debug messages
+  , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+  -- ^ We can add widgets here that will be included in the head of the page
+  --   (useful for example to include external js libraries in the tests)
+  , _testWidgetConfig_jsaddlePort :: PortNumber
+  -- ^ Port used by the jsaddle server
+  }
+
+-- | Test a widget by running some webdriver commands before and after
+-- hydration.
+testWidget
+  :: TestWidgetConfig
+  -> WD a
+  -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
+  -> WD b
+  -- ^ Webdriver commands to run after hydration switchover
+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+  -- ^ Widget we are testing (contents of body)
+  -> WD b
+testWidget cfg before after widget = testWidget' cfg before (const after) widget
+
+-- | Test a widget by running some webdriver commands before hydration (on the
+-- statically rendered page).
+testWidgetStatic
+  :: TestWidgetConfig
+  -> WD a
+  -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+  -- ^ Widget we are testing (contents of body)
+  -> WD a
+testWidgetStatic cfg before widget = testWidget' cfg before pure widget
+
+-- | Test a widget by running some webdriver commands after hydration.
+testWidgetHydrated
+  :: TestWidgetConfig
+  -> WD b
+  -- ^ Webdriver commands to run after hydration switchover
+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+  -- ^ Widget we are testing (contents of body)
+  -> WD b
+testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
+
+-- | Test a widget by running some webdriver commands before and after
+-- hydration. Like 'testWidget', but you can use the result of the webdriver
+-- commands from before hydration in the post hydration test.
+testWidget'
+  :: TestWidgetConfig
+  -> WD a
+  -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
+  -> (a -> WD b)
+  -- ^ Webdriver commands to run after hydration switchover
+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
+  -- ^ Widget we are testing (contents of body)
+  -> WD b
+testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do
+  let putStrLnDebug :: MonadIO m => Text -> m ()
+      putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
+      staticApp = do
+        el "head" $ headWidget
+        el "body" $ do
+          bodyWidget
+          el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
+  putStrLnDebug "rendering static"
+  ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
+  putStrLnDebug "rendered static"
+  waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
+  waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
+  let entryPoint = do
+        putStrLnDebug "taking waitBeforeJS"
+        liftIO $ takeMVar waitBeforeJS
+        let switchOverAction = do
+              putStrLnDebug "switchover syncPoint"
+              syncPoint
+              putStrLnDebug "putting waitUntilSwitchover"
+              liftIO $ putMVar waitUntilSwitchover ()
+              putStrLnDebug "put waitUntilSwitchover"
+        putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
+        mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
+        putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
+        syncPoint
+  application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
+    putStrLnDebug "sending response"
+    r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
+    putStrLnDebug "sent response"
+    return r
+  waitJSaddle <- liftIO newEmptyMVar
+  let settings = foldr ($) Warp.defaultSettings
+        [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
+        , Warp.setBeforeMainLoop $ do
+            putStrLnDebug "putting waitJSaddle"
+            putMVar waitJSaddle ()
+            putStrLnDebug "put waitJSaddle"
+        ]
+      -- hSilence to get rid of ConnectionClosed logs
+      silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]
+      jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application
+  withAsync' jsaddleWarp $ do
+    putStrLnDebug "taking waitJSaddle"
+    liftIO $ takeMVar waitJSaddle
+    putStrLnDebug "opening page"
+    WD.openPage $ "http://localhost:" <> show jsaddlePort
+    putStrLnDebug "running beforeJS"
+    a <- beforeJS
+    putStrLnDebug "putting waitBeforeJS"
+    liftIO $ putMVar waitBeforeJS ()
+    putStrLnDebug "taking waitUntilSwitchover"
+    liftIO $ takeMVar waitUntilSwitchover
+    putStrLnDebug "running afterSwitchover"
+    afterSwitchover a
+
+--------------------------------------------------------------------------------
+-- Utilities
+--------------------------------------------------------------------------------
+
+-- | Embed a different spec type by evaluating it directly.
+embedSpec :: (Hspec.Example a, MonadIO m) => Hspec.Arg a -> a -> m ()
+embedSpec arg spec = liftIO $ do
+  Hspec.Result _info status <- Hspec.evaluateExample
+    spec
+    Hspec.defaultParams
+    (\actionWith -> actionWith arg)
+    (\_ -> pure ())
+  case status of
+    Hspec.Success -> pure ()
+    Hspec.Pending _ _ -> pure () -- should not happen
+    failure -> throwIO failure
+
+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
+withAsync' f g = bracket
+  (liftIO $ Async.async f)
+  (liftIO . Async.uninterruptibleCancel)
+  (const g)

reflex-dom/ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for reflex-dom
 
+## 0.6.1.0
+
+* Update for new dependent-map and dependent-sum (after the "some" package split)
+
 ## 0.6.0.0
 
 * ([#379](https://github.com/reflex-frp/reflex-dom/pull/379)) Re-export all modules from `reflex-dom-core`. The newly re-exported modules are:

reflex-dom/reflex-dom.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.24
 Name: reflex-dom
-Version: 0.6.0.0
+Version: 0.6.1.0
 Synopsis: Functional Reactive Web Apps with Reflex
 Description:
   Web applications without callbacks or side-effects.
@@ -73,8 +73,8 @@ library
   build-depends:
     base >= 4.7 && < 4.14,
     bytestring == 0.10.*,
-    reflex >= 0.6.2 && < 0.8,
-    reflex-dom-core == 0.6.0.0,
+    reflex >= 0.8 && < 0.9,
+    reflex-dom-core == 0.6.1.0,
     text == 1.2.*
   if !impl(ghcjs)
     if flag(use-warp) && (os(linux) || os(osx))