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

-- import general libraries
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 web libraries
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 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 -> EventLoop -> IO ()
httpComm Config{Bool
Maybe Int
Maybe [Char]
Maybe ByteString
Maybe ConfigSSL
CallBufferMode
ByteString -> IO ()
jsUseSSL :: Config -> Maybe ConfigSSL
jsCallBufferMode :: Config -> CallBufferMode
jsWindowReloadOnDisconnect :: Config -> Bool
jsLog :: Config -> ByteString -> IO ()
jsStatic :: Config -> Maybe [Char]
jsCustomHTML :: Config -> Maybe [Char]
jsAddr :: Config -> Maybe ByteString
jsPort :: Config -> Maybe Int
jsUseSSL :: Maybe ConfigSSL
jsCallBufferMode :: CallBufferMode
jsWindowReloadOnDisconnect :: Bool
jsLog :: ByteString -> IO ()
jsStatic :: Maybe [Char]
jsCustomHTML :: Maybe [Char]
jsAddr :: Maybe ByteString
jsPort :: Maybe Int
..} EventLoop
worker = do
    [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment

    let config :: Config Snap a
config = forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
Snap.setErrorLog     ((ByteString -> IO ()) -> ConfigLog
Snap.ConfigIoLog ByteString -> IO ()
jsLog)
               forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
Snap.setAccessLog    ((ByteString -> IO ()) -> ConfigLog
Snap.ConfigIoLog ByteString -> IO ()
jsLog)
               forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
[([Char], [Char])] -> Config m a -> Config m a
configureHTTP [([Char], [Char])]
env) forall (m :: * -> *) a. ConfigSSL -> Config m a -> Config m a
configureSSL Maybe ConfigSSL
jsUseSSL
               forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSnap m => Config m a
Snap.defaultConfig

    Server
server <- MVar Filepaths -> MVar Filepaths -> (ByteString -> IO ()) -> Server
Server forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar forall {k} {a}. (Integer, Map k a)
newFilepaths forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar forall {k} {a}. (Integer, Map k a)
newFilepaths forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString -> IO ()
jsLog

    forall a. Config Snap a -> Snap () -> IO ()
Snap.httpServe forall {a}. Config Snap a
config forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route forall a b. (a -> b) -> a -> b
$
        Server -> Maybe [Char] -> Maybe [Char] -> [(ByteString, Snap ())]
routeResources Server
server Maybe [Char]
jsCustomHTML Maybe [Char]
jsStatic
        forall a. [a] -> [a] -> [a]
++ forall void.
(RequestInfo -> Comm -> IO void) -> [(ByteString, Snap ())]
routeWebsockets (EventLoop
worker Server
server)

    where
    configureHTTP :: [(String, String)] -> Snap.Config m a -> Snap.Config m a
    configureHTTP :: forall (m :: * -> *) a.
[([Char], [Char])] -> Config m a -> Config m a
configureHTTP [([Char], [Char])]
env Config m a
config =
        let portEnv :: Maybe Int
portEnv = forall a. Read a => [Char] -> Maybe a
Safe.readMay forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup [Char]
"PORT" [([Char], [Char])]
env
            addrEnv :: Maybe ByteString
addrEnv = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup [Char]
"ADDR" [([Char], [Char])]
env
         in forall (m :: * -> *) a. Int -> Config m a -> Config m a
Snap.setPort (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
defaultPort forall a. a -> a
id (Maybe Int
jsPort forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Int
portEnv))
                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
Snap.setBind (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
defaultAddr forall a. a -> a
id (Maybe ByteString
jsAddr forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ByteString
addrEnv)) Config m a
config

    configureSSL :: ConfigSSL -> Snap.Config m a -> Snap.Config m a
    configureSSL :: forall (m :: * -> *) a. ConfigSSL -> Config m a -> Config m a
configureSSL ConfigSSL
cfgSsl Config m a
config =
        forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
Snap.setSSLBind            (ConfigSSL -> ByteString
jsSSLBind ConfigSSL
cfgSsl)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Int -> Config m a -> Config m a
Snap.setSSLPort      (ConfigSSL -> Int
jsSSLPort ConfigSSL
cfgSsl)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. [Char] -> Config m a -> Config m a
Snap.setSSLCert      (ConfigSSL -> [Char]
jsSSLCert ConfigSSL
cfgSsl)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. [Char] -> Config m a -> Config m a
Snap.setSSLKey       (ConfigSSL -> [Char]
jsSSLKey ConfigSSL
cfgSsl)
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Bool -> Config m a -> Config m a
Snap.setSSLChainCert (ConfigSSL -> Bool
jsSSLChainCert ConfigSSL
cfgSsl) Config m a
config

-- | Route the communication between JavaScript and the server
routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes
routeWebsockets :: forall void.
(RequestInfo -> Comm -> IO void) -> [(ByteString, Snap ())]
routeWebsockets RequestInfo -> Comm -> IO void
worker = [(ByteString
"websocket", Snap ()
response)]
    where
    response :: Snap ()
