{-# 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 FilePath
Maybe ByteString
CallBufferMode
ByteString -> IO ()
jsCallBufferMode :: Config -> CallBufferMode
jsWindowReloadOnDisconnect :: Config -> Bool
jsLog :: Config -> ByteString -> IO ()
jsStatic :: Config -> Maybe FilePath
jsCustomHTML :: Config -> Maybe FilePath
jsAddr :: Config -> Maybe ByteString
jsPort :: Config -> Maybe Int
jsCallBufferMode :: CallBufferMode
jsWindowReloadOnDisconnect :: Bool
jsLog :: ByteString -> IO ()
jsStatic :: Maybe FilePath
jsCustomHTML :: Maybe FilePath
jsAddr :: Maybe ByteString
jsPort :: Maybe Int
..} EventLoop
worker = do
    [(FilePath, FilePath)]
env <- IO [(FilePath, FilePath)]
getEnvironment
    let portEnv :: Maybe Int
portEnv = FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
Safe.readMay (FilePath -> Maybe Int) -> Maybe FilePath -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup FilePath
"PORT" [(FilePath, FilePath)]
env
    let addrEnv :: Maybe ByteString
addrEnv = (FilePath -> ByteString) -> Maybe FilePath -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> ByteString
BS.pack (Maybe FilePath -> Maybe ByteString)
-> Maybe FilePath -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup FilePath
"ADDR" [(FilePath, FilePath)]
env
    
    let config :: Config Snap a
config = Int -> Config Snap a -> Config Snap 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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Int
portEnv))
               (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ ByteString -> Config Snap a -> Config Snap 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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ByteString
addrEnv))
               (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.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
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
forall k a. (Integer, Map k a)
newFilepaths IO (MVar Filepaths -> (ByteString -> IO ()) -> Server)
-> IO (MVar Filepaths) -> IO ((ByteString -> IO ()) -> Server)
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
forall k a. (Integer, Map k a)
newFilepaths IO ((ByteString -> IO ()) -> Server)
-> IO (ByteString -> IO ()) -> IO Server
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> IO ()) -> IO (ByteString -> IO ())
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 FilePath -> Maybe FilePath -> [(ByteString, Snap ())]
routeResources Server
server Maybe FilePath
jsCustomHTML Maybe FilePath
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)

-- | Route the communication between JavaScript and the server
routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes
routeWebsockets :: (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 ())
-> (FilePath -> ByteString) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
LBS.pack (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"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  -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                        FilePath
"Foreign.JavaScript: Couldn't parse JSON input"
                        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
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
    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 all :: E.SomeException -> Maybe ()
            all :: SomeException -> Maybe ()
all 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 ()
all (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
$ FilePath -> ByteString
LBS.pack FilePath
"close"

    Comm -> IO Comm
forall (m :: * -> *) a. Monad m => a -> m a
return (Comm -> IO Comm) -> Comm -> IO Comm
forall a b. (a -> b) -> a -> b
$ Comm :: TQueue Value -> TQueue Value -> TVar Bool -> IO () -> Comm
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 FilePath -> Maybe FilePath -> [(ByteString, Snap ())]
routeResources Server
server Maybe FilePath
customHTML Maybe FilePath
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 -> (FilePath -> ByteString -> Snap ()) -> Snap ()
forall a.
MVar Filepaths -> (FilePath -> ByteString -> Snap a) -> Snap a
withFilepath (Server -> MVar Filepaths
sFiles Server
server) ((ByteString -> FilePath -> Snap ())
-> FilePath -> ByteString -> Snap ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> FilePath -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> FilePath -> m ()
serveFileAs))
        ,(ByteString
"/dir/:name"                 ,
            MVar Filepaths -> (FilePath -> ByteString -> Snap ()) -> Snap ()
forall a.
MVar Filepaths -> (FilePath -> ByteString -> Snap a) -> Snap a
withFilepath (Server -> MVar Filepaths
sDirs  Server
server) (\FilePath
path ByteString
_ -> FilePath -> Snap ()
forall (m :: * -> *). MonadSnap m => FilePath -> m ()
serveDirectory FilePath
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
h

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

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

writeTextMime :: 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 :: MVar Filepaths -> (FilePath -> ByteString -> Snap a) -> Snap a
withFilepath MVar Filepaths
rDict FilePath -> 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 (FilePath, FilePath)
dict) <- IO Filepaths -> Snap Filepaths
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 (m :: * -> *) a. Monad m => a -> m a
return
    case (\ByteString
key -> ByteString
-> Map ByteString (FilePath, FilePath)
-> Maybe (FilePath, FilePath)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key Map ByteString (FilePath, FilePath)
dict) (ByteString -> Maybe (FilePath, FilePath))
-> Maybe ByteString -> Maybe (FilePath, FilePath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mName of
        Just (FilePath
path,FilePath
mimetype) -> FilePath -> ByteString -> Snap a
cont FilePath
path (FilePath -> ByteString
BS.pack FilePath
mimetype)
        Maybe (FilePath, FilePath)
Nothing              -> FilePath -> Snap a
forall a. HasCallStack => FilePath -> a
error (FilePath -> Snap a) -> FilePath -> Snap a
forall a b. (a -> b) -> a -> b
$ FilePath
"File not loaded: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> FilePath
forall a. Show a => a -> FilePath
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 -> (FilePath, FilePath) -> IO FilePath
newAssociation MVar Filepaths
rDict (FilePath
path,FilePath
mimetype) = do
    (Integer
old, Map ByteString (FilePath, FilePath)
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 :: FilePath
key = Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
new FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
takeFileName FilePath
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
-> (FilePath, FilePath)
-> Map ByteString (FilePath, FilePath)
-> Map ByteString (FilePath, FilePath)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FilePath -> ByteString
BS.pack FilePath
key) (FilePath
path,FilePath
mimetype) Map ByteString (FilePath, FilePath)
dict)
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
key

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

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