Add getCookies to retrieve cookies sent with the HTTP request. #137

We can always get the cookies by calling JavaScript functions,
but this would require a roundtrip, and does not work for all
cookies (HTTP only, secure).

CHANGELOG.md

@@ -1,5 +1,9 @@
 ## Changelog for the `threepenny-gui` package
 
+**0.8.2.0** — Snapshot release
+
+* Add `getCookies` function that retrieves the cookies sent with the HTTP request when the browser window connects (to the websocket).
+
 **0.8.1.0** — Snapshot release
 
 * Improve documentation and handling of call buffering (`CallBufferMode`). The default call buffer mode was documented incorrectly, it was  `BufferRun` and is now `FlushOften`. [#163][], [#191][], [#192][]

src/Foreign/JavaScript.hs

@@ -18,7 +18,7 @@ module Foreign.JavaScript (
         , jsCustomHTML, jsStatic, jsLog
         , jsWindowReloadOnDisconnect, jsCallBufferMode),
     Server, MimeType, URI, loadFile, loadDirectory,
-    Window, getServer, root,
+    Window, getServer, getCookies, root,
 
     -- * JavaScript FFI
     ToJS(..), FromJS, JSFunction, JSObject, JavaScriptException,

src/Foreign/JavaScript/EventLoop.hs

@@ -46,8 +46,8 @@ type Result = Either String JSON.Value
 
 -- | Event loop for a browser window.
 -- Supports concurrent invocations of `runEval` and `callEval`.
-eventLoop :: (Window -> IO void) -> (Server -> Comm -> IO ())
-eventLoop init server comm = void $ do
+eventLoop :: (Window -> IO void) -> EventLoop
+eventLoop init server info comm = void $ do
     -- To support concurrent FFI calls, we need three threads.
     -- A fourth thread supports 
     --
@@ -91,6 +91,7 @@ eventLoop init server comm = void $ do
 
     w0 <- newPartialWindow
     let w = w0 { getServer    = server
+               , getCookies   = info
                , runEval      = run  . RunEval
                , callEval     = call . CallEval
                , debug        = debug

src/Foreign/JavaScript/Server.hs

@@ -25,7 +25,7 @@ import           Data.Aeson                             ((.=))
 import qualified Data.Aeson                    as JSON
 import qualified Network.WebSockets            as WS
 import qualified Network.WebSockets.Snap       as WS
-import           Snap.Core
+import           Snap.Core                     as Snap
 import qualified Snap.Http.Server              as Snap
 import           Snap.Util.FileServe
 
@@ -37,7 +37,7 @@ import Foreign.JavaScript.Types
     HTTP Server using WebSockets
 ------------------------------------------------------------------------------}
 -- | Run a HTTP server that creates a 'Comm' channel.
-httpComm :: Config -> (Server -> Comm -> IO ()) -> IO ()
+httpComm :: Config -> EventLoop -> IO ()
 httpComm Config{..} worker = do
     env <- getEnvironment
     let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env
@@ -56,13 +56,15 @@ httpComm Config{..} worker = do
         ++ routeWebsockets (worker server)
 
 -- | Route the communication between JavaScript and the server
-routeWebsockets :: (Comm -> IO void) -> Routes
+routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes
 routeWebsockets worker = [("websocket", response)]
     where
-    response = WS.runWebSocketsSnap $ \ws -> void $ do
-        comm <- communicationFromWebSocket ws
-        worker comm
-        -- error "Foreign.JavaScript: unreachable code path."
+    response = do
+        requestInfo <- Snap.getRequest
+        WS.runWebSocketsSnap $ \ws -> void $ do
+            comm <- communicationFromWebSocket ws
+            worker (rqCookies requestInfo) comm
+            -- error "Foreign.JavaScript: unreachable code path."
 
 -- | Create 'Comm' channel from WebSocket request.
 communicationFromWebSocket :: WS.PendingConnection -> IO Comm

src/Foreign/JavaScript/Types.hs

@@ -15,6 +15,7 @@ import           Data.Map                as Map
 import           Data.String
 import           Data.Text
 import           Data.Typeable
+import           Snap.Core                       (Cookie(..))
 import           System.IO                       (stderr)
 
 import Foreign.RemotePtr
@@ -256,10 +257,17 @@ data CallBufferMode
 
 flushPeriod = 300 :: Int
 
+-- | Action that the server will run when a browser window connects.
+type EventLoop   = Server -> RequestInfo -> Comm -> IO ()
+type RequestInfo = [Cookie]
+
 -- | Representation of a browser window.
 data Window = Window
     { getServer      :: Server
-    -- ^ Server that tbe browser window communicates with.
+    -- ^ Server that the browser window communicates with.
+    , getCookies     :: [Cookie]
+    -- ^ Cookies that the browser window has sent to the server when connecting.
+
     , runEval        :: String -> IO ()
     , callEval       :: String -> IO JSON.Value
 
@@ -284,7 +292,7 @@ newPartialWindow = do
     b1  <- newTVarIO id
     b2  <- newTVarIO NoBuffering
     let nop = const $ return ()
-    Window undefined nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor
+    Window undefined [] nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor
 
 -- | For the purpose of controlling garbage collection,
 -- every 'Window' as an associated 'RemotePtr' that is alive

threepenny-gui.cabal

@@ -1,5 +1,5 @@
 Name:                threepenny-gui
-Version:             0.8.1.0
+Version:             0.8.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.