response = do
        Request
requestInfo <- forall (m :: * -> *). MonadSnap m => m Request
Snap.getRequest
        forall (m :: * -> *). MonadSnap m => ServerApp -> m ()
WS.runWebSocketsSnap forall a b. (a -> b) -> a -> b
$ \PendingConnection
ws -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
            Comm
comm <- PendingConnection -> IO Comm
communicationFromWebSocket PendingConnection
ws
            RequestInfo -> Comm -> IO void
worker (Request -> RequestInfo
rqCookies Request
requestInfo) Comm
comm
            -- error "Foreign.JavaScript: unreachable code path."

-- | Create 'Comm' channel from WebSocket request.
communicationFromWebSocket :: WS.PendingConnection -> IO Comm
communicationFromWebSocket :: PendingConnection -> IO Comm
communicationFromWebSocket PendingConnection
request = do
    Connection
connection <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
request
    TQueue Value
commIn     <- forall a. IO (TQueue a)
STM.newTQueueIO   -- outgoing communication
    TQueue Value
commOut    <- forall a. IO (TQueue a)
STM.newTQueueIO   -- incoming communication
    TVar Bool
commOpen   <- forall a. a -> IO (TVar a)
STM.newTVarIO Bool
True

    -- write data to browser
    let sendData :: IO b
sendData = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            Value
x <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM a
STM.readTQueue TQueue Value
commOut
            -- see note [ServerMsg strictness]
            forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
connection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
JSON.encode forall a b. (a -> b) -> a -> b
$ Value
x

    -- read data from browser
    let readData :: IO b
readData = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            ByteString
input <- forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
connection
            case ByteString
input of
                ByteString
"ping" -> forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
connection forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$ [Char]
"pong"
                ByteString
"quit" -> forall e a. Exception e => e -> IO a
E.throwIO ConnectionException
WS.ConnectionClosed
                ByteString
input  -> case forall a. FromJSON a => ByteString -> Maybe a
JSON.decode ByteString
input of
                    Just Value
x   -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue Value
commIn Value
x
                    Maybe Value
Nothing  -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                        [Char]
"Foreign.JavaScript: Couldn't parse JSON input"
                        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
input

    -- block until the channel is closed
    let sentry :: IO ()
sentry = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            Bool
open <- forall a. TVar a -> STM a
STM.readTVar TVar Bool
commOpen
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
open forall a. STM a
retry

    -- explicitly close the Comm chanenl
    let commClose :: IO ()
commClose = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Bool
commOpen Bool
False

    -- read/write data until an exception occurs or the channel is no longer open
    forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall {b}. IO b
sendData forall a b. IO a -> IO b -> IO ()
`race_` forall {b}. IO b
readData forall a b. IO a -> IO b -> IO ()
`race_` IO ()
sentry) forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
        -- close the communication channel explicitly if that didn't happen yet
        IO ()
commClose

        -- attempt to close websocket if still necessary/possible
        -- ignore any exceptions that may happen if it's already closed
        let all :: E.SomeException -> Maybe ()
            all :: SomeException -> Maybe ()
all SomeException
_ = forall a. a -> Maybe a
Just ()
        forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
E.tryJust SomeException -> Maybe ()
all forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
connection forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
LBS.pack [Char]
"close"

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Comm {IO ()
TVar Bool
TQueue Value
commClose :: IO ()
commOpen :: TVar Bool
commOut :: TQueue Value
commIn :: TQueue Value
commClose :: IO ()
commOpen :: TVar Bool
commOut :: TQueue Value
commIn :: TQueue Value
..}

{-----------------------------------------------------------------------------
    Resources
------------------------------------------------------------------------------}
type Routes = [(ByteString, Snap ())]

routeResources :: Server -> Maybe FilePath -> Maybe FilePath -> Routes
routeResources :: Server -> Maybe [Char] -> Maybe [Char] -> [(ByteString, Snap ())]
routeResources Server
server Maybe [Char]
customHTML Maybe [Char]
staticDir =
    forall {t} {b} {a}. (t -> b) -> [(a, t)] -> [(a, b)]
fixHandlers forall {m :: * -> *} {b}. MonadSnap m => m b -> m b
noCache forall a b. (a -> b) -> a -> b
$
        [(ByteString, Snap ())]
