0eb4e0c · jsaddle · git.iko.soy

git.iko.soy/jsaddle

Debug features: Warp auto reload and runOnAll

Start jsaddle-warp with debug instead of run and it will forkIO the server instead of blocking. If you :reload in ghci you can then call debug again to restart the server and refresh attached browsers.

commit0eb4e0ce29193dc677f8a046104f51304d1263dd authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateThu 15 Jun 2017, 10:17 (9 years ago) parent29392e2

8 files changed+167−31

compare with master

unifiedsplit

jsaddle-warp/default.nix+7−6 jsaddle-warp/jsaddle-warp.cabal+3−2 jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+95−16 jsaddle/default.nix+2−1 jsaddle/jsaddle.cabal+4−1 jsaddle/src/Language/Javascript/JSaddle/Debug.hs+48 jsaddle/src/Language/Javascript/JSaddle/Run.hs+5−4 jsaddle/src/Language/Javascript/JSaddle/Types.hs+3−1

jsaddle-warp/default.nix+7−6

@@ -1,16 +1,17 @@

11{ mkDerivation, aeson, base, bytestring, containers, deepseq

2−, doctest, filepath, ghc-prim, http-types, jsaddle, lens, network

3−, primitive, process, QuickCheck, ref-tf, stdenv, stm, text, time

4−, transformers, uuid, uuid-types, wai, wai-websockets, warp

5−, webdriver, websockets

2+, doctest, filepath, foreign-store, ghc-prim, http-types, jsaddle

3+, lens, network, primitive, process, QuickCheck, ref-tf, stdenv

4+, stm, text, time, transformers, uuid, uuid-types, wai

5+, wai-websockets, warp, webdriver, websockets

66}:

77mkDerivation {

88 pname = "jsaddle-warp";

99 version = "0.9.1.0";

1010 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

1111 libraryHaskellDepends = [

12− aeson base bytestring containers http-types jsaddle stm text time

13− transformers uuid uuid-types wai wai-websockets warp websockets

12+ aeson base bytestring containers foreign-store http-types jsaddle

13+ stm text time transformers uuid uuid-types wai wai-websockets warp

14+ websockets

1415 ];

1516 testHaskellDepends = [

1617 aeson base bytestring containers deepseq doctest filepath ghc-prim

jsaddle-warp/jsaddle-warp.cabal+3−2

@@ -1,5 +1,5 @@

11name: jsaddle-warp

2−version: 0.9.1.0

2+version: 0.9.2.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -28,8 +28,9 @@ library

2828 aeson >=0.8.0.2 && <1.3,

2929 bytestring >=0.10.6.0 && <0.11,

3030 containers >=0.5.6.2 && <0.6,

31+ foreign-store >=0.2 && <0.3,

3132 http-types >=0.8.6 && <0.10,

32− jsaddle >=0.9.0.0 && <0.10,

33+ jsaddle >=0.9.2.0 && <0.10,

3334 stm >=2.4.4 && <2.5,

3435 text >=1.2.1.3 && <1.3,

3536 time >=1.5.0.1 && <1.8,

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+95−16

@@ -1,5 +1,7 @@

11{-# LANGUAGE LambdaCase #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecursiveDo #-}

35-----------------------------------------------------------------------------

46--

57-- Module : Language.Javascript.JSaddle.WebSockets

@@ -18,38 +20,50 @@ module Language.Javascript.JSaddle.WebSockets (

1820 , jsaddleApp

1921 , jsaddleWithAppOr

2022 , jsaddleAppPartial

23+ , debug

24+ , debugWrapper

2125) where

2226

23−import Control.Monad (forever)

24−import Control.Concurrent (forkIO, threadDelay)

25−import Control.Exception (handle, AsyncException, throwIO, fromException)

27+import Control.Monad (when, join, void, forever)

28+import Control.Concurrent (killThread, forkIO, threadDelay)

29+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)

2630

2731import Data.Monoid ((<>))

2832import Data.Aeson (encode, decode)

2933

3034import Network.Wai

31− (lazyRequestBody, Application, Request, Response, ResponseReceived)

35+ (Middleware, lazyRequestBody, Application, Request, Response,

36+ ResponseReceived)

3237import Network.WebSockets

33− (ConnectionOptions(..), sendTextData, receiveDataMessage,

34− acceptRequest, ServerApp, sendPing)

38+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,

39+ receiveDataMessage, acceptRequest, ServerApp, sendPing)

3540import qualified Network.WebSockets as WS (DataMessage(..))

3641import Network.Wai.Handler.WebSockets (websocketsOr)

3742

38−import Language.Javascript.JSaddle.Types (JSM(..))

43+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))

