Server.hs

{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Foreign.JavaScript.Server (
    httpComm, loadFile, loadDirectory,
    ) where

-- import general libraries
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                          (Text)
import qualified Safe                       as Safe
import           System.Environment
import           System.FilePath

-- import web libraries
import qualified Data.Aeson                    as JSON
import qualified Network.WebSockets            as WS
import qualified Network.WebSockets.Snap       as WS
import           Snap.Core                     as Snap hiding (path, dir)
import qualified Snap.Http.Server              as Snap
import           Snap.Util.FileServe

-- import internal modules
import Foreign.JavaScript.Resources
import Foreign.JavaScript.Types

{-----------------------------------------------------------------------------
    HTTP Server using WebSockets
------------------------------------------------------------------------------}
-- | Run a HTTP server that creates a 'Comm' channel.
httpComm :: Config -> EventLoop -> IO ()
httpComm Config{..} worker = do
    env <- getEnvironment

    let config = Snap.setErrorLog     (Snap.ConfigIoLog jsLog)
               $ Snap.setAccessLog    (Snap.ConfigIoLog jsLog)
               $ maybe (configureHTTP env) configureSSL jsUseSSL
               $ Snap.defaultConfig

    server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog

    Snap.httpServe config . route $
        routeResources server jsCustomHTML jsStatic
        ++ routeWebsockets (worker server)

    where
    configureHTTP :: [(String, String)] -> Snap.Config m a -> Snap.Config m a
    configureHTTP env config =
        let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env
            addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env
         in Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))
                $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv)) config

    configureSSL :: ConfigSSL -> Snap.Config m a -> Snap.Config m a
    configureSSL cfgSsl config =
        Snap.setSSLBind            (jsSSLBind cfgSsl)
            . Snap.setSSLPort      (jsSSLPort cfgSsl)
            . Snap.setSSLCert      (jsSSLCert cfgSsl)
            . Snap.setSSLKey       (jsSSLKey cfgSsl)
            $ Snap.setSSLChainCert (jsSSLChainCert cfgSsl) config

-- | Route the communication between JavaScript and the 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
            -- error "Foreign.JavaScript: unreachable code path."

-- | Create 'Comm' channel from WebSocket request.
communicationFromWebSocket :: WS.PendingConnection -> IO Comm
communicationFromWebSocket request = do
    connection <- WS.acceptRequest request
    commIn     <- STM.newTQueueIO   -- outgoing communication
    commOut    <- STM.newTQueueIO   -- incoming communication
    commOpen   <- STM.newTVarIO True

    -- write data to browser
    let sendData = forever $ do
            x <- atomically $ STM.readTQueue commOut
            -- see note [ServerMsg strictness]
            WS.sendTextData connection . JSON.encode $ x

    -- read data from browser
    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

    -- block until the channel is closed
    let sentry = atomically $ do
            open <- STM.readTVar commOpen
            when open retry

    -- explicitly close the Comm chanenl
    let commClose = atomically $ STM.writeTVar commOpen False

    -- read/write data until an exception occurs or the channel is no longer open
    _ <- forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do
        -- close the communication channel explicitly if that didn't happen yet
        commClose

        -- attempt to close websocket if still necessary/possible
        -- ignore any exceptions that may happen if it's already closed
        let allExceptions :: E.SomeException -> Maybe ()
            allExceptions _ = Just ()
        E.tryJust allExceptions $ WS.sendClose connection $ LBS.pack "close"

    return $ Comm {..}

{-----------------------------------------------------------------------------
    Resources
------------------------------------------------------------------------------}
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 :: MonadSnap m => Text -> ByteString -> m ()
writeTextMime text mime = do
    modifyResponse (setHeader "Content-type" mime)
    writeText text

-- | Extract  from a URI
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

-- FIXME: Serving large files fails with the exception
-- System.SendFile.Darwin: invalid argument (Socket is not connected)

-- | Associate an URL to a FilePath
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

-- | Begin to serve a local file with a given 'MimeType' under a URI.
loadFile :: Server -> MimeType -> FilePath -> IO String
loadFile server mimetype path = do
    key <- newAssociation (sFiles server) (path, mimetype)
    return $ "/file/" ++ key

-- | Begin to serve a local directory under a URI.
loadDirectory :: Server -> FilePath -> IO String
loadDirectory server path = do
    key <- newAssociation (sDirs server) (path,"")
    return $ "/dir/" ++ key