Core.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings, PackageImports #-}
{-# OPTIONS -fno-warn-name-shadowing #-}

module Graphics.UI.Threepenny.Internal.Core
  (
  -- * Synopsis
  -- | The main internal functionality.
      
  -- * Server running
   serve
  ,loadFile
  ,loadDirectory
  
  -- * Event handling
  -- $eventhandling
  ,bind
  ,disconnect
  ,module Reactive.Threepenny
  
  -- * Setting attributes
  -- $settingattributes
  ,setStyle
  ,setAttr
  ,setProp
  ,setText
  ,setHtml
  ,setTitle
  ,emptyEl
  ,delete
  
  -- * Manipulating tree structure
  -- $treestructure
  ,newElement
  ,appendElementTo
  
  -- * Querying
  -- $querying
  ,getHead
  ,getBody
  ,getElementsByTagName
  ,getElementsById
  ,getElementsByClassName
  ,getWindow
  ,getProp
  ,getValue
  ,getValuesList
  ,readValue
  ,readValuesList
  ,getRequestCookies
  ,getRequestLocation
  
  -- * Utilities
  ,debug
  ,clear
  ,callDeferredFunction
  ,atomic

  -- * JavaScript FFI
  ,ToJS, FFI, ffi, JSFunction
  ,runFunction, callFunction
  
  -- * Types
  ,Window
  ,Element
  ,Config(..)
  ,EventData(..)
  ) where



import           Graphics.UI.Threepenny.Internal.Types     as Threepenny
import           Graphics.UI.Threepenny.Internal.Resources

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.Chan.Extra
import           Control.Concurrent.Delay
import qualified Control.Exception
import           Reactive.Threepenny
import           Control.Monad
import           Control.Monad.IO.Class
import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as E
import           Data.ByteString               (ByteString)
import           Data.ByteString.UTF8          (toString,fromString)
import           Data.Map                      (Map)
import qualified Data.Map                      as M
import           Data.Maybe
import           Data.Text                     (Text,pack,unpack)
import qualified Data.Text                     as Text
import           Data.Text.Encoding
import           Data.Time
import           Network.URI
import qualified Network.WebSockets            as WS
import qualified Network.WebSockets.Snap       as WS
import qualified Data.Attoparsec.Enumerator    as Atto
import           Prelude                       hiding (init)
import           Safe
import           Snap.Core
import qualified Snap.Http.Server              as Snap
import           Snap.Util.FileServe
import           System.FilePath
import qualified Text.JSON as JSON
import           Text.JSON.Generic


{-----------------------------------------------------------------------------
    Server and and session management
------------------------------------------------------------------------------}
newServerState :: IO ServerState
newServerState = ServerState 
    <$> newMVar M.empty
    <*> newMVar (0,M.empty)
    <*> newMVar (0,M.empty)

-- | Run a TP server with Snap on the specified port and the given
--   worker action.
serve :: Config -> (Session -> IO ()) -> IO ()
serve Config{..} worker = do
    server <- newServerState
    _      <- forkIO $ custodian 30 (sSessions server)
    let config = Snap.setPort tpPort
               $ Snap.setErrorLog (Snap.ConfigIoLog tpLog)
               $ Snap.setAccessLog (Snap.ConfigIoLog tpLog)
               $ Snap.defaultConfig
    Snap.httpServe config . route $
        routeResources tpCustomHTML tpStatic server
        -- ++ routeCommunication worker server
        ++ routeWebsockets worker server

-- | Kill sessions after at least n seconds of disconnectedness.
custodian :: Integer -> MVar Sessions -> IO ()
custodian seconds sessions = forever $ do
  delaySeconds seconds
  modifyMVar_ sessions $ \sessions -> do
    killed <- fmap catMaybes $ forM (M.assocs sessions) $ \(key,Session{..}) -> do
      state <- readMVar sConnectedState
      case state of
        Connected -> return Nothing
        Disconnected time -> do
          now <- getCurrentTime
          let dcSeconds = diffUTCTime now time
          -- session is disconnected for more than  seconds
          if (dcSeconds > fromIntegral seconds)
             then do killThread sThreadId
                     return (Just key)
             else return Nothing
    
    -- remove killed sessions from the map
    return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)

