As the new maintenance daemon will also provide an HTTP server, move the generic infrastructure to a utils module, so that it can be shared between the two servers.
Signed-off-by: Klaus Aehlig <[email protected]> --- Makefile.am | 1 + src/Ganeti/Monitoring/Server.hs | 32 ++------------ src/Ganeti/Utils/Http.hs | 92 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 29 deletions(-) create mode 100644 src/Ganeti/Utils/Http.hs diff --git a/Makefile.am b/Makefile.am index c7dbea5..936cdf4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1022,6 +1022,7 @@ HS_LIB_SRCS = \ src/Ganeti/Utils.hs \ src/Ganeti/Utils/Atomic.hs \ src/Ganeti/Utils/AsyncWorker.hs \ + src/Ganeti/Utils/Http.hs \ src/Ganeti/Utils/IORef.hs \ src/Ganeti/Utils/Livelock.hs \ src/Ganeti/Utils/Monad.hs \ diff --git a/src/Ganeti/Monitoring/Server.hs b/src/Ganeti/Monitoring/Server.hs index 0c3cb0f..5076195 100644 --- a/src/Ganeti/Monitoring/Server.hs +++ b/src/Ganeti/Monitoring/Server.hs @@ -52,7 +52,6 @@ import Data.List (find) import Data.Monoid (mempty) import qualified Data.Map as Map import qualified Data.PSQueue as Queue -import Network.BSD (getServicePortNumber) import Snap.Core import Snap.Http.Server import qualified Text.JSON as J @@ -70,7 +69,8 @@ import Ganeti.Objects (DataCollectorConfig(..)) import qualified Ganeti.Constants as C import qualified Ganeti.ConstantUtils as CU import Ganeti.Runtime -import Ganeti.Utils (getCurrentTimeUSec, withDefaultOnIOError) +import Ganeti.Utils (getCurrentTimeUSec) +import Ganeti.Utils.Http (httpConfFromOpts, error404) -- * Types and constants definitions @@ -86,17 +86,6 @@ type PrepResult = Config Snap () latestAPIVersion :: Int latestAPIVersion = C.mondLatestApiVersion --- * Configuration handling - --- | The default configuration for the HTTP server. -defaultHttpConf :: FilePath -> FilePath -> Config Snap () -defaultHttpConf accessLog errorLog = - setAccessLog (ConfigFileLog accessLog) . - setCompression False . - setErrorLog (ConfigFileLog errorLog) $ - setVerbose False - emptyConfig - -- * Helper functions -- | Check function for the monitoring agent. @@ -105,17 +94,7 @@ checkMain _ = return $ Right () -- | Prepare function for monitoring agent. prepMain :: PrepFn CheckResult PrepResult -prepMain opts _ = do - accessLog <- daemonsExtraLogFile GanetiMond AccessLog - errorLog <- daemonsExtraLogFile GanetiMond ErrorLog - defaultPort <- withDefaultOnIOError C.defaultMondPort - . liftM fromIntegral - $ getServicePortNumber C.mond - return . - setPort - (maybe defaultPort fromIntegral (optPort opts)) . - maybe id (setBind . pack) (optBindAddress opts) - $ defaultHttpConf accessLog errorLog +prepMain opts _ = httpConfFromOpts GanetiMond opts -- * Query answers @@ -219,11 +198,6 @@ errorReport = do modifyResponse $ setResponseStatus 404 "Not found" writeBS "Unable to produce a report for the requested resource" -error404 :: Snap () -error404 = do - modifyResponse $ setResponseStatus 404 "Not found" - writeBS "Resource not found" - -- | Return the report of one collector. oneReport :: MVar CollectorMap -> MVar ConfigAccess -> Snap () oneReport mvar mvarConfig = do diff --git a/src/Ganeti/Utils/Http.hs b/src/Ganeti/Utils/Http.hs new file mode 100644 index 0000000..9b67f61 --- /dev/null +++ b/src/Ganeti/Utils/Http.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Utils for HTTP servers + +-} + +{- + +Copyright (C) 2013 Google Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +-} + +module Ganeti.Utils.Http + ( httpConfFromOpts + , error404 + ) where + +import Control.Monad (liftM) +import Data.ByteString.Char8 (pack) +import Data.Map ((!)) +import Network.BSD (getServicePortNumber) +import Snap.Core (Snap, writeBS, modifyResponse, setResponseStatus) +import Snap.Http.Server.Config ( Config, ConfigLog(ConfigFileLog), emptyConfig + , setAccessLog, setErrorLog, setCompression + , setVerbose, setPort, setBind ) + +import qualified Ganeti.Constants as C +import Ganeti.Daemon (DaemonOptions(..)) +import Ganeti.Runtime ( GanetiDaemon, daemonName + , daemonsExtraLogFile, ExtraLogReason(..)) +import Ganeti.Utils (withDefaultOnIOError) + +-- * Configuration handling + +-- | The default configuration for the HTTP server. +defaultHttpConf :: FilePath -> FilePath -> Config Snap () +defaultHttpConf accessLog errorLog = + setAccessLog (ConfigFileLog accessLog) . + setCompression False . + setErrorLog (ConfigFileLog errorLog) $ + setVerbose False + emptyConfig + +-- | Get the HTTP Configuration from the daemon options. +httpConfFromOpts :: GanetiDaemon -> DaemonOptions -> IO (Config Snap ()) +httpConfFromOpts daemon opts = do + accessLog <- daemonsExtraLogFile daemon AccessLog + errorLog <- daemonsExtraLogFile daemon ErrorLog + let name = daemonName daemon + standardPort = snd $ C.daemonsPorts ! name + defaultPort <- withDefaultOnIOError standardPort + . liftM fromIntegral + $ getServicePortNumber name + return . + setPort + (maybe defaultPort fromIntegral (optPort opts)) . + maybe id (setBind . pack) (optBindAddress opts) + $ defaultHttpConf accessLog errorLog + + +-- * Standard answers + +-- | Resource not found error +error404 :: Snap () +error404 = do + modifyResponse $ setResponseStatus 404 "Not found" + writeBS "Resource not found" + -- 2.4.3.573.g4eafbef
