{-# LANGUAGE OverloadedStrings #-}
module System.Remote.Snap
( startServer
) where
import Control.Applicative ((<$>), (<|>))
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.Function (on)
import qualified Data.HashMap.Strict as M
import qualified Data.List as List
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)
import Snap.Http.Server (httpServe)
import qualified Snap.Http.Server.Config as Config
import Snap.Util.FileServe (serveDirectory)
import System.FilePath ((</>))
import System.Metrics
import System.Remote.Json
getNumericHostAddress :: S.ByteString -> IO S.ByteString
getNumericHostAddress :: ByteString -> IO ByteString
getNumericHostAddress host :: ByteString
host = do
[AddrInfo]
ais <- Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo Maybe AddrInfo
forall a. Maybe a
Nothing (HostName -> Maybe HostName
forall a. a -> Maybe a
Just (ByteString -> HostName
S8.unpack ByteString
host)) Maybe HostName
forall a. Maybe a
Nothing
case [AddrInfo]
ais of
[] -> IO ByteString
forall a. IO a
unsupportedAddressError
(ai :: AddrInfo
ai:_) -> do
(Maybe HostName, Maybe HostName)
ni <- [NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe HostName, Maybe HostName)
getNameInfo [NameInfoFlag
NI_NUMERICHOST] Bool
True Bool
False (AddrInfo -> SockAddr
addrAddress AddrInfo
ai)
case (Maybe HostName, Maybe HostName)
ni of
(Just numericHost :: HostName
numericHost, _) -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! HostName -> ByteString
S8.pack HostName
numericHost
_ -> IO ByteString
forall a. IO a
unsupportedAddressError
where
unsupportedAddressError :: IO a
unsupportedAddressError = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$
HostName -> IOError
userError (HostName -> IOError) -> HostName -> IOError
forall a b. (a -> b) -> a -> b
$ "unsupported address: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ ByteString -> HostName
S8.unpack ByteString
host
startServer :: Store
-> S.ByteString
-> Int
-> IO ()
startServer :: Store -> ByteString -> Int -> IO ()
startServer store :: Store
store host :: ByteString
host port :: Int
port = do
ByteString
numericHost <- ByteString -> IO ByteString
getNumericHostAddress ByteString
host
let conf :: Config Snap a
conf = Bool -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
Config.setVerbose Bool
False (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
Config.setErrorLog ConfigLog
Config.ConfigNoLog (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
Config.setAccessLog ConfigLog
Config.ConfigNoLog (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$
Int -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
Config.setPort Int
port (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
Config.setHostname ByteString
host (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
Config.setBind ByteString
numericHost (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
Config.defaultConfig
Config Snap Any -> Snap () -> IO ()
forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap Any
forall a. Config Snap a
conf (Store -> Snap ()
monitor Store
store)
monitor :: Store -> Snap ()
monitor :: Store -> Snap ()
monitor store :: Store
store = do
HostName
dataDir <- IO HostName -> Snap HostName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HostName
getDataDir
(Snap () -> Snap ()
forall a. Snap a -> Snap a
jsonHandler (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ Store -> Snap ()
forall (m :: * -> *). MonadSnap m => Store -> m ()
serve Store
store)
Snap () -> Snap () -> Snap ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HostName -> Snap ()
forall (m :: * -> *). MonadSnap m => HostName -> m ()
serveDirectory (HostName
dataDir HostName -> HostName -> HostName
</> "assets")
where
jsonHandler :: Snap a -> Snap a
jsonHandler = ByteString -> Snap a -> Snap a
forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
wrapHandler "application/json"
wrapHandler :: ByteString -> m a -> m a
wrapHandler fmt :: ByteString
fmt handler :: m a
handler = Method -> m a -> m a
forall (m :: * -> *) a. MonadSnap m => Method -> m a -> m a
method Method
GET (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> m a -> m a
forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
format ByteString
fmt (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m a
handler
acceptHeader :: Request -> Maybe S.ByteString
req :: Request
req = CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader "Accept" Request
req
format :: MonadSnap m => S.ByteString -> m a -> m a
format :: ByteString -> m a -> m a
format fmt :: ByteString
fmt action :: m a
action = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let acceptHdr :: Maybe ByteString
acceptHdr = ([ByteString] -> ByteString
forall a. [a] -> a
List.head ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
parseHttpAccept) (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Maybe ByteString
acceptHeader Request
req
case Maybe ByteString
acceptHdr of
Just hdr :: ByteString
hdr | ByteString
hdr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
fmt -> m a
action
_ -> m a
forall (m :: * -> *) a. MonadSnap m => m a
pass
serve :: MonadSnap m => Store -> m ()
serve :: Store -> m ()
serve store :: Store
store = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Response
setContentType "application/json"
if ByteString -> Bool
S.null (Request -> ByteString
rqPathInfo Request
req)
then m ()
serveAll
else ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
serveOne (Request -> ByteString
rqPathInfo Request
req)
where
serveAll :: m ()
serveAll = do
Sample
metrics <- IO Sample -> m Sample
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sample -> m Sample) -> IO Sample -> m Sample
forall a b. (a -> b) -> a -> b
$ Store -> IO Sample
sampleAll Store
store
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Sample -> ByteString
encodeAll Sample
metrics
serveOne :: ByteString -> m ()
serveOne pathInfo :: ByteString
pathInfo = do
let segments :: [ByteString]
segments = Char -> ByteString -> [ByteString]
S8.split '/' ByteString
pathInfo
nameBytes :: ByteString
nameBytes = ByteString -> [ByteString] -> ByteString
S8.intercalate "." [ByteString]
segments
case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
nameBytes of
Left _ -> do
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Response -> Response
setResponseStatus 400 "Bad Request"
Response
r <- m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse
Response -> m ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith Response
r
Right name :: Text
name -> do
Sample
metrics <- IO Sample -> m Sample
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sample -> m Sample) -> IO Sample -> m Sample
forall a b. (a -> b) -> a -> b
$ Store -> IO Sample
sampleAll Store
store
case Text -> Sample -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
name Sample
metrics of
Nothing -> m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
Just metric :: Value
metric -> ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
encodeOne Value
metric
parseHttpAccept :: S.ByteString -> [S.ByteString]
parseHttpAccept :: ByteString -> [ByteString]
parseHttpAccept = ((ByteString, Double) -> ByteString)
-> [(ByteString, Double)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
List.map (ByteString, Double) -> ByteString
forall a b. (a, b) -> a
fst
([(ByteString, Double)] -> [ByteString])
-> (ByteString -> [(ByteString, Double)])
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Double) -> (ByteString, Double) -> Ordering)
-> [(ByteString, Double)] -> [(ByteString, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (Double -> Double -> Ordering
rcompare (Double -> Double -> Ordering)
-> ((ByteString, Double) -> Double)
-> (ByteString, Double)
-> (ByteString, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ByteString, Double) -> Double
forall a b. (a, b) -> b
snd)
([(ByteString, Double)] -> [(ByteString, Double)])
-> (ByteString -> [(ByteString, Double)])
-> ByteString
-> [(ByteString, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, Double))
-> [ByteString] -> [(ByteString, Double)]
forall a b. (a -> b) -> [a] -> [b]
List.map ByteString -> (ByteString, Double)
forall b. (Read b, Fractional b) => ByteString -> (ByteString, b)
grabQ
([ByteString] -> [(ByteString, Double)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split 44
where
rcompare :: Double -> Double -> Ordering
rcompare :: Double -> Double -> Ordering
rcompare = (Double -> Double -> Ordering) -> Double -> Double -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
grabQ :: ByteString -> (ByteString, b)
grabQ s :: ByteString
s =
let (s' :: ByteString
s', q :: ByteString
q) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard 59 ByteString
s
(_, q' :: ByteString
q') = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard 61 ByteString
q
in (ByteString -> ByteString
trimWhite ByteString
s', ByteString -> b
forall p. (Read p, Fractional p) => ByteString -> p
readQ (ByteString -> b) -> ByteString -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
trimWhite ByteString
q')
readQ :: ByteString -> p
readQ s :: ByteString
s = case ReadS p
forall a. Read a => ReadS a
reads ReadS p -> ReadS p
forall a b. (a -> b) -> a -> b
$ ByteString -> HostName
S8.unpack ByteString
s of
(x :: p
x, _):_ -> p
x
_ -> 1.0
trimWhite :: ByteString -> ByteString
trimWhite = (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 32)
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard w :: Word8
w s :: ByteString
s =
let (x :: ByteString
x, y :: ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
s
in (ByteString
x, Int -> ByteString -> ByteString
S.drop 1 ByteString
y)