module System.Remote.Snap
( startServer
) where
import Control.Applicative ((<$>), (<|>))
import Control.Exception (throwIO)
import Control.Monad (join, unless)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson.Types as A
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.HashMap.Strict as M
import Data.IORef (IORef)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.Socket (NameInfoFlag(NI_NUMERICHOST), addrAddress, getAddrInfo,
getNameInfo)
import Paths_ekg (getDataDir)
import Prelude hiding (read)
import Snap.Core (MonadSnap, Request, Snap, finishWith, getHeaders, getRequest,
getResponse, method, Method(GET), modifyResponse, pass, route,
rqParams, rqPathInfo, setContentType, setResponseStatus,
writeBS, writeLBS)
import Snap.Http.Server (httpServe)
import qualified Snap.Http.Server.Config as Config
import Snap.Util.FileServe (serveDirectory)
import System.FilePath ((</>))
import System.Remote.Common
getNumericHostAddress :: S.ByteString -> IO S.ByteString
getNumericHostAddress host = do
ais <- getAddrInfo Nothing (Just (S8.unpack host)) Nothing
case ais of
[] -> unsupportedAddressError
(ai:_) -> do
ni <- getNameInfo [NI_NUMERICHOST] True False (addrAddress ai)
case ni of
(Just numericHost, _) -> return $! S8.pack numericHost
_ -> unsupportedAddressError
where
unsupportedAddressError = throwIO $
userError $ "unsupported address: " ++ S8.unpack host
startServer :: IORef Counters -> IORef Gauges -> IORef Labels
-> S.ByteString
-> Int
-> IO ()
startServer counters gauges labels host port = do
numericHost <- getNumericHostAddress host
let conf = Config.setVerbose False $
Config.setErrorLog Config.ConfigNoLog $
Config.setAccessLog Config.ConfigNoLog $
Config.setPort port $
Config.setHostname host $
Config.setBind numericHost $
Config.defaultConfig
httpServe conf (monitor counters gauges labels)
monitor :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
monitor counters gauges labels = do
dataDir <- liftIO getDataDir
route [
("", method GET (format "application/json"
(serveAll counters gauges labels)))
, ("combined", method GET (format "application/json"
(serveCombined counters gauges labels)))
, ("counters", method GET (format "application/json"
(serveMany counters)))
, ("counters/:name", method GET (format "text/plain"
(serveOne counters)))
, ("gauges", method GET (format "application/json"
(serveMany gauges)))
, ("gauges/:name", method GET (format "text/plain"
(serveOne gauges)))
, ("labels", method GET (format "application/json"
(serveMany labels)))
, ("labels/:name", method GET (format "text/plain"
(serveOne labels)))
]
<|> serveDirectory (dataDir </> "assets")
acceptHeader :: Request -> Maybe S.ByteString
acceptHeader req = S.intercalate "," <$> getHeaders "Accept" req
format :: MonadSnap m => S.ByteString -> m a -> m a
format fmt action = do
req <- getRequest
let acceptHdr = (List.head . parseHttpAccept) <$> acceptHeader req
case acceptHdr of
Just hdr | hdr == fmt -> action
_ -> pass
serveMany :: (Ref r t, A.ToJSON t) => IORef (M.HashMap T.Text r) -> Snap ()
serveMany mapRef = do
modifyResponse $ setContentType "application/json"
bs <- liftIO $ buildMany mapRef
writeLBS bs
serveAll :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
serveAll counters gauges labels = do
req <- getRequest
unless (S.null $ rqPathInfo req) pass
modifyResponse $ setContentType "application/json"
bs <- liftIO $ buildAll counters gauges labels
writeLBS bs
serveCombined :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
serveCombined counters gauges labels = do
modifyResponse $ setContentType "application/json"
bs <- liftIO $ buildCombined counters gauges labels
writeLBS bs
serveOne :: (Ref r t, Show t) => IORef (M.HashMap T.Text r) -> Snap ()
serveOne refs = do
modifyResponse $ setContentType "text/plain"
req <- getRequest
let mname = T.decodeUtf8 <$> join
(listToMaybe <$> Map.lookup "name" (rqParams req))
case mname of
Nothing -> pass
Just name -> do
mbs <- liftIO $ buildOne refs name
case mbs of
Just bs -> writeBS bs
Nothing -> do
modifyResponse $ setResponseStatus 404 "Not Found"
r <- getResponse
finishWith r