-- Run a snap action with the given session.
withSession :: ServerState -> (Session -> Snap a) -> Snap a
withSession server cont = do
    token <- readInput "token"
    case token of
        Nothing    -> error $ "Invalid session token format."
        Just token -> withGivenSession token server cont

-- Do something with the session given by its token id.
withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
withGivenSession token ServerState{..} cont = do
    sessions <- liftIO $ withMVar sSessions return
    case M.lookup token sessions of
        Nothing      -> error $ "Nonexistant token: " ++ show token
        Just session -> cont session

{-----------------------------------------------------------------------------
    Implementation of two-way communication
    - POST and GET requests
------------------------------------------------------------------------------}
-- | Route the communication between JavaScript and the server
routeCommunication :: (Session -> IO a) -> ServerState -> Routes
routeCommunication worker server =
    [("/init"   , init worker server)
    ,("/poll"   , withSession server poll  )
    ,("/signal" , withSession server signal)
    ]

-- | Make a new session.
newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
newSession sServerState sStartInfo sToken = do
    sSignals          <- newChan
    sInstructions     <- newChan
    sMutex            <- newMVar ()
    sEventHandlers    <- newMVar M.empty
    sElementEvents    <- newMVar M.empty
    sEventQuit        <- newEvent
    sElementIds       <- newMVar [0..]
    now               <- getCurrentTime
    sConnectedState   <- newMVar (Disconnected now)
    sThreadId         <- myThreadId
    sClosures         <- newMVar [0..]
    let session = Session {..}
    initializeElementEvents session    
    return session

-- | Make a new session and add it to the server
createSession :: (Session -> IO void) -> ServerState -> Snap Session
createSession worker server = do
    -- uri    <- snapRequestURI
    let uri = undefined -- FIXME: No URI for WebSocket requests.
    params <- snapRequestCookies
    liftIO $ modifyMVar (sSessions server) $ \sessions -> do
        let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
        session <- newSession server (uri,params) newKey
        _       <- forkIO $ void $ worker session >> handleEvents session
        return (M.insert newKey session sessions, session)

-- | Respond to initialization request.
init :: (Session -> IO void) -> ServerState -> Snap ()
init worker server = do
    session <- createSession worker server
    modifyResponse . setHeader "Set-Token" . fromString . show . sToken $ session
    poll session

snapRequestURI :: Snap URI
snapRequestURI = do
    uri     <- getInput "info"
    maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)

snapRequestCookies :: Snap [(String, String)]
snapRequestCookies = do
    cookies <- getsRequest rqCookies
    return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)


-- | Respond to poll requests.
poll :: Session -> Snap ()
poll Session{..} = do
    let setDisconnected = do
        now <- getCurrentTime
        modifyMVar_ sConnectedState (const (return (Disconnected now)))
    
    instructions <- liftIO $ do
        modifyMVar_ sConnectedState (const (return Connected))
        threadId <- myThreadId
        forkIO $ do
            delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
            killThread threadId
        E.catch (readAvailableChan sInstructions) $ \e -> do
            -- no instructions available after some time
            when (e == Control.Exception.ThreadKilled) $ setDisconnected
            E.throw e
    
    writeJson instructions

-- | Handle signals sent from the client.
signal :: Session -> Snap ()
signal Session{..} = do
    input <- getInput "signal"
    case input of
      Just signalJson -> do
        let signal = JSON.decode signalJson
        case signal of
          Ok signal -> liftIO $ writeChan sSignals signal
          Error err -> error err
      Nothing -> error $ "Unable to parse " ++ show input

{-----------------------------------------------------------------------------
    Implementation of two-way communication
    - WebSockets
------------------------------------------------------------------------------}
-- | Route the communication between JavaScript and the server
routeWebsockets :: (Session -> IO a) -> ServerState -> Routes
routeWebsockets worker server =
    [("websocket", response)]
    where
    response = do
        session <- createSession worker server
        WS.runWebSocketsSnap (webSocket session)
        error "Threepenny.Internal.Core: runWebSocketsSnap should never return."


