Skip to content

Commit 04aac2a

Browse files
luiteluite
committed
add non-preemptible threads, fix race condition in GHCJS.Concurrent.synchronously, fix websocket, add bindings for Location object
1 parent bdd8bc3 commit 04aac2a

File tree

6 files changed

+284
-79
lines changed

6 files changed

+284
-79
lines changed

‎GHCJS/Concurrent.hs‎

Lines changed: 36 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ module GHCJS.Concurrent ( isThreadSynchronous
2929
, isThreadContinueAsync
3030
, OnBlocked(..)
3131
, WouldBlockException(..)
32+
, withoutPreemption
3233
, synchronously
3334
) where
3435

@@ -60,25 +61,39 @@ data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocke
6061
deriving (Data, Typeable, Enum, Show, Eq, Ord)
6162

6263
{- |
63-
Runs the action synchronously, which means that the thread will not
64+
Run the action without the scheduler preempting the thread. When a blocking
65+
action is encountered, the thread is still suspended and will continue
66+
without preemption when it's woken up again.
67+
68+
When the thread encounters a black hole from another thread, the scheduler
69+
will attempt to clear it by temporarily switching to that thread.
70+
-}
71+
72+
withoutPreemption :: IO a -> IO a
73+
withoutPreemption x = Ex.mask $ \restore -> do
74+
oldS <- js_setNoPreemption True
75+
if oldS
76+
then restore x
77+
else restore x `Ex.finally` js_setNoPreemption False
78+
{-# INLINE withoutPreemption #-}
79+
80+
81+
{- |
82+
Run the action synchronously, which means that the thread will not
6483
be preempted by the scheduler. If the thread encounters a blocking
65-
operation, the scheduler will switch to other threads. When the thread
66-
is scheduled again, it will still be non-preemptible.
84+
operation, the runtime throws a WouldBlock exception.
6785
6886
When the thread encounters a black hole from another thread, the scheduler
6987
will attempt to clear it by temporarily switching to that thread.
7088
-}
7189
synchronously :: IO a -> IO a
72-
synchronously x = do
90+
synchronously x = Ex.mask $ \restore -> do
7391
oldS <- js_setSynchronous True
7492
if oldS
75-
then x
76-
else x `Ex.finally` js_setSynchronous False
93+
then restore x
94+
else restore x `Ex.finally` js_setSynchronous False
7795
{-# INLINE synchronously #-}
7896

79-
makeAsynchronous :: ThreadId -> IO ()
80-
makeAsynchronous (ThreadId tid) = js_makeAsynchronous tid
81-
8297
{- | Returns whether the 'ThreadId' is a synchronous thread
8398
-}
8499
isThreadSynchronous :: ThreadId -> IO Bool
@@ -91,6 +106,13 @@ isThreadSynchronous = fmap (`testBit` 0) . syncThreadState
91106
isThreadContinueAsync :: ThreadId -> IO Bool
92107
isThreadContinueAsync = fmap (`testBit` 1) . syncThreadState
93108

109+
{- |
110+
Returns whether the 'ThreadId' is not preemptible. Always
111+
returns 'True' when the thread is synchronous.
112+
-}
113+
isThreadNonPreemptible :: ThreadId -> IO Bool
114+
isThreadNonPreemptible = fmap (`testBit` 2) . syncThreadState
115+
94116
syncThreadState :: ThreadId-> IO Int
95117
syncThreadState (ThreadId tid) = js_syncThreadState tid
96118

@@ -99,11 +121,12 @@ syncThreadState (ThreadId tid) = js_syncThreadState tid
99121
foreign import javascript unsafe "h$syncThreadState($1)"
100122
js_syncThreadState :: ThreadId# -> IO Int
101123

124+
foreign import javascript unsafe
125+
"$r = h$currentThread.noPreemption;\
126+
\h$currentThread.noPreemption = $1;"
127+
js_setNoPreemption :: Bool -> IO Bool;
128+
102129
foreign import javascript unsafe
103130
"$r = h$currentThread.isSynchronous;\
104131
\h$currentThread.isSynchronous = $1;"
105132
js_setSynchronous :: Bool -> IO Bool
106-
107-
foreign import javascript unsafe
108-
"$1.isSynchronous = false;"
109-
js_makeAsynchronous :: ThreadId# -> IO ()

‎JavaScript/Web/History.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module JavaScript.Web.History () where
2+
3+
-- todo: implement

‎JavaScript/Web/Location.hs‎

Lines changed: 172 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,172 @@
1+
{-# LANGUAGE ForeignFunctionInterface #-}
2+
{-# LANGUAGE JavaScriptFFI #-}
3+
{-# LANGUAGE DeriveDataTypeable #-}
4+
5+
module JavaScript.Web.Location ( Location
6+
, getWindowLocation
7+
, getHref
8+
, setHref
9+
, getProtocol
10+
, setProtocol
11+
, getHost
12+
, setHost
13+
, getHostname
14+
, setHostname
15+
, getPort
16+
, setPort
17+
, getPathname
18+
, setPathname
19+
, getSearch
20+
, setSearch
21+
, getHash
22+
, setHash
23+
, getUsername
24+
, setUsername
25+
, getPassword
26+
, setPassword
27+
, getOrigin
28+
, assign
29+
, reload
30+
, replace
31+
) where
32+
33+
import Data.Typeable
34+
35+
import Data.JSString (JSString)
36+
import qualified Data.JSString as JSS
37+
38+
import GHCJS.Types
39+
40+
newtype Location = Location JSVal deriving (Typeable)
41+
instance IsJSVal Location
42+
43+
getWindowLocation :: IO Location
44+
getWindowLocation = js_getWindowLocation
45+
{-# INLINE getWindowLocation #-}
46+
47+
getHref :: Location -> IO JSString
48+
getHref = js_getHref
49+
{-# INLINE getHref #-}
50+
51+
setHref :: JSString -> Location -> IO ()
52+
setHref = js_setHref
53+
{-# INLINE setHref #-}
54+
55+
getProtocol :: Location -> IO JSString
56+
getProtocol = js_getProtocol
57+
{-# INLINE getProtocol #-}
58+
59+
setProtocol :: JSString -> Location -> IO ()
60+
setProtocol = js_setProtocol
61+
{-# INLINE setProtocol #-}
62+
63+
getHost :: Location -> IO JSString
64+
getHost = js_getHost
65+
{-# INLINE getHost #-}
66+
67+
setHost :: JSString -> Location -> IO ()
68+
setHost = js_setHost
69+
{-# INLINE setHost #-}
70+
71+
getHostname :: Location -> IO JSString
72+
getHostname = js_getHostname
73+
{-# INLINE getHostname #-}
74+
75+
setHostname :: JSString -> Location -> IO ()
76+
setHostname = js_setHostname
77+
{-# INLINE setHostname #-}
78+
79+
getPort :: Location -> IO JSString
80+
getPort = js_getPort
81+
{-# INLINE getPort #-}
82+
83+
setPort :: JSString -> Location -> IO ()
84+
setPort = js_setPort
85+
{-# INLINE setPort #-}
86+
87+
getPathname :: Location -> IO JSString
88+
getPathname = js_getPathname
89+
{-# INLINE getPathname #-}
90+
91+
setPathname :: JSString -> Location -> IO ()
92+
setPathname = js_setPathname
93+
{-# INLINE setPathname #-}
94+
95+
getSearch :: Location -> IO JSString
96+
getSearch = js_getSearch
97+
{-# INLINE getSearch #-}
98+
99+
setSearch :: JSString -> Location -> IO ()
100+
setSearch = js_setSearch
101+
{-# INLINE setSearch #-}
102+
103+
getHash :: Location -> IO JSString
104+
getHash = js_getHash
105+
{-# INLINE getHash #-}
106+
107+
setHash :: JSString -> Location -> IO ()
108+
setHash = js_setHash
109+
{-# INLINE setHash #-}
110+
111+
getUsername :: Location -> IO JSString
112+
getUsername = js_getUsername
113+
{-# INLINE getUsername #-}
114+
115+
setUsername :: JSString -> Location -> IO ()
116+
setUsername = js_setUsername
117+
{-# INLINE setUsername #-}
118+
119+
getPassword :: Location -> IO JSString
120+
getPassword = js_getPassword
121+
{-# INLINE getPassword #-}
122+
123+
setPassword :: JSString -> Location -> IO ()
124+
setPassword = js_setPassword
125+
{-# INLINE setPassword #-}
126+
127+
getOrigin :: Location -> IO JSString
128+
getOrigin = js_getUsername
129+
{-# INLINE getOrigin #-}
130+
131+
assign :: JSString -> Location -> IO ()
132+
assign = js_assign
133+
{-# INLINE assign #-}
134+
135+
reload :: Bool -> Location -> IO ()
136+
reload = js_reload
137+
{-# INLINE reload #-}
138+
139+
replace :: JSString -> Location -> IO ()
140+
replace = js_assign
141+
{-# INLINE replace #-}
142+
143+
-------------------------------------------------------------------------------
144+
145+
foreign import javascript safe "window.location" js_getWindowLocation :: IO Location
146+
147+
foreign import javascript unsafe "$1.href" js_getHref :: Location -> IO JSString
148+
foreign import javascript unsafe "$1.protocol" js_getProtocol :: Location -> IO JSString
149+
foreign import javascript unsafe "$1.host" js_getHost :: Location -> IO JSString
150+
foreign import javascript unsafe "$1.hostname" js_getHostname :: Location -> IO JSString
151+
foreign import javascript unsafe "$1.port" js_getPort :: Location -> IO JSString
152+
foreign import javascript unsafe "$1.pathname" js_getPathname :: Location -> IO JSString
153+
foreign import javascript unsafe "$1.search" js_getSearch :: Location -> IO JSString
154+
foreign import javascript unsafe "$1.hash" js_getHash :: Location -> IO JSString
155+
foreign import javascript unsafe "$1.username" js_getUsername :: Location -> IO JSString
156+
foreign import javascript unsafe "$1.password" js_getPassword :: Location -> IO JSString
157+
foreign import javascript unsafe "$1.origin" js_getOrigin :: Location -> IO JSString
158+
159+
foreign import javascript safe "$2.href = $1;" js_setHref :: JSString -> Location -> IO ()
160+
foreign import javascript safe "$2.protocol = $1;" js_setProtocol :: JSString -> Location -> IO ()
161+
foreign import javascript safe "$2.host = $1;" js_setHost :: JSString -> Location -> IO ()
162+
foreign import javascript safe "$2.hostname = $1;" js_setHostname :: JSString -> Location -> IO ()
163+
foreign import javascript safe "$2.port = $1;" js_setPort :: JSString -> Location -> IO ()
164+
foreign import javascript safe "$2.pathname = $1;" js_setPathname :: JSString -> Location -> IO ()
165+
foreign import javascript safe "$2.search = $1;" js_setSearch :: JSString -> Location -> IO ()
166+
foreign import javascript safe "$2.hash = $1;" js_setHash :: JSString -> Location -> IO ()
167+
foreign import javascript safe "$2.username = $1;" js_setUsername :: JSString -> Location -> IO ()
168+
foreign import javascript safe "$2.password = $1;" js_setPassword :: JSString -> Location -> IO ()
169+
170+
foreign import javascript safe "$2.assign($1);" js_assign :: JSString -> Location -> IO ()
171+
foreign import javascript safe "$2.reload($1);" js_reload :: Bool -> Location -> IO ()
172+
foreign import javascript safe "$2.replace($1);" js_replace :: JSString -> Location -> IO ()

‎JavaScript/Web/WebSocket.hs‎

Lines changed: 28 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,9 @@ module JavaScript.Web.WebSocket ( WebSocket
1515
, connect
1616
, close
1717
, send
18-
, getBufferedAmount
18+
, sendArrayBuffer
19+
, sendBlob
20+
, getBufferedAmount
1921
, getExtensions
2022
, getProtocol
2123
, getReadyState
@@ -44,6 +46,8 @@ import qualified Data.JSString as JSS
4446

4547
import JavaScript.Array (JSArray)
4648
import qualified JavaScript.Array as JSA
49+
import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer)
50+
import JavaScript.Web.Blob (Blob)
4751
import JavaScript.Web.MessageEvent
4852
import JavaScript.Web.MessageEvent.Internal
4953
import JavaScript.Web.CloseEvent
@@ -74,29 +78,23 @@ connect :: WebSocketRequest -> IO WebSocket
7478
connect req = do
7579
mcb <- maybeCallback MessageEvent (onMessage req)
7680
ccb <- maybeCallback CloseEvent (onClose req)
77-
synchronously $ do
81+
withoutPreemption $ do
7882
ws <- case protocols req of
79-
[] -> js_createStr (url req) JSS.empty
80-
[x] -> js_createStr (url req) x
81-
xs -> js_createArr (url req) (JSA.fromList $ unsafeCoerce xs) -- fixme
83+
[] -> js_createDefault (url req)
84+
[x] -> js_createStr (url req) x
8285
(js_open ws mcb ccb >>= handleOpenErr >> return ws) `onException` js_close 1000 "Haskell Exception" ws
8386

8487
maybeCallback :: (JSVal -> a) -> Maybe (a -> IO ()) -> IO JSVal
8588
maybeCallback _ Nothing = return jsNull
8689
maybeCallback f (Just g) = do
87-
cb@(Callback cb') <- CB.syncCallback1 CB.ContinueAsync (g . f)
88-
CB.releaseCallback cb
89-
return cb'
90+
Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f)
91+
return cb
9092

9193
handleOpenErr :: JSVal -> IO ()
9294
handleOpenErr r
9395
| isNull r = return ()
9496
| otherwise = throwIO (userError "WebSocket failed to connect") -- fixme
9597

96-
releaseMessageCallback :: WebSocket -> IO ()
97-
releaseMessageCallback ws = js_getOnmessage ws >>=
98-
\cb -> unless (isNull cb) (CB.releaseCallback $ Callback cb)
99-
10098
{- | close a websocket and release the callbacks -}
10199
close :: Maybe Int -> Maybe JSString -> WebSocket -> IO ()
102100
close value reason ws =
@@ -107,6 +105,14 @@ send :: JSString -> WebSocket -> IO ()
107105
send xs ws = js_send xs ws
108106
{-# INLINE send #-}
109107

108+
sendBlob :: Blob -> WebSocket -> IO ()
109+
sendBlob = js_sendBlob
110+
{-# INLINE sendBlob #-}
111+
112+
sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()
113+
sendArrayBuffer = js_sendArrayBuffer
114+
{-# INLINE sendArrayBuffer #-}
115+
110116
getBufferedAmount :: WebSocket -> IO Int
111117
getBufferedAmount ws = js_getBufferedAmount ws
112118
{-# INLINE getBufferedAmount #-}
@@ -139,19 +145,25 @@ getLastError ws = do
139145

140146
-- -----------------------------------------------------------------------------
141147

142-
148+
foreign import javascript safe
149+
"new WebSocket($1)" js_createDefault :: JSString -> IO WebSocket
143150
foreign import javascript safe
144151
"new WebSocket($1, $2)" js_createStr :: JSString -> JSString -> IO WebSocket
145152
foreign import javascript safe
146153
"new WebSocket($1, $2)" js_createArr :: JSString -> JSArray -> IO WebSocket
147-
154+
148155
foreign import javascript interruptible
149156
"h$openWebSocket($1, $2, $3, $c);"
150-
js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal
157+
js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal
151158
foreign import javascript safe
152-
"h$closeWebSocket($1, $2);" js_close :: Int -> JSString -> WebSocket -> IO ()
159+
"h$closeWebSocket($1, $2, $3);"
160+
js_close :: Int -> JSString -> WebSocket -> IO ()
153161
foreign import javascript unsafe
154162
"$2.send($1);" js_send :: JSString -> WebSocket -> IO ()
163+
foreign import javascript unsafe
164+
"$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO ()
165+
foreign import javascript unsafe
166+
"$2.send($1);" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO ()
155167
foreign import javascript unsafe
156168
"$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int
157169
foreign import javascript unsafe
@@ -165,16 +177,5 @@ foreign import javascript unsafe
165177
foreign import javascript unsafe
166178
"$1.binaryType === 'blob' ? 1 : 2"
167179
js_getBinaryType :: WebSocket -> IO Int
168-
169-
foreign import javascript unsafe
170-
"$2.onopen = $1;" js_setOnopen :: Callback a -> WebSocket -> IO ()
171-
foreign import javascript unsafe
172-
"$2.onclose = $1;" js_setOnclose :: Callback a -> WebSocket -> IO ()
173-
foreign import javascript unsafe
174-
"$2.onopen = $1;" js_setOnerror :: Callback a -> WebSocket -> IO ()
175-
foreign import javascript unsafe
176-
"$2.onmessage = $1;" js_setOnmessage :: Callback a -> WebSocket -> IO ()
177-
foreign import javascript unsafe
178-
"$1.onmessage" js_getOnmessage :: WebSocket -> IO JSVal
179180
foreign import javascript unsafe
180181
"$1.lastError" js_getLastError :: WebSocket -> IO JSVal

‎ghcjs-base.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ library
2020
jsbits/text.js
2121
jsbits/utils.js
2222
jsbits/xhr.js
23+
jsbits/websocket.js
2324
other-extensions: DeriveDataTypeable
2425
DeriveGeneric
2526
ForeignFunctionInterface
@@ -106,6 +107,8 @@ library
106107
JavaScript.Web.ErrorEvent
107108
JavaScript.Web.ErrorEvent.Internal
108109
JavaScript.Web.File
110+
JavaScript.Web.History
111+
JavaScript.Web.Location
109112
JavaScript.Web.MessageEvent
110113
JavaScript.Web.MessageEvent.Internal
111114
JavaScript.Web.Performance

0 commit comments

Comments
 (0)