module Graphics.UI.Threepenny.Internal.Driver
(
serve
,loadFile
,loadDirectory
,newElement
,appendElementTo
,emptyEl
,delete
,bind
,disconnect
,module Reactive.Threepenny
,getHead
,getBody
,getElementsByTagName
,getElementsById
,getElementsByClassName
,getWindow
,getValuesList
,getRequestCookies
,getRequestLocation
,debug
,callDeferredFunction
,atomic
,ToJS, FFI, ffi, JSFunction
,runFunction, callFunction
,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
newServerState :: IO ServerState
newServerState = ServerState
<$> newMVar M.empty
<*> newMVar (0,M.empty)
<*> newMVar (0,M.empty)
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
++ routeWebsockets worker server
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
if (dcSeconds > fromIntegral seconds)
then do killThread sThreadId
return (Just key)
else return Nothing
return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)
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
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
routeCommunication :: (Session -> IO a) -> ServerState -> Routes
routeCommunication worker server =
[("/init" , init worker server)
,("/poll" , withSession server poll )
,("/signal" , withSession server signal)
]
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
let sBodyElement = undefined
now <- getCurrentTime
sConnectedState <- newMVar (Disconnected now)
sThreadId <- myThreadId
sClosures <- newMVar [0..]
let session = Session {..}
initializeElements session
createSession :: (Session -> IO void) -> ServerState -> Snap Session
createSession worker server = do
let uri = undefined
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)
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)
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
killThread threadId
E.catch (readAvailableChan sInstructions) $ \e -> do
when (e == Control.Exception.ThreadKilled) $ setDisconnected
E.throw e
writeJson instructions
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
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
modifyMVar_ sConnectedState (const (return Connected))
sendData <- forkIO . forever $ do
x <- readChan sInstructions
WS.sendTextData connection . Text.pack . JSON.encode $ x
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
writeChan sSignals $ Quit ()
)
atomic :: Window -> IO a -> IO a
atomic window@(Session{..}) m = do
takeMVar sMutex
ret <- m
putMVar sMutex ()
return ret
call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
call session@(Session{..}) instruction withSignal = do
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
run :: Session -> Instruction -> IO ()
run (Session{..}) instruction =
writeChan sInstructions $!! instruction
callDeferredFunction
:: Window
-> String
-> [String]
-> ([Maybe String] -> IO ())
-> IO ()
callDeferredFunction window fun params thunk = do
closure <- newClosure window fun $ \(EventData xs) -> thunk xs
run window $ CallDeferredFunction (closure,fun,params)
runFunction :: Window -> JSFunction () -> IO ()
runFunction session = run session . RunJSFunction . toCode
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
newClosure
:: Window
-> String
-> (EventData -> IO ())
-> 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)
writeJson :: (MonadSnap m, JSON a) => a -> m ()
writeJson json = do
modifyResponse $ setContentType "application/json"
(writeText . pack . (\x -> showJSValue x "") . showJSON) json
getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
getInput = fmap (fmap (unpack . decodeUtf8)) . getParam
readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
readInput = fmap (>>= readMay) . getInput
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
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
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
loadFile :: Session -> MimeType -> FilePath -> IO String
loadFile Session{..} mimetype path = do
key <- newAssociation (sFiles sServerState) (path,mimetype)
return $ "/file/" ++ key
loadDirectory :: Session -> FilePath -> IO String
loadDirectory Session{..} path = do
key <- newAssociation (sDirs sServerState) (path,"")
return $ "/dir/" ++ key
newElement :: Window
-> String
-> Events
-> IO Element
newElement elSession@(Session{..}) elTagName elEvents = do
elHandlers <- newMVar M.empty
el <- Foreign.newItem sPrizeBooth ElementData{..}
Foreign.addFinalizer el $ delete el
return el
getWindow :: Element -> IO Window
getWindow e = withElement e $ \_ window -> return window
lookupElements :: Session -> [ElementId] -> IO [Element]
lookupElements window = mapM (flip lookupElement window)
appendElementTo
:: Element
-> Element
-> IO ()
appendElementTo eParent eChild =
withElement eParent $ \parent session ->
withElement eChild $ \child _ -> do
Foreign.addReachable eParent eChild
runFunction session $ ffi "$(%1).append($(%2))" parent child
getHead :: Window -> IO Element
getHead session = return $ sHeadElement session
getBody :: Window -> IO Element
getBody session = return $ sBodyElement session
emptyEl :: Element -> IO ()
emptyEl el = withElement el $ \elid window -> do
Foreign.clearReachable el
runFunction window $ ffi "$(%1).contents().detach()" elid
delete :: Element -> IO ()
delete el = withElement el $ \elid window ->
run window $ Delete elid
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
System.Mem.performGC
#endif
handleEvents window
Quit () -> do
snd sEventQuit ()
_ -> do
handleEvents window
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 ()
getSignal :: Window -> IO Signal
getSignal (Session{..}) = readChan sSignals
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
:: EventId
-> Element
-> Handler EventData
-> IO ()
bind eventId e handler = withElementData e $ \elid el -> do
handlers <- readMVar $ elHandlers el
when (not $ eventId `M.member` handlers) $
run (elSession el) $ Bind eventId elid
attachClosure e eventId handler
disconnect :: Window -> Event ()
disconnect = fst . sEventQuit
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
getElementsByTagName :: Window -> String -> IO [Element]
getElementsByTagName window tag = do
elids <- callFunction window $ ffi "document.getElementsByTagName(%1)" tag
lookupElements window elids
getElementsById :: Window -> [String] -> IO [Element]
getElementsById window ids = do
elids <- forM ids $ \x ->
callFunction window $ ffi "[document.getElementById(%1)]" x
lookupElements window $ concat elids
getElementsByClassName :: Window -> String -> IO [Element]
getElementsByClassName window cls = do
elids <- callFunction window $ ffi "document.getElementsByClassName(%1)" cls
lookupElements window elids
getValuesList
:: [Element]
-> IO [String]
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
getRequestLocation :: Window -> IO URI
getRequestLocation = return . fst . sStartInfo
getRequestCookies :: Window -> IO [(String,String)]
getRequestCookies = return . snd . sStartInfo
debug
:: Window
-> String
-> IO ()
debug window = run window . Debug