3944import qualified Network.Wai as W

4045 (responseLBS, requestMethod, pathInfo)

4146import qualified Data.Text as T (pack)

4247import qualified Network.HTTP.Types as H

4348 (status403, status200)

44−import Language.Javascript.JSaddle.Run (runJavaScript)

49+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)

4550import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)

51+import Language.Javascript.JSaddle.Debug

52+ (removeContext, addContext)

4653import Data.Maybe (fromMaybe)

4754import qualified Data.Map as M (empty, insert, lookup)

48−import Data.IORef (readIORef, newIORef, atomicModifyIORef')

49−import Data.ByteString.Lazy (fromStrict, ByteString)

50−import Data.Text (Text)

55+import Data.IORef

56+ (writeIORef, IORef, readIORef, newIORef, atomicModifyIORef')

57+import Data.ByteString.Lazy (ByteString)

5158import Data.UUID.Types (toText)

52−import Data.UUID.V4 (nextRandom)

59+import Control.Concurrent.MVar

60+ (tryPutMVar, modifyMVar_, putMVar, takeMVar, readMVar, newMVar,

61+ newEmptyMVar, modifyMVar)

62+import Network.Wai.Handler.Warp

63+ (defaultSettings, setTimeout, setPort, runSettings)

64+import Foreign.Store (newStore, readStore, lookupStore)

65+import Language.Javascript.JSaddle (askJSM)

66+import Control.Monad.IO.Class (MonadIO(..))

5367

5468jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

5569jsaddleOr opts entryPoint otherApp = do

@@ -57,7 +71,11 @@ jsaddleOr opts entryPoint otherApp = do

5771 let wsApp :: ServerApp

5872 wsApp pending_conn = do

5973 conn <- acceptRequest pending_conn

60− (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint

74+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do

75+ syncKey <- toText . contextId <$> askJSM

76+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

77+ liftIO $ sendTextData conn (encode syncKey)

78+ entryPoint

6179 _ <- forkIO . forever $

6280 receiveDataMessage conn >>= \case

6381 (WS.Text t) ->

@@ -65,9 +83,6 @@ jsaddleOr opts entryPoint otherApp = do

6583 Nothing -> error $ "jsaddle Results decode failed : " <> show t

6684 Just r -> processResult r

6785 _ -> error "jsaddle WebSocket unexpected binary data"

68− syncKey <- toText <$> nextRandom

69− atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

70− sendTextData conn (encode syncKey)

7186 start

7287 waitTillClosed conn

7388

@@ -141,6 +156,13 @@ jsaddleJs = "\

141156 \ var batch = JSON.parse(e.data);\n\

142157 \ if(typeof batch === \"string\") {\n\

143158 \ syncKey = batch;\n\

159+ \ var xhr = new XMLHttpRequest();\n\

160+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\

161+ \ xhr.onreadystatechange = function() {\n\

162+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\

163+ \ setTimeout(function(){window.location.reload();}, 500);\n\

164+ \ };\n\

165+ \ xhr.send();\n\

144166 \ return;\n\

145167 \ }\n\

146168 \\n\

@@ -164,3 +186,60 @@ jsaddleJs = "\

164186 \connect();\n\

165187 \"

166188

189+-- | Start or restart the server.

190+-- To run this as part of every :reload use

191+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")

192+debug :: Int -> JSM () -> IO ()

193+debug port f = do

194+ debugWrapper $ \refreshMiddleware registerContext ->

195+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

196+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)

197+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"

198+

199+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()

200+debugWrapper run = do

201+ reloadMVar <- newEmptyMVar

202+ reloadDoneMVars <- newMVar []

203+ contexts <- newMVar []

204+ let refreshMiddleware :: Middleware

205+ refreshMiddleware otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of

206+ ("POST", ["reload", _syncKey]) -> do

207+ reloadDone <- newEmptyMVar

208+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))

