2013-01-03 09:17:10 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
|
|
|
|
module System.Remote.Snap
|
|
|
|
( startServer
|
|
|
|
) where
|
2013-02-22 17:45:19 +00:00
|
|
|
|
2013-01-03 09:17:10 +00:00
|
|
|
import Control.Applicative ((<$>), (<|>))
|
2013-02-22 00:50:42 +00:00
|
|
|
import Control.Exception (throwIO)
|
2013-01-03 09:17:10 +00:00
|
|
|
import Control.Monad (join, unless)
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import qualified Data.Aeson.Types as A
|
|
|
|
import qualified Data.ByteString as S
|
2013-02-22 00:50:42 +00:00
|
|
|
import qualified Data.ByteString.Char8 as S8
|
2013-11-05 19:52:45 +00:00
|
|
|
import Data.Function (on)
|
2013-01-03 09:17:10 +00:00
|
|
|
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
|
2013-11-05 19:52:45 +00:00
|
|
|
import Data.Word (Word8)
|
2013-02-22 00:50:42 +00:00
|
|
|
import Network.Socket (NameInfoFlag(NI_NUMERICHOST), addrAddress, getAddrInfo,
|
|
|
|
getNameInfo)
|
2013-01-03 09:17:10 +00:00
|
|
|
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
|
|
|
|
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
|
2013-02-22 00:50:42 +00:00
|
|
|
-- | Convert a host name (e.g. \"localhost\" or \"127.0.0.1\") to a
|
|
|
|
-- numeric host address (e.g. \"127.0.0.1\").
|
|
|
|
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
|
|
|
|
|
2013-01-03 09:17:10 +00:00
|
|
|
startServer :: IORef Counters -> IORef Gauges -> IORef Labels
|
|
|
|
-> S.ByteString -- ^ Host to listen on (e.g. \"localhost\")
|
|
|
|
-> Int -- ^ Port to listen on (e.g. 8000)
|
|
|
|
-> IO ()
|
2013-02-22 00:50:42 +00:00
|
|
|
startServer counters gauges labels host port = do
|
|
|
|
-- Snap doesn't allow for non-numeric host names in
|
|
|
|
-- 'Snap.setBind'. We work around that limitation by converting a
|
|
|
|
-- possible non-numeric host name to a numeric address.
|
|
|
|
numericHost <- getNumericHostAddress host
|
|
|
|
let conf = Config.setVerbose False $
|
2013-01-03 09:17:10 +00:00
|
|
|
Config.setErrorLog Config.ConfigNoLog $
|
|
|
|
Config.setAccessLog Config.ConfigNoLog $
|
|
|
|
Config.setPort port $
|
|
|
|
Config.setHostname host $
|
2013-02-22 00:50:42 +00:00
|
|
|
Config.setBind numericHost $
|
2013-01-03 09:17:10 +00:00
|
|
|
Config.defaultConfig
|
2013-02-22 00:50:42 +00:00
|
|
|
httpServe conf (monitor counters gauges labels)
|
2013-01-03 09:17:10 +00:00
|
|
|
|
2013-04-10 06:54:14 +00:00
|
|
|
-- | The routes of the ekg monitor. They do not include the routes for its
|
|
|
|
-- assets.
|
|
|
|
monitorRoutes :: MonadSnap m
|
|
|
|
=> IORef Counters -> IORef Gauges -> IORef Labels
|
|
|
|
-> [(S8.ByteString, m ())]
|
|
|
|
monitorRoutes counters gauges labels =
|
|
|
|
[ ("", jsonHandler $ serveAll counters gauges labels)
|
|
|
|
, ("combined", jsonHandler $ serveCombined counters gauges labels)
|
|
|
|
, ("counters", jsonHandler $ serveMany counters)
|
|
|
|
, ("counters/:name", textHandler $ serveOne counters)
|
|
|
|
, ("gauges", jsonHandler $ serveMany gauges)
|
|
|
|
, ("gauges/:name", textHandler $ serveOne gauges)
|
|
|
|
, ("labels", jsonHandler $ serveMany labels)
|
|
|
|
, ("labels/:name", textHandler $ serveOne labels)
|
|
|
|
]
|
|
|
|
where
|
|
|
|
jsonHandler = wrapHandler "application/json"
|
|
|
|
textHandler = wrapHandler "text/plain"
|
|
|
|
wrapHandler fmt handler = method GET $ format fmt $ do
|
|
|
|
req <- getRequest
|
|
|
|
-- We only want to handle completely matched paths.
|
|
|
|
if S.null (rqPathInfo req) then handler else pass
|
|
|
|
|
2013-01-03 09:17:10 +00:00
|
|
|
-- | A handler that can be installed into an existing Snap application.
|
|
|
|
monitor :: IORef Counters -> IORef Gauges -> IORef Labels -> Snap ()
|
|
|
|
monitor counters gauges labels = do
|
|
|
|
dataDir <- liftIO getDataDir
|
2013-04-10 06:54:14 +00:00
|
|
|
route (monitorRoutes counters gauges labels)
|
2013-01-03 09:17:10 +00:00
|
|
|
<|> serveDirectory (dataDir </> "assets")
|
|
|
|
|
|
|
|
-- | The Accept header of the request.
|
|
|
|
acceptHeader :: Request -> Maybe S.ByteString
|
|
|
|
acceptHeader req = S.intercalate "," <$> getHeaders "Accept" req
|
|
|
|
|
|
|
|
-- | Runs a Snap monad action only if the request's Accept header
|
|
|
|
-- matches the given MIME type.
|
|
|
|
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
|
|
|
|
|
|
|
|
-- | Serve a collection of counters or gauges, as a JSON object.
|
2013-04-10 06:54:14 +00:00
|
|
|
serveMany :: (Ref r t, A.ToJSON t, MonadSnap m)
|
|
|
|
=> IORef (M.HashMap T.Text r) -> m ()
|
2013-01-03 09:17:10 +00:00
|
|
|
serveMany mapRef = do
|
|
|
|
modifyResponse $ setContentType "application/json"
|
|
|
|
bs <- liftIO $ buildMany mapRef
|
|
|
|
writeLBS bs
|
|
|
|
{-# INLINABLE serveMany #-}
|
|
|
|
|
|
|
|
-- | Serve all counter, gauges and labels, built-in or not, as a
|
|
|
|
-- nested JSON object.
|
2013-04-10 06:54:14 +00:00
|
|
|
serveAll :: MonadSnap m
|
|
|
|
=> IORef Counters -> IORef Gauges -> IORef Labels -> m ()
|
2013-01-03 09:17:10 +00:00
|
|
|
serveAll counters gauges labels = do
|
|
|
|
req <- getRequest
|
|
|
|
-- Workaround: Snap still matches requests to /foo to this handler
|
|
|
|
-- if the Accept header is "application/json", even though such
|
|
|
|
-- requests ought to go to the 'serveOne' handler.
|
|
|
|
unless (S.null $ rqPathInfo req) pass
|
|
|
|
modifyResponse $ setContentType "application/json"
|
|
|
|
bs <- liftIO $ buildAll counters gauges labels
|
|
|
|
writeLBS bs
|
|
|
|
|
|
|
|
-- | Serve all counters and gauges, built-in or not, as a flattened
|
|
|
|
-- JSON object.
|
2013-04-10 06:54:14 +00:00
|
|
|
serveCombined :: MonadSnap m
|
|
|
|
=> IORef Counters -> IORef Gauges -> IORef Labels -> m ()
|
2013-01-03 09:17:10 +00:00
|
|
|
serveCombined counters gauges labels = do
|
|
|
|
modifyResponse $ setContentType "application/json"
|
|
|
|
bs <- liftIO $ buildCombined counters gauges labels
|
|
|
|
writeLBS bs
|
|
|
|
|
|
|
|
-- | Serve a single counter, as plain text.
|
2013-04-10 06:54:14 +00:00
|
|
|
serveOne :: (Ref r t, Show t, MonadSnap m)
|
|
|
|
=> IORef (M.HashMap T.Text r) -> m ()
|
2013-01-03 09:17:10 +00:00
|
|
|
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
|
|
|
|
{-# INLINABLE serveOne #-}
|
2013-11-05 19:52:45 +00:00
|
|
|
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
-- Utilities for working with accept headers
|
|
|
|
|
|
|
|
-- | Parse the HTTP accept string to determine supported content types.
|
|
|
|
parseHttpAccept :: S.ByteString -> [S.ByteString]
|
|
|
|
parseHttpAccept = List.map fst
|
|
|
|
. List.sortBy (rcompare `on` snd)
|
|
|
|
. List.map grabQ
|
|
|
|
. S.split 44 -- comma
|
|
|
|
where
|
|
|
|
rcompare :: Double -> Double -> Ordering
|
|
|
|
rcompare = flip compare
|
|
|
|
grabQ s =
|
|
|
|
let (s', q) = breakDiscard 59 s -- semicolon
|
|
|
|
(_, q') = breakDiscard 61 q -- equals sign
|
|
|
|
in (trimWhite s', readQ $ trimWhite q')
|
|
|
|
readQ s = case reads $ S8.unpack s of
|
|
|
|
(x, _):_ -> x
|
|
|
|
_ -> 1.0
|
|
|
|
trimWhite = S.dropWhile (== 32) -- space
|
|
|
|
|
|
|
|
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
|
|
|
|
breakDiscard w s =
|
|
|
|
let (x, y) = S.break (== w) s
|
2013-11-05 20:07:14 +00:00
|
|
|
in (x, S.drop 1 y)
|