threepenny-gui 0.9.1.0 → 0.9.2.0
raw patch · 12 files changed
+144/−63 lines, 12 filesdep ~basedep ~hashablePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, hashable
API changes (from Hackage documentation)
+ Foreign.JavaScript: data ConfigSSL
+ Graphics.UI.Threepenny.Core: asum :: (Foldable t, Alternative f) => t (f a) -> f a
- Graphics.UI.Threepenny.SVG.Attributes: path :: [Char]
+ Graphics.UI.Threepenny.SVG.Attributes: path :: String
Files
- CHANGELOG.md +10/−1
- README.md +0/−1
- samples/Paths.hs +0/−5
- src/Foreign/JavaScript.hs +6/−2
- src/Foreign/JavaScript/CallBuffer.hs +17/−13
- src/Foreign/JavaScript/EventLoop.hs +11/−7
- src/Foreign/JavaScript/Marshal.hs +6/−3
- src/Foreign/JavaScript/Server.hs +20/−7
- src/Foreign/JavaScript/Types.hs +50/−4
- src/Foreign/RemotePtr.hs +10/−10
- src/Reactive/Threepenny/Types.hs +3/−1
- threepenny-gui.cabal +11/−9
CHANGELOG.md view
@@ -1,9 +1,18 @@ ## Changelog for the `threepenny-gui` package +**0.9.2.0** – Maintenance and snapshot release++* Add support for SSL.++ To start the server as an HTTPS server, use the `jsUseSSL` field with appropriate parameters. For security reasons, no information is read from the environment in this case.++* Bump dependencies for compatibility with GHC-9.4.+* Bump dependencies for compatibility with GHC-9.2.+ **0.9.1.0** – Maintenance and snapshot release * Add support for websockets over SSL.-* Bump dependencies for compatibility with GHC 9.0.+* Bump dependencies for compatibility with GHC-9.0. **0.9.0.0** – Maintenance and snapshot release
README.md view
@@ -1,4 +1,3 @@-[](https://travis-ci.org/HeinrichApfelmus/threepenny-gui) [](https://ci.appveyor.com/project/HeinrichApfelmus/threepenny-gui) [](https://hackage.haskell.org/package/threepenny-gui) [](http://stackage.org/lts/package/threepenny-gui)
samples/Paths.hs view
@@ -11,11 +11,6 @@ getStaticDir :: IO FilePath getStaticDir = (</> "samples/static") `liftM` Paths_threepenny_gui.getDataDir -#elif defined(FPCOMPLETE)--getStaticDir :: IO FilePath-getStaticDir = return "samples/static"- #else -- using GHCi
src/Foreign/JavaScript.hs view
@@ -16,7 +16,9 @@ serve, defaultConfig, Config( jsPort, jsAddr , jsCustomHTML, jsStatic, jsLog- , jsWindowReloadOnDisconnect, jsCallBufferMode),+ , jsWindowReloadOnDisconnect, jsCallBufferMode+ , jsUseSSL),+ ConfigSSL (jsSSLBind, jsSSLCert, jsSSLChainCert, jsSSLKey, jsSSLPort), Server, MimeType, URI, loadFile, loadDirectory, Window, getServer, getCookies, root, @@ -76,7 +78,9 @@ unsafeCreateJSObject w f = do g <- wrapImposeStablePtr w f bufferRunEval w =<< toCode g- marshalResult g w JSON.Null+ marshalResult g w err+ where+ err = error "unsafeCreateJSObject: marshal does not take arguments" -- | Call a JavaScript function and wait for the result. callFunction :: Window -> JSFunction a -> IO a
src/Foreign/JavaScript/CallBuffer.hs view
@@ -12,9 +12,8 @@ ------------------------------------------------------------------------------} -- | Set the call buffering mode for the given browser window. setCallBufferMode :: Window -> CallBufferMode -> IO ()-setCallBufferMode w@Window{..} new = do- flushCallBuffer w- atomically $ writeTVar wCallBufferMode new+setCallBufferMode w new =+ flushCallBufferWithAtomic w $ writeTVar (wCallBufferMode w) new -- | Get the call buffering mode for the given browser window. getCallBufferMode :: Window -> IO CallBufferMode@@ -23,16 +22,21 @@ -- | Flush the call buffer, -- i.e. send all outstanding JavaScript to the client in one single message. flushCallBuffer :: Window -> IO ()-flushCallBuffer w@Window{..} = do- code' <- atomically $ do- code <- readTVar wCallBuffer- writeTVar wCallBuffer id- return code+flushCallBuffer w = flushCallBufferWithAtomic w $ return ()++-- | Flush the call buffer, and atomically perform an additional action+flushCallBufferWithAtomic :: Window -> STM a -> IO a+flushCallBufferWithAtomic w@Window{..} action = do+ -- by taking the call buffer, we ensure that no further code+ -- is added to the buffer while we execute the current buffer's code.+ code' <- atomically $ takeTMVar wCallBuffer let code = code' ""- unless (null code) $- runEval code+ unless (null code) $ runEval code+ atomically $ do+ putTMVar wCallBuffer id+ action --- Schedule a piece of JavaScript code to be run with `runEval`,+-- | Schedule a piece of JavaScript code to be run with `runEval`, -- depending on the buffering mode bufferRunEval :: Window -> String -> IO () bufferRunEval w@Window{..} code = do@@ -42,8 +46,8 @@ NoBuffering -> do return $ Just code _ -> do- msg <- readTVar wCallBuffer- writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))+ msg <- takeTMVar wCallBuffer+ putTMVar wCallBuffer (msg . (\s -> ";" ++ code ++ s)) return Nothing case action of Nothing -> return ()
src/Foreign/JavaScript/EventLoop.hs view
@@ -3,7 +3,7 @@ module Foreign.JavaScript.EventLoop ( eventLoop, runEval, callEval, debug, onDisconnect,- newHandler, fromJSStablePtr,+ newHandler, fromJSStablePtr, newJSObjectFromCoupon ) where import Control.Applicative@@ -186,16 +186,20 @@ -- parseArgs x = Map.elems (fromSuccess (JSON.fromJSON x) :: Map.Map String JSON.Value) --- | Convert a stable pointer from JavaScript into a 'JSObject'.+-- | Retrieve 'JSObject' associated with a JavaScript stable pointer. fromJSStablePtr :: JSON.Value -> Window -> IO JSObject fromJSStablePtr js w@(Window{..}) = do let JSON.Success coupon = JSON.fromJSON js mhs <- Foreign.lookup coupon wJSObjects case mhs of Just hs -> return hs- Nothing -> do- ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects- addFinalizer ptr $- runEval ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')")- return ptr+ Nothing -> newJSObjectFromCoupon w coupon++-- | Create a new JSObject by registering a new coupon.+newJSObjectFromCoupon :: Window -> Foreign.Coupon -> IO JSObject+newJSObjectFromCoupon w@(Window{..}) coupon = do+ ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects+ addFinalizer ptr $+ bufferRunEval w ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')")+ return ptr
src/Foreign/JavaScript/Marshal.hs view
@@ -28,7 +28,7 @@ import qualified Data.Vector as Vector import Safe (atMay) -import Foreign.JavaScript.EventLoop (fromJSStablePtr)+import Foreign.JavaScript.EventLoop (fromJSStablePtr, newJSObjectFromCoupon ) import Foreign.JavaScript.Types import Foreign.RemotePtr @@ -122,14 +122,17 @@ instance FromJS NewJSObject where fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return NewJSObject } +-- | Impose a JS stable pointer upon a newly created JavaScript object.+-- In this way, JSObject can be created without waiting for the browser+-- to return a result. wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)-wrapImposeStablePtr w@(Window{..}) f = do+wrapImposeStablePtr (Window{..}) f = do coupon <- newCoupon wJSObjects rcoupon <- render coupon rcode <- code f return $ JSFunction { code = return $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon]- , marshalResult = \w _ -> newRemotePtr coupon (JSPtr coupon) wJSObjects+ , marshalResult = \w _ -> newJSObjectFromCoupon w coupon } {-----------------------------------------------------------------------------
src/Foreign/JavaScript/Server.hs view
@@ -40,13 +40,10 @@ httpComm :: Config -> EventLoop -> IO () httpComm Config{..} worker = do env <- getEnvironment- let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env- let addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env- - let config = Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))- $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv))- $ Snap.setErrorLog (Snap.ConfigIoLog jsLog)- $ Snap.setAccessLog (Snap.ConfigIoLog jsLog)++ let config = Snap.setErrorLog (Snap.ConfigIoLog jsLog)+ $ Snap.setAccessLog (Snap.ConfigIoLog jsLog)+ $ maybe (configureHTTP env) configureSSL jsUseSSL $ Snap.defaultConfig server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog@@ -54,6 +51,22 @@ Snap.httpServe config . route $ routeResources server jsCustomHTML jsStatic ++ routeWebsockets (worker server)++ where+ configureHTTP :: [(String, String)] -> Snap.Config m a -> Snap.Config m a+ configureHTTP env config =+ let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env+ addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env+ in Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))+ $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv)) config++ configureSSL :: ConfigSSL -> Snap.Config m a -> Snap.Config m a+ configureSSL cfgSsl config =+ Snap.setSSLBind (jsSSLBind cfgSsl)+ . Snap.setSSLPort (jsSSLPort cfgSsl)+ . Snap.setSSLCert (jsSSLCert cfgSsl)+ . Snap.setSSLKey (jsSSLKey cfgSsl)+ $ Snap.setSSLChainCert (jsSSLChainCert cfgSsl) config -- | Route the communication between JavaScript and the server routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes
src/Foreign/JavaScript/Types.hs view
@@ -30,7 +30,7 @@ This is a record type which has the following fields: -* @jsPort :: Maybe Int@ +* @jsPort :: Maybe Int@ Port number. @Nothing@ means that the port number is read from the environment variable @PORT@.@@ -64,19 +64,64 @@ The initial 'CallBufferMode' to use for 'runFunction'. It can be changed at any time with 'setCallBufferMode'. +* @jsUseSSLBind :: Maybe ConfigSSL@++ Whether to serve on a HTTPS connection instead of HTTP for improved security.++ * 'Just' with a 'ConfigSSL' to serve on HTTPS.+ Note that this will fail silently unless the @snap-server@ package+ has been compiled with the @openssl@ flag enabled.++ * 'Nothing' to serve on HTTP.+ (For reasons of forward compatibility, the constructor is not exported.) -} data Config = Config- { jsPort :: Maybe Int + { jsPort :: Maybe Int , jsAddr :: Maybe ByteString , jsCustomHTML :: Maybe FilePath , jsStatic :: Maybe FilePath , jsLog :: ByteString -> IO () , jsWindowReloadOnDisconnect :: Bool , jsCallBufferMode :: CallBufferMode+ , jsUseSSL :: Maybe ConfigSSL } +{- | Static configuration for the SSL version of the "Foreign.JavaScript" server.++This is a record type which has the following fields:++* @jsSSLBind :: ByteString@++ Bind address.++* @jsSSLCert :: FilePath@++ Path to SSL certificate file. Example: @cert.pem@.++* @jsSSLChainCert :: Bool@++ If it is SSL chain certificate file.++* @jsSSLKey :: FilePath@++ Path to SSL key file. Example: @key.pem@.++* @jsSSLPort :: ByteString@++ Port number. Example: 443.++-}++data ConfigSSL = ConfigSSL+ { jsSSLBind :: ByteString+ , jsSSLCert :: FilePath+ , jsSSLChainCert :: Bool+ , jsSSLKey :: FilePath+ , jsSSLPort :: Int+ }+ defaultPort :: Int defaultPort = 8023 @@ -99,6 +144,7 @@ , jsStatic = Nothing , jsLog = BS.hPutStrLn stderr , jsCallBufferMode = FlushOften+ , jsUseSSL = Nothing } {-----------------------------------------------------------------------------@@ -271,7 +317,7 @@ , runEval :: String -> IO () , callEval :: String -> IO JSON.Value - , wCallBuffer :: TVar (String -> String)+ , wCallBuffer :: TMVar (String -> String) , wCallBufferMode :: TVar CallBufferMode , timestamp :: IO ()@@ -289,7 +335,7 @@ newPartialWindow :: IO Window newPartialWindow = do ptr <- newRemotePtr "" () =<< newVendor- b1 <- newTVarIO id+ b1 <- newTMVarIO id b2 <- newTVarIO NoBuffering let nop = const $ return () Window undefined [] nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor
src/Foreign/RemotePtr.hs view
@@ -19,7 +19,7 @@ import Control.Monad import Control.Concurrent import qualified Data.Text as T-import qualified Data.Map as Map+import qualified Data.HashMap.Strict as Map import Data.Functor import Data.IORef @@ -53,7 +53,7 @@ case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif -type Map = Map.Map+type Map = Map.HashMap {----------------------------------------------------------------------------- Types@@ -97,8 +97,8 @@ -- A single 'RemotePtr' will always be associated with the same 'Coupon'. data Vendor a = Vendor- { coupons :: MVar (Map Coupon (Weak (RemotePtr a)))- , counter :: MVar [Integer]+ { coupons :: IORef (Map Coupon (Weak (RemotePtr a)))+ , counter :: IORef Integer } {-----------------------------------------------------------------------------@@ -107,14 +107,14 @@ -- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's. newVendor :: IO (Vendor a) newVendor = do- counter <- newMVar [0..]- coupons <- newMVar Map.empty+ counter <- newIORef 0+ coupons <- newIORef Map.empty return $ Vendor {..} -- | Take a 'Coupon' to a 'Vendor' and maybe you'll get a 'RemotePtr' for it. lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a)) lookup coupon Vendor{..} = do- w <- Map.lookup coupon <$> readMVar coupons+ w <- Map.lookup coupon <$> readIORef coupons maybe (return Nothing) deRefWeak w -- | Create a new 'Coupon'.@@ -124,7 +124,7 @@ -- certainly not on a remote machine. newCoupon :: Vendor a -> IO Coupon newCoupon Vendor{..} =- T.pack . show <$> modifyMVar counter (\(n:ns) -> return (ns,n))+ T.pack . show <$> atomicModifyIORef' counter (\n -> (n+1,n)) -- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'. newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a)@@ -133,9 +133,9 @@ let self = undefined ptr <- newIORef RemoteData{..} - let finalize = modifyMVar coupons $ \m -> return (Map.delete coupon m, ())+ let finalize = atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ()) w <- mkWeakIORef ptr finalize- modifyMVar coupons $ \m -> return (Map.insert coupon w m, ())+ atomicModifyIORef' coupons $ \m -> (Map.insert coupon w m, ()) atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ()) return ptr
src/Reactive/Threepenny/Types.hs view
@@ -20,7 +20,9 @@ , evalP :: EvalP (Maybe a) } -instance Hashable Priority where hashWithSalt _ = fromEnum+instance Hashable Priority where+ hashWithSalt = hashUsing fromEnum+ hash = fromEnum data Latch a = Latch { readL :: EvalL a }
threepenny-gui.cabal view
@@ -1,5 +1,5 @@ Name: threepenny-gui-Version: 0.9.1.0+Version: 0.9.2.0 Synopsis: GUI framework that uses the web browser as a display. Description: Threepenny-GUI is a GUI framework that uses the web browser as a display.@@ -33,8 +33,10 @@ ,GHC == 8.2.2 ,GHC == 8.4.4 ,GHC == 8.6.5- ,GHC == 8.8.3- ,GHC == 8.10.1+ ,GHC == 8.8.4+ ,GHC == 8.10.7+ ,GHC == 9.2.4+ ,GHC == 9.4.1 Extra-Source-Files: CHANGELOG.md ,README.md@@ -109,8 +111,8 @@ if flag(rebug) cpp-options: -DREBUG ghc-options: -O2- build-depends: base >= 4.8 && < 4.16- ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.6)+ build-depends: base >= 4.8 && < 4.19+ ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.2) ,async >= 2.0 && < 2.3 ,bytestring >= 0.9.2 && < 0.12 ,containers >= 0.4.2 && < 0.7@@ -119,19 +121,19 @@ ,exceptions >= 0.6 && < 0.11 ,filepath >= 1.3.0 && < 1.5.0 ,file-embed >= 0.0.10 && < 0.1- ,hashable >= 1.1.0 && < 1.4+ ,hashable >= 1.2.0 && < 1.5 ,safe == 0.3.* ,snap-server >= 0.9.0 && < 1.2 ,snap-core >= 0.9.0 && < 1.1 ,stm >= 2.2 && < 2.6- ,template-haskell >= 2.7.0 && < 2.18- ,text >= 0.11 && < 1.3+ ,template-haskell >= 2.7.0 && < 2.20+ ,text >= 0.11 && < 2.1 ,transformers >= 0.3.0 && < 0.6 ,unordered-containers == 0.2.* ,websockets (>= 0.8 && < 0.12.5) || (> 0.12.5.0 && < 0.13) ,websockets-snap >= 0.8 && < 0.11 ,vault == 0.3.*- ,vector >= 0.10 && < 0.13+ ,vector >= 0.10 && < 0.14 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances default-language: Haskell2010