{-# 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 -> 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)
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
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
TQueue Value
commOut <- IO (TQueue Value)
forall a. IO (TQueue a)
STM.newTQueueIO
TVar Bool
commOpen <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
STM.newTVarIO Bool
True
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
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
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
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
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
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
IO ()
commClose
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
..}
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
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
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
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
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