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

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

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

    Config Snap Any -> Snap () -> IO ()
forall a. Config Snap a -> Snap () -> IO ()
Snap.httpServe Config Snap Any
forall {a}. Config Snap a
config (Snap () -> IO ())
-> ([(ByteString, Snap ())] -> Snap ())
-> [(ByteString, Snap ())]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, Snap ())] -> Snap ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route ([(ByteString, Snap ())] -> IO ())
-> [(ByteString, Snap ())] -> IO ()
forall a b. (a -> b) -> a -> b
$
        Server -> Maybe [Char] -> Maybe [Char] -> [(ByteString, Snap ())]
routeResources Server
server Maybe [Char]
jsCustomHTML Maybe [Char]
jsStatic
        [(ByteString, Snap ())]
-> [(ByteString, Snap ())] -> [(ByteString, Snap ())]
forall a. [a] -> [a] -> [a]
++ (RequestInfo -> Comm -> IO ()) -> [(ByteString, Snap ())]
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 = [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
Safe.readMay ([Char] -> Maybe Int) -> Maybe [Char] -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup [Char]
"PORT" [([Char], [Char])]
env
            addrEnv :: Maybe ByteString
addrEnv = ([Char] -> ByteString) -> Maybe [Char] -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ByteString
BS.pack (Maybe [Char] -> Maybe ByteString)
-> Maybe [Char] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup [Char]
"ADDR" [([Char], [Char])]
env
         in Int -> Config m a -> Config m a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
Snap.setPort (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
defaultPort Int -> Int
forall a. a -> a
id (Maybe Int
jsPort Maybe Int -> Maybe Int -> Maybe Int
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Int
portEnv))
                (Config m a -> Config m a) -> Config m a -> Config m a
forall a b. (a -> b) -> a -> b
$ ByteString -> Config m a -> Config m a
forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
Snap.setBind (ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
defaultAddr ByteString -> ByteString
forall a. a -> a
id (Maybe ByteString
jsAddr Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
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 =
        ByteString -> Config m a -> Config m a
forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
Snap.setSSLBind            (ConfigSSL -> ByteString
jsSSLBind ConfigSSL
cfgSsl)
            (Config m a -> Config m a)
-> (Config m a -> Config m a) -> Config m a -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Config m a -> Config m a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
Snap.setSSLPort      (ConfigSSL -> Int
jsSSLPort ConfigSSL
cfgSsl)
            (Config m a -> Config m a)
-> (Config m a -> Config m a) -> Config m a -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Config m a -> Config m a
forall (m :: * -> *) a. [Char] -> Config m a -> Config m a
Snap.setSSLCert      (ConfigSSL -> [Char]
jsSSLCert ConfigSSL
cfgSsl)
            (Config m a -> Config m a)
-> (Config m a -> Config m a) -> Config m a -> Config m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Config m a -> Config m a
forall (m :: * -> *) a. [Char] -> Config m a -> Config m a
Snap.setSSLKey       (ConfigSSL -> [Char]
jsSSLKey ConfigSSL
cfgSsl)
            (Config m a -> Config m a) -> Config m a -> Config m a
forall a b. (a -> b) -> a -> b
$ Bool -> Config m a -> Config m a
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 <- Snap Request
forall (m :: * -> *). MonadSnap m => m Request
Snap.getRequest
        ServerApp -> Snap ()
forall (m :: * -> *). MonadSnap m => ServerApp -> m ()
WS.runWebSocketsSnap (ServerApp -> Snap ()) -> ServerApp -> Snap ()
forall a b. (a -> b) -> a -> b
$ \PendingConnection
ws -> IO void -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO void -> IO ()) -> IO void -> IO ()
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     <- IO (TQueue Value)
forall a. IO (TQueue a)
STM.newTQueueIO   -- outgoing communication
    TQueue Value
commOut    <- IO (TQueue Value)
forall a. IO (TQueue a)
STM.newTQueueIO   -- incoming communication
    TVar Bool
commOpen   <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
STM.newTVarIO Bool
True

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

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

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

    -- explicitly close the Comm chanenl
    let commClose :: IO ()
commClose = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
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
    ThreadId
_ <- IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IO Any
forall {b}. IO b
sendData IO Any -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
`race_` IO Any
forall {b}. IO b
readData IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
`race_` IO ()
sentry) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
_ -> IO (Either () ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
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 allExceptions :: E.SomeException -> Maybe ()
            allExceptions :: SomeException -> Maybe ()
allExceptions SomeException
_ = () -> Maybe ()
forall a. a -> Maybe a
Just ()
        (SomeException -> Maybe ()) -> IO () -> IO (Either () ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
E.tryJust SomeException -> Maybe ()
allExceptions (IO () -> IO (Either () ())) -> IO () -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendClose Connection
connection (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
LBS.pack [Char]
"close"

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

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

    static :: [(ByteString, Snap ())]
static = [(ByteString, Snap ())]
-> ([Char] -> [(ByteString, Snap ())])
-> Maybe [Char]
-> [(ByteString, Snap ())]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\[Char]
dir -> [(ByteString
"/static", [Char] -> Snap ()
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 -> [Char] -> Snap ()
forall (m :: * -> *). MonadSnap m => [Char] -> m ()
serveFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
file)
            Maybe [Char]
Nothing  -> ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
logError ByteString
"Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic"
        Maybe [Char]
Nothing   -> Text -> ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => Text -> ByteString -> m ()
writeTextMime Text
defaultHtmlFile ByteString
"text/html"

writeTextMime :: MonadSnap m => Text -> ByteString -> m ()
writeTextMime :: forall (m :: * -> *). MonadSnap m => Text -> ByteString -> m ()
writeTextMime Text
text ByteString
mime = do
    (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse (CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Content-type" ByteString
mime)
    Text -> m ()
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    <- ByteString -> Snap (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam ByteString
"name"
    (Integer
_,Map ByteString ([Char], [Char])
dict) <- IO Filepaths -> Snap Filepaths
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Filepaths -> Snap Filepaths) -> IO Filepaths -> Snap Filepaths
forall a b. (a -> b) -> a -> b
$ MVar Filepaths -> (Filepaths -> IO Filepaths) -> IO Filepaths
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Filepaths
rDict Filepaths -> IO Filepaths
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    case (\ByteString
key -> ByteString
-> Map ByteString ([Char], [Char]) -> Maybe ([Char], [Char])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key Map ByteString ([Char], [Char])
dict) (ByteString -> Maybe ([Char], [Char]))
-> Maybe ByteString -> Maybe ([Char], [Char])
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              -> [Char] -> Snap a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Snap a) -> [Char] -> Snap a
forall a b. (a -> b) -> a -> b
$ [Char]
"File not loaded: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> [Char]
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) <- MVar Filepaths -> IO Filepaths
forall a. MVar a -> IO a
takeMVar MVar Filepaths
rDict
    let new :: Integer
new = Integer
old Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1; key :: [Char]
key = Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
new [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
takeFileName [Char]
path
    MVar Filepaths -> Filepaths -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Filepaths
rDict (Filepaths -> IO ()) -> Filepaths -> IO ()
forall a b. (a -> b) -> a -> b
$ (Integer
new, ByteString
-> ([Char], [Char])
-> Map ByteString ([Char], [Char])
-> Map ByteString ([Char], [Char])
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)
    [Char] -> IO [Char]
forall a. a -> IO a
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)
    [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"/file/" [Char] -> [Char] -> [Char]
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]
"")
    [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"/dir/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
key