diff --git a/System/Remote/Snap.hs b/System/Remote/Snap.hs index 0242cd7..3bc0244 100644 --- a/System/Remote/Snap.hs +++ b/System/Remote/Snap.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module System.Remote.Snap ( startServer @@ -9,6 +10,7 @@ import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import Data.Maybe (fromMaybe) import Data.Function (on) import qualified Data.HashMap.Strict as M import qualified Data.List as List @@ -16,19 +18,21 @@ import qualified Data.Text.Encoding as T import Data.Word (Word8) import Network.Socket (NameInfoFlag(NI_NUMERICHOST), addrAddress, getAddrInfo, getNameInfo) -import Paths_ekg (getDataDir) import Prelude hiding (read) import Snap.Core (MonadSnap, Request, Snap, finishWith, getHeader, getRequest, getResponse, method, Method(GET), modifyResponse, pass, - rqPathInfo, setContentType, setResponseStatus, - writeLBS) + rqURI, rqPathInfo, + setContentType, setContentLength, setResponseStatus, setResponseCode, + writeBS, writeLBS) import Snap.Http.Server (httpServe) import qualified Snap.Http.Server.Config as Config -import Snap.Util.FileServe (serveDirectory) -import System.FilePath (()) +import Snap.Util.FileServe (defaultMimeTypes) +import System.FilePath (takeExtension) import System.Metrics import System.Remote.Json +import Data.FileEmbed (embedDir) + ------------------------------------------------------------------------ @@ -72,9 +76,9 @@ startServer store m_host port = do -- | A handler that can be installed into an existing Snap application. monitor :: Store -> Snap () monitor store = do - dataDir <- liftIO getDataDir (jsonHandler $ serve store) - <|> serveDirectory (dataDir "assets") + <|> + serveAssets where jsonHandler = wrapHandler "application/json" wrapHandler fmt handler = method GET $ format fmt $ handler @@ -145,3 +149,32 @@ breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s = let (x, y) = S.break (== w) s in (x, S.drop 1 y) + +-- | Serve the embedded assets. +serveAssets :: MonadSnap m => m () +serveAssets = serveEmbeddedFiles $(embedDir "assets") + +-- | Serve a list of files under the given filepaths while selecting the MIME +--type using the 'defaultMimeMap'. +serveEmbeddedFiles :: MonadSnap m => [(FilePath, S8.ByteString)] -> m () +serveEmbeddedFiles files = do + req <- getRequest + fromMaybe pass $ M.lookup (rqURI req) table + where + table = M.fromList $ do + (path, content) <- files + let err = error $ "Failed to determine MIME type of '" ++ path ++ "'" + mime = fromMaybe err $ + M.lookup (takeExtension path) defaultMimeTypes + response = do + modifyResponse $ + setContentType mime . + setContentLength (fromIntegral $ S8.length content) . + setResponseCode 200 + writeBS content + path' <- + map S8.pack $ + if path == "index.html" || path == "index.htm" + then ["/", "/index.html", "/index.htm"] + else ["/" ++ path] + return (path', response) diff --git a/ekg.cabal b/ekg.cabal index 42b7b6c..ff2ed26 100644 --- a/ekg.cabal +++ b/ekg.cabal @@ -15,14 +15,14 @@ maintainer: Johan Tibell , Mikhail Glushenkov category: System, Network build-type: Simple -data-files: assets/index.html assets/monitor.js assets/monitor.css - assets/jquery.flot.min.js assets/jquery-1.6.4.min.js - assets/bootstrap-1.4.0.min.css - assets/chart_line_add.png assets/cross.png extra-source-files: LICENSE.icons LICENSE.javascript README.md assets/jquery-1.6.4.js assets/jquery.flot.js assets/bootstrap-1.4.0.css examples/Basic.hs CHANGES.md + assets/index.html assets/monitor.js assets/monitor.css + assets/jquery.flot.min.js assets/jquery-1.6.4.min.js + assets/bootstrap-1.4.0.min.css + assets/chart_line_add.png assets/cross.png tested-with: GHC == 8.6.5, GHC == 8.4.4, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3, GHC == 7.8.4, GHC == 7.6.3 @@ -35,7 +35,6 @@ library System.Remote.Monitoring other-modules: - Paths_ekg System.Remote.Json System.Remote.Snap @@ -45,12 +44,13 @@ library bytestring < 1.0, ekg-core >= 0.1 && < 0.2, ekg-json >= 0.1 && < 0.2, + file-embed == 0.0.*, filepath < 1.5, network < 3.2, snap-core < 1.1, snap-server < 1.2, text < 1.3, - time < 1.9, + time < 1.10, transformers < 0.6, unordered-containers < 0.3