0eb4e0c · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Debug features: Warp auto reload and runOnAll

0eb4e0cHamish Mackenzie9 years ago

jsaddle-warp/default.nix+7−6

compare with master

unifiedsplit

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

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

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

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

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

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

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

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

5−, webdriver, websockets

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

6}:

7mkDerivation {

8 pname = "jsaddle-warp";

9 version = "0.9.1.0";

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

11 libraryHaskellDepends = [

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

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

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

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

14+ websockets

14 ];

15 ];

15 testHaskellDepends = [

16 testHaskellDepends = [

16 aeson base bytestring containers deepseq doctest filepath ghc-prim

17 aeson base bytestring containers deepseq doctest filepath ghc-prim

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

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

1name: jsaddle-warp

2−version: 0.9.1.0

2+version: 0.9.2.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

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

28 aeson >=0.8.0.2 && <1.3,

29 bytestring >=0.10.6.0 && <0.11,

30 containers >=0.5.6.2 && <0.6,

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

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

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

32− jsaddle >=0.9.0.0 && <0.10,

33+ jsaddle >=0.9.2.0 && <0.10,

33 stm >=2.4.4 && <2.5,

34 stm >=2.4.4 && <2.5,

34 text >=1.2.1.3 && <1.3,

35 text >=1.2.1.3 && <1.3,

35 time >=1.5.0.1 && <1.8,

36 time >=1.5.0.1 && <1.8,

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

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

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecursiveDo #-}

3-----------------------------------------------------------------------------

5-----------------------------------------------------------------------------

4--

6--

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

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

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

18 , jsaddleApp

20 , jsaddleApp

19 , jsaddleWithAppOr

21 , jsaddleWithAppOr

20 , jsaddleAppPartial

22 , jsaddleAppPartial

23+ , debug

24+ , debugWrapper

21) where

25) where

23−import Control.Monad (forever)

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

24−import Control.Concurrent (forkIO, threadDelay)

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

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

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

27import Data.Monoid ((<>))

31import Data.Monoid ((<>))

28import Data.Aeson (encode, decode)

32import Data.Aeson (encode, decode)

30import Network.Wai

34import Network.Wai

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

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

36+ ResponseReceived)

32import Network.WebSockets

37import Network.WebSockets

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

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

34− acceptRequest, ServerApp, sendPing)

39+ receiveDataMessage, acceptRequest, ServerApp, sendPing)

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

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

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

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

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

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

39import qualified Network.Wai as W

44import qualified Network.Wai as W

40 (responseLBS, requestMethod, pathInfo)

45 (responseLBS, requestMethod, pathInfo)

41import qualified Data.Text as T (pack)

46import qualified Data.Text as T (pack)

42import qualified Network.HTTP.Types as H

47import qualified Network.HTTP.Types as H

43 (status403, status200)

48 (status403, status200)

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

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

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

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

51+import Language.Javascript.JSaddle.Debug

52+ (removeContext, addContext)

46import Data.Maybe (fromMaybe)

53import Data.Maybe (fromMaybe)

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

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

55+import Data.IORef

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

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

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

57+import Data.ByteString.Lazy (ByteString)

50−import Data.Text (Text)

51import Data.UUID.Types (toText)

58import 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(..))

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

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

55jsaddleOr opts entryPoint otherApp = do

69jsaddleOr opts entryPoint otherApp = do

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

57 let wsApp :: ServerApp

71 let wsApp :: ServerApp

58 wsApp pending_conn = do

72 wsApp pending_conn = do

59 conn <- acceptRequest pending_conn

73 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

61 _ <- forkIO . forever $

79 _ <- forkIO . forever $

62 receiveDataMessage conn >>= \case

80 receiveDataMessage conn >>= \case

63 (WS.Text t) ->

81 (WS.Text t) ->

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

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

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

66 Just r -> processResult r

84 Just r -> processResult r

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

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

68− syncKey <- toText <$> nextRandom

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

