module Graphics.UI.Threepenny.Internal.Core
(
serve
,loadFile
,loadDirectory
,bind
,disconnect
,module Reactive.Threepenny
,setStyle
,setAttr
,setProp
,setText
,setHtml
,setTitle
,emptyEl
,delete
,newElement
,appendElementTo
,getHead
,getBody
,getElementsByTagName
,getElementsById
,getElementsByClassName
,getWindow
,getProp
,getValue
,getValuesList
,readValue
,readValuesList
,getRequestCookies
,getRequestLocation
,debug
,clear
,callDeferredFunction
,atomic
,ToJS, FFI, ffi, JSFunction
,runFunction, callFunction
,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
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 ()
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
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.Request -> WS.WebSockets WS.Hybi00 ()
webSocket Session{..} req = void $ do
WS.acceptRequest req
liftIO $ modifyMVar_ sConnectedState (const (return Connected))
send <- WS.getSink
sendData <- liftIO . forkIO . forever $ do
x <- readChan sInstructions
WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x
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
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
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
run :: Session -> Instruction -> IO ()
run (Session{..}) i = writeChan sInstructions i
callDeferredFunction
:: Window
-> String
-> [String]
-> ([Maybe String] -> IO ())
-> 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)
runFunction :: Window -> JSFunction () -> IO ()
runFunction session = run session . RunJSFunction . unJSCode . 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
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
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
handleEvents window
addEventHandler :: Window -> (EventKey, Handler EventData) -> IO ()
addEventHandler Session{..} (key,handler) =
modifyMVar_ sEventHandlers $ return .
M.insertWith (\h1 h a -> h1 a >> h a) key handler
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 ()
getSignal :: Window -> IO Signal
getSignal (Session{..}) = readChan sSignals
bind
:: String
-> Element
-> Handler EventData
-> IO ()
bind eventType (Element el@(ElementId elid) session) handler = do
let key = (elid, eventType)
handlers <- readMVar $ sEventHandlers session
when (not $ key `M.member` handlers) $
run session $ Bind eventType el (Closure key)
addEventHandler session (key, handler)
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
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)
setStyle :: [(String, String)]
-> Element
-> IO ()
setStyle props e@(Element el session) = run session $ SetStyle el props
setAttr :: String
-> String
-> Element
-> IO ()
setAttr key value e@(Element el session) = run session $ SetAttr el key value
setProp :: String
-> JSValue
-> Element
-> IO ()
setProp key value e@(Element el session) =
runFunction session $ ffi "$(%1).prop(%2,%3);" el key value
setText :: String
-> Element
-> IO ()
setText props e@(Element el session) = run session $ SetText el props
setHtml :: String
-> Element
-> IO ()
setHtml props e@(Element el session) = run session $ SetHtml el props
setTitle
:: String
-> Window
-> IO ()
setTitle title session = run session $ SetTitle title
emptyEl :: Element -> IO ()
emptyEl e@(Element el session) = run session $ EmptyEl el
delete :: Element -> IO ()
delete e@(Element el session) = run session $ Delete el
newElement :: Window
-> String
-> IO Element
newElement session@(Session{..}) tagName = do
elid <- modifyMVar sElementIds $ \elids ->
return (tail elids,"*" ++ show (head elids) ++ ":" ++ tagName)
return (Element (ElementId elid) session)
appendElementTo
:: Element
-> Element
-> IO ()
appendElementTo (Element parent session) e@(Element child _) =
run session $ Append parent child
getElementsByTagName
:: Window
-> String
-> IO [Element]
getElementsByTagName window tagName =
call window (GetElementsByTagName tagName) $ \signal ->
case signal of
Elements els -> return $ Just $ [Element el window | el <- els]
_ -> return Nothing
getElementsById
:: Window
-> [String]
-> IO [Element]
getElementsById window ids =
call window (GetElementsById ids) $ \signal ->
case signal of
Elements els -> return $ Just [Element el window | el <- els]
_ -> return Nothing
getElementsByClassName
:: Window
-> String
-> IO [Element]
getElementsByClassName window cls =
call window (GetElementsByClassName cls) $ \signal ->
case signal of
Elements els -> return $ Just [Element el window | el <- els]
_ -> return Nothing
getValue
:: Element
-> IO String
getValue e@(Element el window) =
call window (GetValue el) $ \signal ->
case signal of
Value str -> return (Just str)
_ -> return Nothing
getProp
:: String
-> Element
-> IO JSValue
getProp prop e@(Element el window) =
callFunction window (ffi "$(%1).prop(%2)" el prop)
getWindow :: Element -> Window
getWindow (Element _ window) = window
getValuesList
:: [Element]
-> IO [String]
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
readValue
:: Read a
=> Element
-> IO (Maybe a)
readValue = liftM readMay . getValue
readValuesList
:: Read a
=> [Element]
-> IO (Maybe [a])
readValuesList = liftM (sequence . map readMay) . getValuesList
getHead :: Window -> IO Element
getHead session = return $ Element (ElementId "head") session
getBody :: Window -> IO Element
getBody session = return $ Element (ElementId "body") session
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
clear :: Window -> IO ()
clear window = runFunction window $ ffi "$('body').contents().detach()"