module Graphics.UI.Threepenny.Internal.Core
(
serve
,loadFile
,loadDirectory
,bind
,handleEvent
,handleEvents
,module Control.Event
,setStyle
,setAttr
,setText
,setHtml
,setTitle
,emptyEl
,delete
,newElement
,appendElementTo
,getHead
,getBody
,getElementsByTagName
,getElementsById
,getWindow
,getValue
,getValuesList
,readValue
,readValuesList
,getRequestCookies
,getRequestLocation
,debug
,clear
,callFunction
,runFunction
,callDeferredFunction
,atomic
,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 as E
import Control.Event
import Control.Monad.IO
import Control.Monad.Reader
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 Prelude hiding (init)
import Safe
import Snap.Core
import Snap.Http.Server hiding (Config)
import Snap.Util.FileServe
import System.FilePath
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)
httpServe config (router tpCustomHTML tpStatic worker server)
where config = setPort tpPort defaultConfig
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)
router
:: Maybe FilePath
-> FilePath
-> (Session -> IO a)
-> ServerState
-> Snap ()
router customHTML wwwroot worker server =
route [("/static" , serveDirectory wwwroot)
,("/" , root)
,("/driver/threepenny-gui.js" , writeText jsDriverCode )
,("/driver/threepenny-gui.css" , writeText cssDriverCode)
,("/init" , init worker server)
,("/poll" , withSession server poll )
,("/signal" , withSession server signal)
,("/file/:name" ,
withFilepath (sFiles server) (flip serveFileAs))
,("/dir/:name" ,
withFilepath (sDirs server) (\path _ -> serveDirectory path))
]
where
root = case customHTML of
Just file -> serveFile (wwwroot </> file)
Nothing -> writeText defaultHtmlFile
withFilepath :: MVar Filepaths -> (FilePath -> MimeType -> Snap a) -> Snap a
withFilepath rDict cont = do
mName <- getParam "name"
(_,dict) <- io $ 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
init :: (Session -> IO void) -> ServerState -> Snap ()
init sessionThread server = do
uri <- getRequestURI
params <- getRequestCookies
key <- io $ modifyMVar (sSessions server) $ \sessions -> do
let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
session <- newSession server (uri,params) newKey
_ <- forkIO $ do _ <- sessionThread session; return ()
return (M.insert newKey session sessions,newKey)
modifyResponse $ setHeader "Set-Token" (fromString (show key))
withGivenSession key server poll
where getRequestURI = do
uri <- getInput "info"
maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)
getRequestCookies = do
cookies <- getsRequest rqCookies
return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
newSession server info token = do
signals <- newChan
instructions <- newChan
(event, handler) <- newEventsTagged
ids <- newMVar [0..]
mutex <- newMVar ()
now <- getCurrentTime
conState <- newMVar (Disconnected now)
threadId <- myThreadId
closures <- newMVar [0..]
return $ Session
{ sSignals = signals
, sInstructions = instructions
, sEvent = event
, sEventHandler = handler
, sElementIds = ids
, sToken = token
, sMutex = mutex
, sConnectedState = conState
, sThreadId = threadId
, sClosures = closures
, sStartInfo = info
, sServerState = server
}
poll :: Session -> Snap ()
poll Session{..} = do
let setDisconnected = do
now <- getCurrentTime
modifyMVar_ sConnectedState (const (return (Disconnected now)))
io $ modifyMVar_ sConnectedState (const (return Connected))
threadId <- io $ myThreadId
_ <- io $ forkIO $ do
delaySeconds $ 60 * 5
killThread threadId
instructions <- io $ E.catch (readAvailableChan sInstructions) $ \e -> do
when (e == E.ThreadKilled) $ do
setDisconnected
E.throw e
writeJson instructions
writeJson :: (MonadSnap m, Data a) => a -> m ()
writeJson json = do
modifyResponse $ setContentType "application/json"
(writeString . encodeJSON) json
writeString :: (MonadSnap m) => String -> m ()
writeString = writeText . pack
signal :: Session -> Snap ()
signal Session{..} = do
input <- getInput "signal"
case input of
Just signalJson -> do
let signal = decode signalJson
case signal of
Ok signal -> io $ writeChan sSignals signal
Error err -> error err
Nothing -> error $ "Unable to parse " ++ show input
getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
getInput = fmap (fmap (unpack . decodeUtf8)) . getParam
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 <- io $ withMVar sSessions return
case M.lookup token sessions of
Nothing -> error $ "Nonexistant token: " ++ show token
Just session -> cont session
readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
readInput = fmap (>>= readMay) . getInput
handleEvents :: Window -> IO ()
handleEvents window = forever $ handleEvent window
handleEvent :: Window -> IO ()
handleEvent window@(Session{..}) = do
signal <- getSignal window
case signal of
Threepenny.Event (elid,eventType,params) -> do
sEventHandler ((elid,eventType), EventData params)
_ -> return ()
getSignal :: Window -> IO Signal
getSignal (Session{..}) = readChan sSignals
bind
:: String
-> Element
-> Event EventData
bind eventType (Element el@(ElementId elid) session) =
Control.Event.Event register
where
key = (elid, eventType)
register h = do
unregister <- Control.Event.register (sEvent session key) h
run session $ Bind eventType el (Closure key)
return unregister
newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
newClosure window@(Session{..}) eventType elid thunk = do
let key = (elid, eventType)
_ <- register (sEvent 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
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
getValue
:: Element
-> IO String
getValue e@(Element el window) =
call window (GetValue el) $ \signal ->
case signal of
Value str -> return (Just str)
_ -> return Nothing
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
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
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 = run window $ Clear ()
callFunction
:: Window
-> String
-> [String]
-> IO [Maybe String]
callFunction window func params =
call window (CallFunction (func,params)) $ \signal ->
case signal of
FunctionCallValues vs -> return (Just vs)
_ -> return Nothing
runFunction
:: Window
-> String
-> [String]
-> IO ()
runFunction window func params =
run window $ CallFunction (func,params)
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)