209+ readMVar reloadMVar

210+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)

211+ putMVar reloadDone ()

212+ return r

213+ _ -> otherApp req sendResponse

214+ start :: Int -> IO (IO Int)

215+ start expectedConnections = do

216+ serverDone <- newEmptyMVar

217+ ready <- newEmptyMVar

218+ let registerContext :: JSM ()

219+ registerContext = do

220+ uuid <- contextId <$> askJSM

221+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))

222+ addContext

223+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()

224+ thread <- forkIO $

225+ finally (run refreshMiddleware registerContext)

226+ (putMVar serverDone ())

227+ forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())

228+ when (expectedConnections /= 0) $ takeMVar ready

229+ return $ do

230+ putMVar reloadMVar ()

231+ ctxs <- takeMVar contexts

232+ mapM_ removeContext ctxs

233+ takeMVar reloadDoneMVars >>= mapM_ takeMVar

234+ killThread thread

235+ takeMVar serverDone

236+ return $ length ctxs

237+ lookupStore shutdown_0 >>= \case

238+ Nothing -> do

239+ shutdownRef <- newIORef =<< start 0

240+ void $ newStore shutdownRef

241+ Just shutdownStore -> do

242+ shutdownRef :: IORef (IO Int) <- readStore shutdownStore

243+ expectedConnections <- join (readIORef shutdownRef)

244+ writeIORef shutdownRef =<< start expectedConnections

245+ where shutdown_0 = 0

jsaddle/default.nix+2−1

@@ -1,7 +1,7 @@

11{ mkDerivation, aeson, attoparsec, base, base64-bytestring

22, bytestring, containers, deepseq, filepath, ghc-prim, http-types

33, lens, primitive, process, ref-tf, scientific, stdenv, stm, text

4−, time, transformers, unordered-containers, vector

4+, time, transformers, unordered-containers, vector, uuid, uuid-types

55}:

66mkDerivation {

77 pname = "jsaddle";

@@ -11,6 +11,7 @@ mkDerivation {

1111 aeson attoparsec base base64-bytestring bytestring containers

1212 deepseq filepath ghc-prim http-types lens primitive process ref-tf

1313 scientific stm text time transformers unordered-containers vector

14+ uuid uuid-types

1415 ];

1516 description = "Interface for JavaScript that works with GHCJS and GHC";

1617 license = stdenv.lib.licenses.mit;

jsaddle/jsaddle.cabal+4−1

@@ -1,5 +1,5 @@

11name: jsaddle

2−version: 0.9.0.0

2+version: 0.9.2.0

33cabal-version: >=1.10

44build-type: Simple

55license: MIT

@@ -47,6 +47,8 @@ library

4747 stm >=2.4.4 && <2.5,

4848 time >=1.5.0.1 && <1.8,

4949 unordered-containers >=0.2 && <0.3,

50+ uuid >=1.3.13 && <1.4,

51+ uuid-types >=1.0.3 && <1.1,

5052 vector >=0.10 && <0.13

5153 exposed-modules:

5254 Data.JSString

@@ -81,6 +83,7 @@ library

8183 JavaScript.Array.Internal

8284 JavaScript.Object

8385 JavaScript.Object.Internal

86+ Language.Javascript.JSaddle.Debug

8487 Language.Javascript.JSaddle.Native

8588 Language.Javascript.JSaddle.Native.Internal

8689 Language.Javascript.JSaddle.Null

jsaddle/src/Language/Javascript/JSaddle/Debug.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+-----------------------------------------------------------------------------

4+--

5+-- Module : Language.Javascript.JSaddle.WebSockets

6+-- Copyright : (c) Hamish Mackenzie

7+-- License : MIT

8+--

9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.Javascript.JSaddle.Debug (

16+ contexts

17+ , addContext

18+ , removeContext

19+ , runOnAll

20+ , runOnAll_

21+) where

22+

23+import Language.Javascript.JSaddle

24+ (runJSM, askJSM, JSM, JSContextRef(..))

25+import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)