70− sendTextData conn (encode syncKey)

71 start

86 start

72 waitTillClosed conn

87 waitTillClosed conn

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

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

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

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

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

143 \ syncKey = batch;\n\

158 \ 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\

144 \ return;\n\

166 \ return;\n\

145 \ }\n\

167 \ }\n\

146 \\n\

168 \\n\

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

164 \connect();\n\

186 \connect();\n\

165 \"

187 \"

166

188

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

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

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

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

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

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

5}:

6mkDerivation {

7 pname = "jsaddle";

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

11 aeson attoparsec base base64-bytestring bytestring containers

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

13 scientific stm text time transformers unordered-containers vector

14+ uuid uuid-types

14 ];

15 ];

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

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

16 license = stdenv.lib.licenses.mit;

17 license = stdenv.lib.licenses.mit;

jsaddle/jsaddle.cabal+4−1

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

1name: jsaddle

2−version: 0.9.0.0

2+version: 0.9.2.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

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

47 stm >=2.4.4 && <2.5,

48 time >=1.5.0.1 && <1.8,

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

50+ uuid >=1.3.13 && <1.4,

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

50 vector >=0.10 && <0.13

52 vector >=0.10 && <0.13

51 exposed-modules:

53 exposed-modules:

52 Data.JSString

54 Data.JSString

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

81 JavaScript.Array.Internal

83 JavaScript.Array.Internal

82 JavaScript.Object

84 JavaScript.Object

83 JavaScript.Object.Internal

85 JavaScript.Object.Internal

86+ Language.Javascript.JSaddle.Debug

84 Language.Javascript.JSaddle.Native

87 Language.Javascript.JSaddle.Native

85 Language.Javascript.JSaddle.Native.Internal

88 Language.Javascript.JSaddle.Native.Internal

86 Language.Javascript.JSaddle.Null

89 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

40 (waitForAnimationFrame)

41#else

42import Control.Exception (throwIO)

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

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

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

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

46import Control.Monad.STM (atomically)

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

58import Data.Monoid ((<>))

59import qualified Data.Text as T (unpack)

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

61+import Data.UUID.V4 (nextRandom)

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

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

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

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

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

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

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

69import Control.DeepSeq (deepseq)

70import Control.DeepSeq (deepseq)

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

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

71−import Data.Maybe (isJust)

72−import Data.Foldable (forM_)

73#endif

72#endif

75-- | Enable (or disable) JSaddle logging

74-- | Enable (or disable) JSaddle logging

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

151

150

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

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

153runJavaScript sendBatch entryPoint = do

152runJavaScript sendBatch entryPoint = do

153+ contextId' <- nextRandom

154 startTime' <- getCurrentTime

155 recvMVar <- newEmptyMVar

156 lastAsyncBatch <- newEmptyMVar

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

159 nextRef' <- newTVarIO 0

160 loggingEnabled <- newIORef False

161 let ctx = JSContextRef {

162+ contextId = contextId'

162− startTime = startTime'

163+ , startTime = startTime'

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

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

164 result <- newEmptyMVar

165 result <- newEmptyMVar

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

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

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

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

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

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

109import Data.Text (Text)

110+import Data.UUID (UUID)

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

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

111import Data.Typeable (Typeable)

112import Data.Typeable (Typeable)

112import Data.Coerce (coerce, Coercible)

113import Data.Coerce (coerce, Coercible)

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

129type JSContextRef = ()

130type JSContextRef = ()

130#else

131#else

131data JSContextRef = JSContextRef {

132data JSContextRef = JSContextRef {

133+ contextId :: UUID

132− startTime :: UTCTime

134+ , startTime :: UTCTime

133 , doSendCommand :: Command -> IO Result

135 , doSendCommand :: Command -> IO Result

134 , doSendAsyncCommand :: AsyncCommand -> IO ()

136 , doSendAsyncCommand :: AsyncCommand -> IO ()

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

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