Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add webserver-0.6 backend

  • Loading branch information...
commit 85ce8d3fd1eb14ae7577808e3663356c64530d3c 1 parent 1bf1084
@kfish authored
Showing with 133 additions and 3 deletions.
  1. +4 −0 System/Remote/Monitoring.hs
  2. +108 −0 System/Remote/WebServer.hs
  3. +21 −3 ekg.cabal
View
4 System/Remote/Monitoring.hs
@@ -45,7 +45,11 @@ import Prelude hiding (read)
import System.Remote.Common
+#ifdef USE_SNAP
import System.Remote.Snap
+#else
+import System.Remote.WebServer
+#endif
-- $configuration
--
View
108 System/Remote/WebServer.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module System.Remote.WebServer
+ ( startServer
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson.Types
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+import Data.Char (chr)
+import qualified Data.HashMap.Strict as M
+import Data.IORef (IORef)
+import qualified Data.Text as T
+import Paths_ekg (getDataDir)
+import Prelude hiding (read)
+import Network.Web.HTTP
+import Network.Web.Server.Basic
+import Network.Web.URI
+import System.FilePath ((</>))
+
+import System.Remote.Common
+
+------------------------------------------------------------------------
+
+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 ()
+startServer counters gauges labels host port = do
+ dataDir <- liftIO getDataDir
+ serveHTTP Nothing port host (routes dataDir counters gauges labels)
+
+------------------------------------------------------------------------
+
+routes :: FilePath -> IORef Counters -> IORef Gauges -> IORef Labels
+ -> Request -> Path
+routes dataDir counters gauges labels req =
+ maybe (File (ekgAsset . ix $ path))
+ Handler (getPath counters gauges labels req)
+ where
+ path = S8.unpack (uriPath (reqURI req))
+ ix "/" = "/index.html"
+ ix x = x
+ ekgAsset x = dataDir </> "assets" ++ x
+
+------------------------------------------------------------------------
+
+ctJSON :: CT
+ctJSON = "application/json"
+
+ctText :: CT
+ctText = "text/plain"
+
+getPath :: IORef Counters -> IORef Gauges -> IORef Labels
+ -> Request -> Maybe (IO Response)
+getPath counters gauges labels req
+ | j && S.null p = Just (getAll counters gauges labels)
+ | prefix == "combined" = Just (getCombined counters gauges labels mname)
+ | prefix == "counters" = Just (getRef counters mname)
+ | prefix == "gauges" = Just (getRef gauges mname)
+ | prefix == "labels" = Just (getRef labels mname)
+ | otherwise = Nothing
+ where
+ j = acceptCT ctJSON req
+ p = S.drop 1 $ uriPath (reqURI req)
+ (prefix, mname) = splitAPI (toText p)
+ toText = T.pack . map (chr . fromIntegral) . S.unpack
+
+acceptCT :: Comm a => CT -> a -> Bool
+acceptCT ct = maybe False (S.isInfixOf ct) . lookupField FkAccept
+
+splitAPI :: T.Text -> (T.Text, Maybe T.Text)
+splitAPI path = f components
+ where
+ f [] = ("", Nothing)
+ f [prefix] = (prefix, Nothing)
+ f (prefix:name:_) = (prefix, Just name)
+ components = T.split (=='/') path
+
+contentResponse :: CT -> L.ByteString -> Response
+contentResponse ct bs = makeResponse2 OK (Just bs) (Just len) [(FkContentType, ct)]
+ where
+ len = fromIntegral $ L.length bs
+
+notFoundResponse :: Response
+notFoundResponse = makeResponse NotFound []
+
+getAll :: IORef Counters -> IORef Gauges -> IORef Labels -> IO Response
+getAll counters gauges labels =
+ contentResponse ctJSON <$> buildAll counters gauges labels
+
+getCombined :: IORef Counters -> IORef Gauges -> IORef Labels
+ -> Maybe T.Text -> IO Response
+getCombined _ _ _ (Just _) = return notFoundResponse
+getCombined counters gauges labels Nothing =
+ contentResponse ctJSON <$> buildCombined counters gauges labels
+
+getRef :: (Ref r t, Show t, ToJSON t) => IORef (M.HashMap T.Text r)
+ -> Maybe T.Text -> IO Response
+getRef refs Nothing = contentResponse ctJSON <$> buildMany refs
+getRef refs (Just name) = do
+ mbs <- buildOne refs name
+ case mbs of
+ Just bs -> return $ contentResponse ctText (L.fromChunks [bs])
+ Nothing -> return notFoundResponse
View
24 ekg.cabal
@@ -21,6 +21,10 @@ extra-source-files: LICENSE.icons LICENSE.javascript README.md
assets/jquery-1.6.4.js assets/jquery.flot.js
examples/Basic.hs
+flag useSnap
+ default: False
+ description: Build against Snap
+
library
exposed-modules: System.Remote.Counter
System.Remote.Gauge
@@ -32,19 +36,33 @@ library
System.Remote.Counter.Internal
System.Remote.Gauge.Internal
System.Remote.Label.Internal
- System.Remote.Snap
build-depends: aeson < 0.7,
base >= 4.5 && < 5,
bytestring < 1.0,
containers < 0.6,
filepath < 1.4,
- snap-core < 0.10,
- snap-server < 0.10,
text < 0.12,
time < 1.5,
transformers < 0.4,
unordered-containers < 0.3
+
+ if flag(useSnap)
+ other-modules:
+ System.Remote.Snap
+ build-depends:
+ snap-core < 0.10,
+ snap-server < 0.10
+ cpp-options: -DUSE_SNAP
+ else
+ other-modules:
+ System.Remote.WebServer
+ build-depends:
+ c10k >= 0.5,
+ network,
+ webserver >= 0.6,
+ unix
+
ghc-options: -Wall
source-repository head
Please sign in to comment.
Something went wrong with that request. Please try again.