26+import System.IO.Unsafe (unsafePerformIO)

27+import Data.Monoid ((<>))

28+import Control.Monad.IO.Class (MonadIO(..))

29+import Data.UUID (UUID)

30+

31+contexts :: IORef [JSContextRef]

32+contexts = unsafePerformIO $ newIORef []

33+{-# NOINLINE contexts #-}

34+

35+addContext :: JSM ()

36+addContext = do

37+ ctx <- askJSM

38+ liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())

39+

40+removeContext :: MonadIO m => UUID -> m ()

41+removeContext uuid =

42+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ())

43+

44+runOnAll :: MonadIO m => JSM a -> m [a]

45+runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)

46+

47+runOnAll_ :: MonadIO m => JSM a -> m ()

48+runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)

jsaddle/src/Language/Javascript/JSaddle/Run.hs+5−4

@@ -40,7 +40,7 @@ import qualified JavaScript.Web.AnimationFrame as GHCJS

4040 (waitForAnimationFrame)

4141#else

4242import Control.Exception (throwIO)

43−import Control.Monad (void, when, forever, zipWithM_)

43+import Control.Monad (void, when, zipWithM_)

4444import Control.Monad.IO.Class (MonadIO(..))

4545import Control.Monad.Trans.Reader (ask, runReaderT)

4646import Control.Monad.STM (atomically)

@@ -58,6 +58,7 @@ import System.Mem.Weak (addFinalizer)

5858import Data.Monoid ((<>))

5959import qualified Data.Text as T (unpack)

6060import qualified Data.Map as M (lookup, delete, insert, empty, size)

61+import Data.UUID.V4 (nextRandom)

6162import Data.Time.Clock (getCurrentTime,diffUTCTime)

6263import Data.IORef (newIORef, atomicWriteIORef, readIORef)

6364

@@ -68,8 +69,6 @@ import Language.Javascript.JSaddle.Exception (JSException(..))

6869-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

6970import Control.DeepSeq (deepseq)

7071import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

71−import Data.Maybe (isJust)

72−import Data.Foldable (forM_)

7372#endif

7473

7574-- | Enable (or disable) JSaddle logging

@@ -151,6 +150,7 @@ sendAsyncCommand cmd = do

151150

152151runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

153152runJavaScript sendBatch entryPoint = do

153+ contextId' <- nextRandom

154154 startTime' <- getCurrentTime

155155 recvMVar <- newEmptyMVar

156156 lastAsyncBatch <- newEmptyMVar

@@ -159,7 +159,8 @@ runJavaScript sendBatch entryPoint = do

159159 nextRef' <- newTVarIO 0

160160 loggingEnabled <- newIORef False

161161 let ctx = JSContextRef {

162− startTime = startTime'

162+ contextId = contextId'

163+ , startTime = startTime'

163164 , doSendCommand = \cmd -> cmd `deepseq` do

164165 result <- newEmptyMVar

165166 atomically $ writeTChan commandChan (Right (cmd, result))

jsaddle/src/Language/Javascript/JSaddle/Types.hs+3−1

@@ -107,6 +107,7 @@ import Control.Monad.Fix (MonadFix)

107107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

108108import Control.Concurrent.STM.TVar (TVar)

109109import Data.Text (Text)

110+import Data.UUID (UUID)

110111import Data.Time.Clock (UTCTime(..))

111112import Data.Typeable (Typeable)

112113import Data.Coerce (coerce, Coercible)

@@ -129,7 +130,8 @@ import GHC.Exts (Constraint)

129130type JSContextRef = ()

130131#else

131132data JSContextRef = JSContextRef {

132− startTime :: UTCTime

133+ contextId :: UUID

134+ , startTime :: UTCTime

133135 , doSendCommand :: Command -> IO Result

134136 , doSendAsyncCommand :: AsyncCommand -> IO ()

135137 , addCallback :: Object -> JSCallAsFunction -> IO ()