static forall a. [a] -> [a] -> [a]
++
        [(ByteString
"/"            , Snap ()
root)
        ,(ByteString
"/haskell.js"  , forall {m :: * -> *}. MonadSnap m => Text -> ByteString -> m ()
writeTextMime Text
jsDriverCode  ByteString
"application/javascript")
        ,(ByteString
"/haskell.css" , forall {m :: * -> *}. MonadSnap m => Text -> ByteString -> m ()
writeTextMime Text
cssDriverCode ByteString
"text/css")
        ,(ByteString
"/file/:name"                ,
            forall a.
MVar Filepaths -> ([Char] -> ByteString -> Snap a) -> Snap a
withFilepath (Server -> MVar Filepaths
sFiles Server
server) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). MonadSnap m => ByteString -> [Char] -> m ()
serveFileAs))
        ,(ByteString
"/dir/:name"                 ,
            forall a.
MVar Filepaths -> ([Char] -> ByteString -> Snap a) -> Snap a
withFilepath (Server -> MVar Filepaths
sDirs  Server
server) (\[Char]
path ByteString
_ -> forall (m :: * -> *). MonadSnap m => [Char] -> m ()
serveDirectory [Char]
path))
        ]
    where
    fixHandlers :: (t -> b) -> [(a, t)] -> [(a, b)]
fixHandlers t -> b
f [(a, t)]
routes = [(a
a,t -> b
f t
b) | (a
a,t
b) <- [(a, t)]
routes]
    noCache :: m b -> m b
noCache m b
h = forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Cache-Control" ByteString
"no-cache") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
h

    static :: [(ByteString, Snap ())]
static = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Char]
dir -> [(ByteString
"/static", forall (m :: * -> *). MonadSnap m => [Char] -> m ()
serveDirectory [Char]
dir)]) Maybe [Char]
staticDir

    root :: Snap ()
root = case Maybe [Char]
customHTML of
        Just [Char]
file -> case Maybe [Char]
staticDir of
            Just [Char]
dir -> forall (m :: * -> *). MonadSnap m => [Char] -> m ()
serveFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
file)
            Maybe [Char]
Nothing  -> forall (m :: * -> *). MonadSnap m => ByteString -> m ()
logError ByteString
"Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic"
        Maybe [Char]
Nothing   -> forall {m :: * -> *}. MonadSnap m => Text -> ByteString -> m ()
writeTextMime Text
defaultHtmlFile ByteString
"text/html"

writeTextMime :: Text -> ByteString -> m ()
writeTextMime Text
text ByteString
mime = do
    forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse (forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Content-type" ByteString
mime)
    forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText Text
text

-- | Extract  from a URI
withFilepath :: MVar Filepaths -> (FilePath -> ByteString -> Snap a) -> Snap a
withFilepath :: forall a.
MVar Filepaths -> ([Char] -> ByteString -> Snap a) -> Snap a
withFilepath MVar Filepaths
rDict [Char] -> ByteString -> Snap a
cont = do
    Maybe ByteString
mName    <- forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
"name"
    (Integer
_,Map ByteString ([Char], [Char])
dict) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Filepaths
rDict forall (m :: * -> *) a. Monad m => a -> m a
return
    case (\ByteString
key -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key Map ByteString ([Char], [Char])
dict) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mName of
        Just ([Char]
path,[Char]
mimetype) -> [Char] -> ByteString -> Snap a
cont [Char]
path ([Char] -> ByteString
BS.pack [Char]
mimetype)
        Maybe ([Char], [Char])
Nothing              -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"File not loaded: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe ByteString
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 :: MVar Filepaths -> ([Char], [Char]) -> IO [Char]
newAssociation MVar Filepaths
rDict ([Char]
path,[Char]
mimetype) = do
    (Integer
old, Map ByteString ([Char], [Char])
dict) <- forall a. MVar a -> IO a
takeMVar MVar Filepaths
rDict
    let new :: Integer
new = Integer
old forall a. Num a => a -> a -> a
+ Integer
1; key :: [Char]
key = forall a. Show a => a -> [Char]
show Integer
new forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
takeFileName [Char]
path
    forall a. MVar a -> a -> IO ()
putMVar MVar Filepaths
rDict forall a b. (a -> b) -> a -> b
$ (Integer
new, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ([Char] -> ByteString
BS.pack [Char]
key) ([Char]
path,[Char]
mimetype) Map ByteString ([Char], [Char])
dict)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
key

-- | Begin to serve a local file with a given 'MimeType' under a URI.
loadFile :: Server -> MimeType -> FilePath -> IO String
loadFile :: Server -> [Char] -> [Char] -> IO [Char]
loadFile Server
server [Char]
mimetype [Char]
path = do
    [Char]
key <- MVar Filepaths -> ([Char], [Char]) -> IO [Char]
newAssociation (Server -> MVar Filepaths
sFiles Server
server) ([Char]
path, [Char]
mimetype)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"/file/" forall a. [a] -> [a] -> [a]
++ [Char]
key

-- | Begin to serve a local directory under a URI.
loadDirectory :: Server -> FilePath -> IO String
loadDirectory :: Server -> [Char] -> IO [Char]
loadDirectory Server
server [Char]
path = do
    [Char]
key <- MVar Filepaths -> ([Char], [Char]) -> IO [Char]
newAssociation (Server -> MVar Filepaths
sDirs Server
server) ([Char]
path,[Char]
"")
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
"/dir/" forall a. [a] -> [a] -> [a]
++ [Char]
key