{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Foreign.JavaScript.Server (
httpComm, loadFile, loadDirectory,
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM as STM
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as M
import Data.Text
import qualified Safe as Safe
import System.Environment
import System.FilePath
import Data.Aeson ((.=))
import qualified Data.Aeson as JSON
import qualified Network.WebSockets as WS
import qualified Network.WebSockets.Snap as WS
import Snap.Core as Snap
import qualified Snap.Http.Server as Snap
import Snap.Util.FileServe
import Foreign.JavaScript.Resources
import Foreign.JavaScript.Types
httpComm :: Config -> EventLoop -> IO ()
httpComm Config{..} worker = do
env <- getEnvironment
let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env
let addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env
let config = Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))
$ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv))
$ Snap.setErrorLog (Snap.ConfigIoLog jsLog)
$ Snap.setAccessLog (Snap.ConfigIoLog jsLog)
$ Snap.defaultConfig
server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog
Snap.httpServe config . route $
routeResources server jsCustomHTML jsStatic
++ routeWebsockets (worker server)
routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes
routeWebsockets worker = [("websocket", response)]
where
response = do
requestInfo <- Snap.getRequest
WS.runWebSocketsSnap $ \ws -> void $ do
comm <- communicationFromWebSocket ws
worker (rqCookies requestInfo) comm
communicationFromWebSocket :: WS.PendingConnection -> IO Comm
communicationFromWebSocket request = do
connection <- WS.acceptRequest request
commIn <- STM.newTQueueIO
commOut <- STM.newTQueueIO
commOpen <- STM.newTVarIO True
let sendData = forever $ do
x <- atomically $ STM.readTQueue commOut
WS.sendTextData connection . JSON.encode $ x
let readData = forever $ do
input <- WS.receiveData connection
case input of
"ping" -> WS.sendTextData connection . LBS.pack $ "pong"
"quit" -> E.throwIO WS.ConnectionClosed
input -> case JSON.decode input of
Just x -> atomically $ STM.writeTQueue commIn x
Nothing -> error $
"Foreign.JavaScript: Couldn't parse JSON input"
++ show input
let sentry = atomically $ do
open <- STM.readTVar commOpen
when open retry
let commClose = atomically $ STM.writeTVar commOpen False
forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do
commClose
let all :: E.SomeException -> Maybe ()
all _ = Just ()
E.tryJust all $ WS.sendClose connection $ LBS.pack "close"
return $ Comm {..}
type Routes = [(ByteString, Snap ())]
routeResources :: Server -> Maybe FilePath -> Maybe FilePath -> Routes
routeResources server customHTML staticDir =
fixHandlers noCache $
static ++
[("/" , root)
,("/haskell.js" , writeTextMime jsDriverCode "application/javascript")
,("/haskell.css" , writeTextMime cssDriverCode "text/css")
,("/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 "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic"
Nothing -> writeTextMime defaultHtmlFile "text/html"
writeTextMime text mime = do
modifyResponse (setHeader "Content-type" mime)
writeText text
withFilepath :: MVar Filepaths -> (FilePath -> ByteString -> 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 (BS.pack 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 (BS.pack key) (path,mimetype) dict)
return key
loadFile :: Server -> MimeType -> FilePath -> IO String
loadFile server mimetype path = do
key <- newAssociation (sFiles server) (path, mimetype)
return $ "/file/" ++ key
loadDirectory :: Server -> FilePath -> IO String
loadDirectory server path = do
key <- newAssociation (sDirs server) (path,"")
return $ "/dir/" ++ key