webSocket :: Session -> WS.Request -> WS.WebSockets WS.Hybi00 ()
webSocket Session{..} req = void $ do
    WS.acceptRequest req
    -- websockets are always connected, don't let the custodian kill you.
    liftIO $ modifyMVar_ sConnectedState (const (return Connected))

    -- write data (in another thread)
    send     <- WS.getSink
    sendData <- liftIO . forkIO . forever $ do
        x <- readChan sInstructions
        WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x

    -- read data
    let readData = do
            input <- WS.receiveData
            case input of
                "ping" -> liftIO . WS.sendSink send . WS.textData . Text.pack $ "pong"
                "quit" -> WS.throwWsError WS.ConnectionClosed
                input  -> case JSON.decode . Text.unpack $ input of
                    Ok signal -> liftIO $ writeChan sSignals signal
                    Error err -> WS.throwWsError . WS.ParseError $ Atto.ParseError [] err
    
    forever readData `WS.catchWsError`
        \_ -> liftIO $ do
            killThread sendData             -- kill sending thread when done
            writeChan sSignals $ Quit ()    -- signal  Quit  event

{-----------------------------------------------------------------------------
    FFI implementation on top of the communication channel
------------------------------------------------------------------------------}
-- | Atomically execute the given computation in the context of a browser window
atomic :: Window -> IO a -> IO a
atomic window@(Session{..}) m = do
  takeMVar sMutex
  ret <- m
  putMVar sMutex ()
  return ret

-- | Send an instruction and read the signal response.
call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
call session@(Session{..}) instruction withSignal = do
  takeMVar sMutex
  run session $ instruction
  newChan <- dupChan sSignals
  go sMutex newChan

  where
    go mutex newChan = do
      signal <- readChan newChan
      result <- withSignal signal
      case result of
        Just signal -> do putMVar mutex ()
                          return signal
        Nothing     -> go mutex newChan
            -- keep reading signals from the duplicated channel
            -- until the function above succeeds

-- Run the given instruction wihtout waiting for a response.
run :: Session -> Instruction -> IO ()
run (Session{..}) i = writeChan sInstructions i

-- | Call the given function with the given continuation. Doesn't block.
callDeferredFunction
  :: Window                    -- ^ Browser window
  -> String                    -- ^ The function name.
  -> [String]                  -- ^ Parameters.
  -> ([Maybe String] -> IO ()) -- ^ The continuation to call if/when the function completes.
  -> IO ()
