Driver.hs

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

module Graphics.UI.Threepenny.Internal.Driver
  (
  -- * Synopsis
  -- | The main internal functionality.
      
  -- * Server running
   serve
  ,loadFile
  ,loadDirectory

  -- * Elements
  ,newElement
  ,appendElementTo
  ,emptyEl
  ,delete
  
  -- * Event handling
  -- $eventhandling
  ,bind
  ,disconnect
  ,module Reactive.Threepenny
 
  -- * Querying
  -- $querying
  ,getHead
  ,getBody
  ,getElementsByTagName
  ,getElementsById
  ,getElementsByClassName
  ,getWindow
  ,getValuesList
  ,getRequestCookies
  ,getRequestLocation
  
  -- * Utilities
  ,debug
  ,callDeferredFunction
  ,atomic

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



import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.Chan.Extra
import           Control.Concurrent.Delay
import           Control.DeepSeq
import qualified Control.Exception
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


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

import qualified Foreign.Coupon as Foreign
import qualified System.Mem

{-----------------------------------------------------------------------------
    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 ()
    sEventQuit        <- newEvent
    sPrizeBooth      <- Foreign.newPrizeBooth
    let sHeadElement  =  undefined -- filled in later
    let sBodyElement  =  undefined
    now               <- getCurrentTime
    sConnectedState   <- newMVar (Disconnected now)
    sThreadId         <- myThreadId
    sClosures         <- newMVar [0..]
    let session = Session {..}
    initializeElements 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.PendingConnection -> IO ()
webSocket Session{..} request = void $ do
    connection <- WS.acceptRequest request
    -- websockets are always connected, don't let the custodian kill you.
    modifyMVar_ sConnectedState (const (return Connected))

    -- write data (in another thread)
    sendData <- forkIO . forever $ do
        x <- readChan sInstructions
        -- see note [Instruction strictness]
        WS.sendTextData connection . Text.pack . JSON.encode $ x

    -- read data
    let readData = do
            input <- WS.receiveData connection
            case input of
                "ping" -> WS.sendTextData connection . Text.pack $ "pong"
                "quit" -> E.throw WS.ConnectionClosed
                input  -> case JSON.decode . Text.unpack $ input of
                    Ok signal -> writeChan sSignals signal
                    Error err -> E.throw $ Atto.ParseError [] err
    
    forever readData `E.finally`
        (do
            killThread sendData             -- kill sending thread when done
            writeChan sSignals $ Quit ()    -- signal  Quit  event
        )

{- note [Instruction strictness]

The  Instruction  may contain components that evaluate to _|_.
An exception will be thrown when we try to send one of those to the browser.
However, the  WS.sendSink  function is called in a different thread
than where the faulty instruction was constructed.
We want to throw an exception in the latter thread.
Hence, we make sure that the  Instruction  is fully evaluated (deepseq)
before passing it to the thread that sends it to the web browser.

(Another, probably preferred, solution would be to make the  Instruction
data type fully strict by default.)

-}



{-----------------------------------------------------------------------------
    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
  -- see note [Instruction strictness]
  Control.Exception.evaluate $ force instruction
  takeMVar sMutex
  writeChan sInstructions 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{..}) instruction =
    writeChan sInstructions $!! instruction  -- see note [Instruction strictness]

-- | 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 window fun params thunk = do
    closure <- newClosure window fun $ \(EventData xs) -> thunk xs
    run window $ CallDeferredFunction (closure,fun,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 . toCode

-- | 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 = 
    call window (CallJSFunction . toCode $ jsfunction) $ \signal ->
        case signal of
            FunctionResult v -> case marshalResult jsfunction window v of
                Ok    a -> return $ Just a
                Error _ -> return Nothing
            _ -> return Nothing


-- | Package a Haskell function such that it can be called from JavaScript.
-- 
-- At the moment, we implement this as an event handler that is
-- attached to the @head@ element.
newClosure
    :: Window               -- ^ Browser window context
    -> String               -- ^ Function name (for debugging).
    -> (EventData -> IO ()) -- ^ Function to call
    -> IO Closure
newClosure window@(Session{..}) fun thunk = do
    cid <- modifyMVar sClosures $ \(x:xs) -> return (xs,x)
    let eventId = fun ++ "-" ++ show cid
    attachClosure sHeadElement eventId thunk
    return $ Closure (unprotectedGetElementId sHeadElement, eventId)


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


{-----------------------------------------------------------------------------
    Elements
        Creation, Management, Finalization
------------------------------------------------------------------------------}
-- | Create a new element of the given tag name.
newElement :: Window        -- ^ Browser window in which context to create the element
           -> String        -- ^ The tag name.
           -> Events        -- ^ Events associated to that element.
           -> IO Element    -- ^ A tag reference. Non-blocking.
newElement elSession@(Session{..}) elTagName elEvents = do
    elHandlers <- newMVar M.empty
    el         <- Foreign.newItem sPrizeBooth ElementData{..}
    Foreign.addFinalizer el $ delete el
        -- FIXME: Do not try to delete elements from the session when
        -- the session is broken/disconnected already.
        -- A fix should be part of the  run  function, though.
    return el

-- | Get 'Window' associated to an 'Element'.
getWindow :: Element -> IO Window
getWindow e = withElement e $ \_ window -> return window

-- | Look up several elements in the browser window.
lookupElements :: Session -> [ElementId] -> IO [Element]
lookupElements window = mapM (flip lookupElement window)

-- | Append a child element to a parent element. Non-blocking.
appendElementTo
    :: Element     -- ^ Parent.
    -> Element     -- ^ Child.
    -> IO ()
appendElementTo eParent eChild =
    -- TODO: Right now, parent and child need to be from the same session/browser window
    --       Implement transfer of elements across browser windows
    withElement eParent $ \parent session ->
    withElement eChild  $ \child  _       -> do
        Foreign.addReachable eParent eChild
        runFunction session $ ffi "$(%1).append($(%2))" parent child

-- | Get the head of the page.
getHead :: Window -> IO Element
getHead session = return $ sHeadElement session

-- | Get the body of the page.
getBody :: Window -> IO Element
getBody session = return $ sBodyElement session

-- | Empty the given element.
emptyEl :: Element -> IO ()
emptyEl el = withElement el $ \elid window -> do
    Foreign.clearReachable el
    runFunction window $ ffi "$(%1).contents().detach()" elid

-- | Delete the given element.
delete :: Element -> IO ()
delete el = withElement el $ \elid window ->
    run window $ Delete elid
    -- Note: We want a primitive 'Delete' here, because 
    -- we do not want the implicit conversion from ElementId to element.


{-----------------------------------------------------------------------------
    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 eventId params -> do
            handleEvent1 window (elid,eventId,EventData params)
#ifdef REBUG
            -- debug garbage collection of elements:
            System.Mem.performGC
#endif
            handleEvents window
        Quit () -> do
            snd sEventQuit ()
            -- do not continue handling events
        _       -> do
            handleEvents window

-- | Handle a single event.
handleEvent1 :: Window -> (ElementId, EventId, EventData) -> IO ()
handleEvent1 window (elid,eventId,params) = do
    el <- lookupElement elid window
    withElementData el $ \_ eldata -> do
        handlers <- readMVar $ elHandlers eldata
        case M.lookup eventId handlers of
            Just handler -> handler params
            Nothing      -> return ()

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

-- | Associate a new closure with an element.
attachClosure :: Element -> EventId -> Handler EventData -> IO () 
attachClosure el eventId handler = withElementData el $ \_ eldata ->
    modifyMVar_ (elHandlers eldata) $ return .
        M.insertWith (\h1 h a -> h1 a >> h a) eventId handler

-- | Bind an event handler for a dom event to an 'Element'.
bind
    :: EventId              -- ^ 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 eventId e handler = withElementData e $ \elid el -> do
    handlers <- readMVar $ elHandlers el
    -- register with client if it has never been registered on the server
    when (not $ eventId `M.member` handlers) $
        run (elSession el) $ Bind eventId elid
    -- register with server
    attachClosure e eventId handler

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

-- | Initialize the 'head' and 'body' elements when the session starts.
initializeElements :: Session -> IO Session
initializeElements session@(Session{..}) = do
        sHeadElement <- createElement "head"
        sBodyElement <- createElement "body"
        return $ Session{..}
    where
    newEvents     e   = newEventsNamed $ \(name,_,handler) -> bind name e handler
    createElement tag = mdo
        x <- newElement session tag =<< newEvents x
        return x

{-----------------------------------------------------------------------------
    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 -> String -> IO [Element]
getElementsByTagName window tag = do
    elids <- callFunction window $ ffi "document.getElementsByTagName(%1)" tag
    lookupElements window elids

-- | Get a list of elements by particular IDs.  Blocks.
getElementsById :: Window -> [String] -> IO [Element]
getElementsById window ids = do
    elids <- forM ids $ \x ->
        callFunction window $ ffi "[document.getElementById(%1)]" x
    lookupElements window $ concat elids

-- | Get a list of elements by particular class.  Blocks.
getElementsByClassName :: Window -> String -> IO [Element]
getElementsByClassName window cls = do
    elids <- callFunction window $ ffi "document.getElementsByClassName(%1)" cls
    lookupElements window elids

-- | 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@(e0:_) = withElement e0 $ \_ window -> do
    let elids  = map unprotectedGetElementId es
    call window (GetValues elids) $ \signal ->
        case signal of
            Values strs -> return $ Just strs
            _           -> return Nothing

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