callDeferredFunction session@(Session{..}) func params closure = do
  cid      <- modifyMVar sClosures (\(x:xs) -> return (xs,x))
  closure' <- newClosure session func (show cid) closure
  run session $ CallDeferredFunction (closure',func,params)

-- | Run the given JavaScript function and carry on. Doesn't block.
--
-- The client window uses JavaScript's @eval()@ function to run the code.
runFunction :: Window -> JSFunction () -> IO ()
runFunction session = run session . RunJSFunction . unJSCode . code

-- | Run the given JavaScript function and wait for results. Blocks.
--
-- The client window uses JavaScript's @eval()@ function to run the code.
callFunction :: Window -> JSFunction a -> IO a
callFunction window (JSFunction code marshal) = 
    call window (CallJSFunction . unJSCode $ code) $ \signal ->
        case signal of
            FunctionResult v -> case marshal window v of
                Ok    a -> return $ Just a
                Error _ -> return Nothing
            _ -> return Nothing


{-----------------------------------------------------------------------------
    Snap utilities
------------------------------------------------------------------------------}
-- Write JSON to output.
writeJson :: (MonadSnap m, JSON a) => a -> m ()
writeJson json = do
    modifyResponse $ setContentType "application/json"
    (writeText . pack . (\x -> showJSValue x "") . showJSON) json

-- Get a text input from snap.
getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
getInput = fmap (fmap (unpack . decodeUtf8)) . getParam

-- Read an input from snap.
readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
readInput = fmap (>>= readMay) . getInput

{-----------------------------------------------------------------------------
    Resourcse
------------------------------------------------------------------------------}
type Routes = [(ByteString, Snap ())]

routeResources :: Maybe FilePath -> Maybe FilePath -> ServerState -> Routes
routeResources customHTML staticDir server =
    fixHandlers noCache $
        static ++
        [("/"                          , root)
        ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
        ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
        ,("/file/:name"                ,
            withFilepath (sFiles server) (flip serveFileAs))
        ,("/dir/:name"                 ,
            withFilepath (sDirs  server) (\path _ -> serveDirectory path))
        ]
    where
    fixHandlers f routes = [(a,f b) | (a,b) <- routes]
    noCache h = modifyResponse (setHeader "Cache-Control" "no-cache") >> h
    
    static = maybe [] (\dir -> [("/static", serveDirectory dir)]) staticDir
    
    root = case customHTML of
        Just file -> case staticDir of
            Just dir -> serveFile (dir </> file)
            Nothing  -> logError "Graphics.UI.Threepenny: Cannot use tpCustomHTML file without tpStatic"
        Nothing   -> writeText defaultHtmlFile


-- Get a filename from a URI
withFilepath :: MVar Filepaths -> (FilePath -> MimeType -> Snap a) -> Snap a
withFilepath rDict cont = do
    mName    <- getParam "name"
    (_,dict) <- liftIO $ withMVar rDict return
    case (\key -> M.lookup key dict) =<< mName of
        Just (path,mimetype) -> cont path mimetype
        Nothing              -> error $ "File not loaded: " ++ show mName

-- FIXME: Serving large files fails with the exception
-- System.SendFile.Darwin: invalid argument (Socket is not connected)


newAssociation :: MVar Filepaths -> (FilePath, MimeType) -> IO String
newAssociation rDict (path,mimetype) = do
    (old, dict) <- takeMVar rDict
    let new = old + 1; key = show new ++ takeFileName path
    putMVar rDict $ (new, M.insert (fromString key) (path,mimetype) dict)
    return key

-- | Begin to serve a local file under an URI.
loadFile :: Session -> MimeType -> FilePath -> IO String
loadFile Session{..} mimetype path = do
    key <- newAssociation (sFiles sServerState) (path,mimetype)
    return $ "/file/" ++ key

-- | Begin to serve a local directory under an URI.
loadDirectory :: Session -> FilePath -> IO String
loadDirectory Session{..} path = do
    key <- newAssociation (sDirs sServerState) (path,"")
    return $ "/dir/" ++ key


{-----------------------------------------------------------------------------
    Event handling
------------------------------------------------------------------------------}
{- $eventhandling

    To bind events to elements, use the 'bind' function.

    To handle DOM events, use the 'handleEvent' function, or the
    'handleEvents' function which will block forever.

    See the rest of this section for some helpful functions that do
    common binding, such as clicks, hovers, etc.
-}

-- | Handle events signalled from the client.
handleEvents :: Window -> IO ()
handleEvents window@(Session{..}) = do
    signal <- getSignal window
    case signal of
        Threepenny.Event (elid,eventType,params) -> do
            handleEvent1 window ((elid,eventType),EventData params)
            handleEvents window
        Quit () -> do
            snd sEventQuit ()
            -- do not continue handling events
        _       -> do
            handleEvents window

-- | Add a new event handler for a given key
addEventHandler :: Window -> (EventKey, Handler EventData) -> IO () 
addEventHandler Session{..} (key,handler) =
    modifyMVar_ sEventHandlers $ return .
        M.insertWith (\h1 h a -> h1 a >> h a) key handler        


-- | Handle a single event
handleEvent1 :: Window -> (EventKey,EventData) -> IO ()
handleEvent1 Session{..} (key,params) = do
    handlers <- readMVar sEventHandlers
    case M.lookup key handlers of
        Just handler -> handler params
        Nothing      -> return ()

-- Get the latest signal sent from the client.
getSignal :: Window -> IO Signal
getSignal (Session{..}) = readChan sSignals

-- | Bind an event handler for a dom event to an 'Element'.
bind
    :: String               -- ^ The eventType, see any DOM documentation for a list of these.
    -> Element              -- ^ The element to bind to.
    -> Handler EventData    -- ^ The event handler to bind.
    -> IO ()
bind eventType (Element el@(ElementId elid) session) handler = do
    let key = (elid, eventType)
    -- register with client if it has never been registered on the server
    handlers <- readMVar $ sEventHandlers session
    when (not $ key `M.member` handlers) $
        run session $ Bind eventType el (Closure key)
    -- register with server
    addEventHandler session (key, handler)

-- | Register event handler that occurs when the client has disconnected.
disconnect :: Window -> Event ()
disconnect = fst . sEventQuit


initializeElementEvents :: Window -> IO ()
initializeElementEvents session@(Session{..}) = do
        initEvents =<< getHead session
        initEvents =<< getBody session
    where
    initEvents el@(Element elid _) = do
        x <- newEventsNamed $ \(name,_,handler) -> bind name el handler
        modifyMVar_ sElementEvents $ return . M.insert elid x

-- Make a uniquely numbered event handler.
newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
newClosure window eventType elid thunk = do
    let key = (elid, eventType)
    addEventHandler window (key, \(EventData xs) -> thunk xs)
    return (Closure key)

{-----------------------------------------------------------------------------
    Setting attributes
------------------------------------------------------------------------------}
{- $settingattributes
 
    Text, HTML and attributes of DOM nodes can be set using the
    functions in this section. 
-}

-- | Set the style of the given element.
setStyle :: [(String, String)] -- ^ Pairs of CSS (property,value).
         -> Element            -- ^ The element to update.
         -> IO ()
setStyle props e@(Element el session) = run session $ SetStyle el props

-- | Set the attribute of the given element.
setAttr :: String  -- ^ The attribute name.
        -> String  -- ^ The attribute value.
        -> Element -- ^ The element to update.
        -> IO ()
setAttr key value e@(Element el session) = run session $ SetAttr el key value

-- | Set the property of the given element.
setProp :: String  -- ^ The property name.
        -> JSValue -- ^ The property value.
        -> Element -- ^ The element to update.
        -> IO ()
setProp key value e@(Element el session) =
    runFunction session $ ffi "$(%1).prop(%2,%3);" el key value

-- | Set the text of the given element.
setText :: String  -- ^ The plain text.
        -> Element -- ^ The element to update.
        -> IO ()
setText props e@(Element el session) = run session $ SetText el props

-- | Set the HTML of the given element.
setHtml :: String  -- ^ The HTML.
        -> Element -- ^ The element to update.
        -> IO ()
setHtml props e@(Element el session) = run session $ SetHtml el props

-- | Set the title of the document.
setTitle
    :: String  -- ^ The title.
    -> Window  -- ^ The document window
    -> IO ()
setTitle title session = run session $ SetTitle title

-- | Empty the given element.
emptyEl :: Element -> IO ()
emptyEl e@(Element el session) = run session $ EmptyEl el

-- | Delete the given element.
delete :: Element -> IO ()
delete e@(Element el session)  = run session $ Delete el


{-----------------------------------------------------------------------------
    Manipulating tree structure
------------------------------------------------------------------------------}
-- $treestructure
--
--  Functions for creating, deleting, moving, appending, prepending, DOM nodes.

-- | Create a new element of the given tag name.
newElement :: Window      -- ^ Browser window in which context to create the element
           -> String      -- ^ The tag name.
           -> IO Element  -- ^ A tag reference. Non-blocking.
newElement session@(Session{..}) tagName = do
    elid <- modifyMVar sElementIds $ \elids ->
        return (tail elids,"*" ++ show (head elids) ++ ":" ++ tagName)
    return (Element (ElementId elid) session)

-- | Append a child element to a parent element. Non-blocking.
appendElementTo
    :: Element     -- ^ Parent.
    -> Element     -- ^ Child.
    -> IO () 
appendElementTo (Element parent session) e@(Element child _) =
    -- TODO: Right now, parent and child need to be from the same session/browser window
    --       Implement transfer of elements across browser windows
    run session $ Append parent child

{-----------------------------------------------------------------------------
    Querying the DOM
------------------------------------------------------------------------------}
-- $querying
-- 
-- The DOM can be searched for elements of a given name, and nodes can
-- be inspected for their values.

-- | Get all elements of the given tag name.  Blocks.
getElementsByTagName
    :: Window        -- ^ Browser window
    -> String        -- ^ The tag name.
    -> IO [Element]  -- ^ All elements with that tag name.
getElementsByTagName window tagName =
  call window (GetElementsByTagName tagName) $ \signal ->
    case signal of
      Elements els -> return $ Just $ [Element el window | el <- els]
      _            -> return Nothing

-- | Get a list of elements by particular IDs.  Blocks.
getElementsById
    :: Window        -- ^ Browser window
    -> [String]      -- ^ The ID string.
    -> IO [Element]  -- ^ Elements with given ID.
getElementsById window ids =
  call window (GetElementsById ids) $ \signal ->
    case signal of
      Elements els -> return $ Just [Element el window | el <- els]
      _            -> return Nothing

-- | Get a list of elements by particular class.  Blocks.
getElementsByClassName
    :: Window        -- ^ Browser window
    -> String        -- ^ The class string.
    -> IO [Element]  -- ^ Elements with given class.
getElementsByClassName window cls =
  call window (GetElementsByClassName cls) $ \signal ->
    case signal of
      Elements els -> return $ Just [Element el window | el <- els]
      _            -> return Nothing

-- | Get the value of an input. Blocks.
getValue
    :: Element   -- ^ The element to get the value of.
    -> IO String -- ^ The plain text value.
getValue e@(Element el window) =
  call window (GetValue el) $ \signal ->
    case signal of
      Value str -> return (Just str)
      _         -> return Nothing

-- | Get the property of an element. Blocks.
getProp
    :: String     -- ^ The property name.
    -> Element    -- ^ The element to get the value of.
    -> IO JSValue -- ^ The plain text value.
getProp prop e@(Element el window) =
    callFunction window (ffi "$(%1).prop(%2)" el prop)

-- | Get 'Window' associated to an 'Element'.
getWindow :: Element -> Window
getWindow (Element _ window) = window

-- | Get values from inputs. Blocks. This is faster than many 'getValue' invocations.
getValuesList
    :: [Element]   -- ^ A list of elements to get the values of.
    -> IO [String] -- ^ The list of plain text values.
getValuesList [] = return []
getValuesList es@(Element _ window : _) =
    let elids = [elid | Element elid _ <- es] in
    call window (GetValues elids) $ \signal ->
        case signal of
            Values strs -> return $ Just strs
            _           -> return Nothing

-- | Read a value from an input. Blocks.
readValue
    :: Read a
    => Element      -- ^ The element to read a value from.
    -> IO (Maybe a) -- ^ Maybe the read value.
readValue = liftM readMay . getValue

-- | Read values from inputs. Blocks. This is faster than many 'readValue' invocations.
readValuesList
    :: Read a
    => [Element]      -- ^ The element to read a value from.
    -> IO (Maybe [a]) -- ^ Maybe the read values. All or none.
readValuesList = liftM (sequence . map readMay) . getValuesList

-- | Get the head of the page.
getHead :: Window -> IO Element
getHead session = return $ Element (ElementId "head") session

-- | Get the body of the page.
getBody :: Window -> IO Element
getBody session = return $ Element (ElementId "body") session

-- | Get the request location.
getRequestLocation :: Window -> IO URI
getRequestLocation = return . fst . sStartInfo

-- | Get the request cookies.
getRequestCookies :: Window -> IO [(String,String)]
getRequestCookies = return . snd . sStartInfo

{-----------------------------------------------------------------------------
    Utilities
------------------------------------------------------------------------------}
-- | Send a debug message to the client. The behaviour of the client
--   is unspecified.
debug
    :: Window -- ^ Client window
    -> String -- ^ Some plain text to send to the client.
    -> IO ()
debug window = run window . Debug

-- | Clear the client's DOM.
clear :: Window -> IO ()
clear window = runFunction window $ ffi "$('body').contents().detach()"