diff --git a/moonshine.cabal b/moonshine.cabal --- a/moonshine.cabal +++ b/moonshine.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: moonshine -version: 1.2.2.1 +version: 2.0.0.0 synopsis: A web service framework for Haskell, similar in purpose to dropwizard. -- description: homepage: https://github.com/SumAll/moonshine @@ -22,14 +22,12 @@ -- other-modules: other-extensions: DeriveGeneric build-depends: - base >= 4.7 && < 5.0, - canteven-config >= 0.1 && < 0.2, aeson, + base >= 4.7 && < 5.0, bytestring, - directory, + canteven-config >= 1.0 && < 1.1, ekg >= 0.4.0.4, ekg-core, - filepath, hslogger, snap, text, diff --git a/src/Web/Moonshine.hs b/src/Web/Moonshine.hs --- a/src/Web/Moonshine.hs +++ b/src/Web/Moonshine.hs @@ -1,48 +1,50 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, NamedFieldPuns #-} module Web.Moonshine ( - Moonshine, LoggingConfig(..), runMoonshine, route, makeTimer, - timerAdd, Timer, getUserConfig, timed, liftSnap, liftIO, badRequest, - requiredParam, requiredUtf8Param, writeJSON, setBanner, readJSON, - created, noContent, methodNotAllowed, assertMethod, timedIO, - makeGauge, gaugeInc, gaugeDec, gaugeSet, gaugeAdd, gaugeSubtract, - Gauge, notFound, setServerVersion, ResponseEntity(..), writeEntity, - getMethod, conflict, ContentType, RequestEntity(..), DecodeResult(..), - readEntity, unsupportedMediaType, exactPath + Moonshine, + runMoonshine, + route, + makeTimer, + timerAdd, + Timer, + timed, + liftSnap, + liftIO, + setBanner, + timedIO, + makeGauge, + gaugeInc, + gaugeDec, + gaugeSet, + gaugeAdd, + gaugeSubtract, + Gauge, ) where import Canteven.Config (canteven) import Control.Applicative (Applicative(pure, (<*>)), (<|>)) import Control.Monad (ap, liftM) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Aeson (Value(String, Object), (.:?), (.!=), ToJSON, encode, - eitherDecode, (.:), (.!=)) +import Data.Aeson (Value(Object), (.:?), (.!=), (.!=)) import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) import Data.Int (Int64) -import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Monoid (mempty, mconcat) import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Data.Version (Version, showVersion) import Data.Yaml (FromJSON(parseJSON)) import GHC.Generics (Generic) import Snap (Snap, httpServe, setPort, Config, setSSLCert, setSSLKey, - setSSLPort, getParam, writeBS, setResponseCode, getResponse, - finishWith, modifyResponse, setHeader, setAccessLog, setErrorLog, - ConfigLog(ConfigIoLog), readRequestBody, Method(Method), getsRequest, - rqMethod, getHeader, rqPathInfo, pass) + setSSLPort, setResponseCode, getResponse, finishWith, setAccessLog, + setErrorLog, ConfigLog(ConfigIoLog)) import System.Environment (setEnv, lookupEnv) -import System.Log (Priority(INFO)) import System.Log.Logger (infoM, errorM) import System.Metrics (registerGcMetrics) import System.Metrics.Distribution (Distribution) import System.Remote.Monitoring (Server, forkServerWith) -import qualified Data.ByteString.Lazy as L (ByteString) -import qualified Data.Text as T +import qualified Data.Text as T (unpack) import qualified Snap (route) -import qualified System.Log.Logger as L (debugM, warningM) +import qualified System.Log.Logger as L (debugM) import qualified System.Metrics as EkgMetrics import qualified System.Metrics.Distribution as D (add) import qualified System.Metrics.Gauge as G (inc, Gauge, dec, set, add, subtract) @@ -88,61 +90,13 @@ newtype Gauge = G {unGauge :: G.Gauge} -{- | - Logging configuration that Moonshine should use to initialize logging. - - This type is an instance of FromJSON, so you can easily use it in your - configuration as: - - @ - data MyConfig = MyConfig { - logging :: LoggingConfig - } deriving (Generic) - instance FromJSON MyConfig - @ --} -data LoggingConfig = - LoggingConfig { - level :: LogPriority, - logfile :: Maybe FilePath, - loggers :: [LoggerDetails] - } - -instance FromJSON LoggingConfig where - parseJSON (Object logging) = do - level <- logging .:? "level" .!= LP INFO - logfile <- logging .:? "logfile" - loggers <- logging .:? "loggers" .!= [] - return LoggingConfig {level, logfile, loggers} - parseJSON value = - fail $ "Couldn't parse logging config from value " ++ show value - - -{- | - A way to set more fined-grained configuration for specific loggers. --} -data LoggerDetails = - LoggerDetails { - loggerName :: String, - loggerLevel :: LogPriority - } - -instance FromJSON LoggerDetails where - parseJSON (Object details) = do - loggerName <- details .: "logger" - loggerLevel <- details .: "level" - return LoggerDetails {loggerName, loggerLevel} - parseJSON value = - fail $ "Couldn't parse logger details from value " ++ show value - - data ServerConfig = ServerConfig { - applicationConnector :: [ConnectorConfig] - -- | Configuration for EKG. Note that although this is a list, - -- at present EKG makes it impossible to support more than one - -- server. See https://github.com/tibbe/ekg/issues/32. - , adminConnector :: [ConnectorConfig] + applicationConnector :: [ConnectorConfig], + adminConnector :: [ConnectorConfig] + -- ^ Configuration for EKG. Note that although this is a list, + -- at present EKG makes it impossible to support more than one + -- server. See https://github.com/tibbe/ekg/issues/32. } deriving (Generic) instance FromJSON ServerConfig @@ -164,18 +118,6 @@ instance FromJSON Scheme -{- | - A wrapper for Priority, so we can avoid orphan instances --} -newtype LogPriority = LP Priority - -instance FromJSON LogPriority where - parseJSON (String s) = case reads (T.unpack s) of - [(priority, "")] -> return (LP priority) - _ -> fail $ "couldn't parse Priority from string " ++ show s - parseJSON value = fail $ "Couldn't parse Priority from value " ++ show value - - -- Public Functions ----------------------------------------------------------- {- | @@ -184,16 +126,21 @@ -} runMoonshine :: Moonshine a -> IO a runMoonshine (Moonshine m) = do - printBanner - MoonshineConfig {mcServerConfig} <- canteven - metricsStore <- EkgMetrics.newStore - (State {snap}, val) <- m State { - snap = return (), - metricsStore - } - let snap2 = snap <|> notFound - startServer mcServerConfig metricsStore snap2 - return val + printBanner + MoonshineConfig {mcServerConfig} <- canteven + metricsStore <- EkgMetrics.newStore + (State {snap}, val) <- m State { + snap = return (), + metricsStore + } + let snap2 = snap <|> notFound + startServer mcServerConfig metricsStore snap2 + return val + where + notFound :: Snap a + notFound = do + response <- fmap (setResponseCode 404) getResponse + finishWith response data MoonshineConfig = MoonshineConfig { @@ -210,13 +157,6 @@ {- | - Returns the user config. --} -getUserConfig :: (MonadIO io, FromJSON config) => io config -getUserConfig = liftIO canteven - - -{- | Like `Snap.route`, but that automatically sets up metrics for the specified routes. -} @@ -253,7 +193,7 @@ will be logged to the metrics handler. -} timed - :: T.Text + :: Text -- ^ The name of the timer. -> Moonshine a -- ^ The action to be wrapped. @@ -266,7 +206,7 @@ {- | Make a new timer with the given name. -} -makeTimer :: T.Text -> Moonshine Timer +makeTimer :: Text -> Moonshine Timer makeTimer name = Moonshine (\state@State {metricsStore} -> do dist <- getDistribution name metricsStore return (state, T dist) @@ -294,224 +234,6 @@ {- | - Look up a parameter, and if it doesn't exist, then cause a 400 - BadRequest to be returned to the user --} -requiredParam :: ByteString -> Snap ByteString -requiredParam name = do - param <- getParam name - case param of - Nothing -> badRequest ("missing parameter: " ++ d name) - Just value -> return value - - -{- | - Look up a parameter, and decode it using utf8. If the parameter doesn't - exist, then cause a 400 BadReqeust to be returned to the user. --} -requiredUtf8Param :: ByteString -> Snap Text -requiredUtf8Param = fmap decodeUtf8 . requiredParam - - -{- | - Using this will short-circuit the snap monad (in much the same way as - `fail` does for all monads), but instead the regular meaning of "fail" - in the snap monad (which allows the framework to choose some other - path), this short-circuit causes a 400 Bad Request to be returned no - matter what. --} -badRequest :: String -> Snap a -badRequest reason = do -- snap monad - writeBS (encodeUtf8 (T.pack (reason ++ "\n"))) - response <- fmap (setResponseCode 400) getResponse - finishWith response - - -{- | - Return a @201 Created@ response. --} -created :: Snap () -created = modifyResponse (setResponseCode 201) - - -{- | - Return a @204 No Content@ response. --} -noContent :: Snap () -noContent = modifyResponse (setResponseCode 204) - - -{- | - Short circuit with a @404 Not Found@. --} -notFound :: Snap a -notFound = do - response <- fmap (setResponseCode 404) getResponse - finishWith response - - -{- | - Set the reponse code to @409 Conflict@. --} -conflict :: Snap () -conflict = modifyResponse (setResponseCode 409) - - - -{- | - Short circuit with a 405 Method Not Allowed. Also, set the Allow header - with the allowed methods. --} -methodNotAllowed :: [Method] -> Snap a -methodNotAllowed allowedMethods = do - response <- fmap (withAllow . setResponseCode 405) getResponse - finishWith response - where - withAllow = ( - setHeader "Allow" - . encodeUtf8 - . T.pack - . intercalate ", " - . map showMethod - ) allowedMethods - - -{- | - Asserts that the request was made using a particular HTTP request method. If - the assertion fails, then the request will result in a 405 Method Not - Allowed. --} -assertMethod :: Method -> Snap a -> Snap a -assertMethod allowedMethod snap = do - requestMethod <- getsRequest rqMethod - if requestMethod == allowedMethod - then snap - else methodNotAllowed [allowedMethod] - - -{- | - Write a `ToJSON` instance to the entity body, setting the @Content-Type@ - header to @application/json@. --} -writeJSON :: (ToJSON json) => json -> Snap () -writeJSON j = do - modifyResponse (setHeader "Content-Type" "application/json") - writeBS . toStrict . encode $ j - - -{- | - A more powerful version of writeJSON. This function writes generic - `ResponseEntity`s, and sets the right content type for them. --} -writeEntity :: (ResponseEntity e) => e -> Snap() -writeEntity e = do - modifyResponse (setHeader "Content-Type" (getContentType e)) - writeBS . getBytes $ e - - -{- | - ContentType is an alias for ByteString --} -type ContentType = ByteString - - -{- | - The class of things that can be used as http response entities. --} -class ResponseEntity e where - {- | - The content type of the respone entity. - -} - getContentType :: e -> ContentType - - {- | - The bytes associated with the response entity. - -} - getBytes :: e -> ByteString - - -{- | - The class of things that can be read as request entitys. --} -class RequestEntity e where - {- | - Decode the entity, according to the specified content type. - -} - decodeEntity :: Maybe ContentType -> L.ByteString -> DecodeResult e - - -{- | - The result of trying to decode a request entity. --} -data DecodeResult e - = Unsupported - -- ^ Signifies an unsupported content type. - | BadEntity String - -- ^ Signifies that the request entity is invalid, and provides some - -- kind of reason why. - | Ok e - -- ^ Successfully decoded the entity. - - -{- | - Reads and decodes a request entity, returning the appropriate error - responses if the entity can't be decoded: @415 Unsupported Media Type@ if the - content type is not supported, or @400 Bad Request@ if the content type is - supported, but the entity can't be decoded. --} -readEntity :: (RequestEntity e) => Int64 -> Snap e -readEntity maxSize = do - body <- readRequestBody maxSize - contentType <- getRequestContentType - case decodeEntity contentType body of - Unsupported -> do - logUnsupported contentType - unsupportedMediaType - BadEntity reason -> do - logBadEntity contentType reason - badRequest reason - Ok e -> return e - where - getRequestContentType = getsRequest (getHeader "content-type") - logBadEntity contentType reason = warningM ( - "readEntity of " ++ show contentType ++ - " failed because of: " ++ show reason - ) - logUnsupported contentType = warningM ( - "readEntity failed because " ++ show contentType ++ - " is not supported." - ) - - -{- | - Short circuit with a 415 response. --} -unsupportedMediaType :: Snap a -unsupportedMediaType = finishWith . setResponseCode 415 =<< getResponse - - -{- | - Read a `FromJSON` from the request entity, causing a 400 bad request on - a parsing error. The first argument specifies the maximum size we are - willing to read. This method delegates to `Snap.Core.readRequestBody`, - so an exception will be thrown in the case where the maximum size - is exceeded. --} -readJSON :: (FromJSON json) => Int64 -> Snap json -readJSON maxSize = do - body <- readRequestBody maxSize - case eitherDecode body of - Left err -> do - logReason body err - badRequest err - Right json -> return json - where - logReason body err = warningM ( - "readJSON failed because of " ++ show err ++ " on " ++ show body - ) - - -{- | Sets the banner that moonshine should display on startup. -} setBanner :: String -> IO () @@ -556,60 +278,16 @@ {- | Create a new gauge with the given name. -} -makeGauge :: T.Text -> Moonshine Gauge +makeGauge :: Text -> Moonshine Gauge makeGauge name = Moonshine (\state@State {metricsStore} -> do gauge <- EkgMetrics.createGauge name metricsStore return (state, G gauge) ) -{- | - Shorthand Snap action for retrieving the request method. --} -getMethod :: Snap Method -getMethod = getsRequest rqMethod - - -{- | - Utility method that sets the @Server:@ header to something sensible. --} -setServerVersion - :: String - -- ^ @name@ - The name of your server. - -> Version - -- ^ @version@ - The version of your server. - -> Moonshine () -setServerVersion name = - liftSnap - . modifyResponse - . setHeader "Server" - . encodeUtf8 - . T.pack - . ((name ++ "/") ++) - . showVersion - - -- Private Types -------------------------------------------------------------- {- | - Defines all the "system" config, where "system" means everything that - Moonshine knows about. --} -data SystemConfig = - SystemConfig { - logging :: Maybe LoggingConfig - , server :: Maybe ServerConfig - } - -instance FromJSON SystemConfig where - parseJSON (Object topLevel) = do - logging <- topLevel .:? "logging" - server <- topLevel .:? "server" - return SystemConfig {logging, server} - parseJSON value = - fail $ "Couldn't parse system config from value " ++ show value - -{- | Defines command line options. -} data Opt = Help @@ -659,7 +337,7 @@ A replacement for 'System.Remote.Monitoring.getDistribution' that uses an 'EkgMetrics.Store' instead of a 'Server'. -} -getDistribution :: T.Text -> EkgMetrics.Store -> IO Distribution +getDistribution :: Text -> EkgMetrics.Store -> IO Distribution getDistribution = EkgMetrics.createDistribution @@ -672,8 +350,8 @@ metricsStore snap = do - mapM_ startMetricsServer adminConnector - httpServe snapConfig snap + mapM_ startMetricsServer adminConnector + httpServe snapConfig snap where startMetricsServer :: ConnectorConfig -> IO Server @@ -686,10 +364,10 @@ snapConfig :: Config m a snapConfig = mconcat $ - map toSnapConfig applicationConnector ++ [ - setAccessLog (ConfigIoLog (infoM "snap" . toString)) mempty, - setErrorLog (ConfigIoLog (errorM "snap" . toString)) mempty - ] + map toSnapConfig applicationConnector ++ [ + setAccessLog (ConfigIoLog (infoM "snap" . toString)) mempty, + setErrorLog (ConfigIoLog (errorM "snap" . toString)) mempty + ] where toString = T.unpack . decodeUtf8 toSnapConfig :: ConnectorConfig -> Config m a @@ -722,47 +400,9 @@ {- | - Make sure that the path info is empty. If it isn't, then fail the snap action - using `pass`. This is helpful when using routes to make sure that a route - named "/foo" does not match an request uri of "/foo/bar" --} -exactPath :: Snap a -> Snap a -exactPath s = do - pathInfo <- getsRequest rqPathInfo - liftIO $ debugM ("PathInfo: " ++ show pathInfo) - case pathInfo of - "" -> s - _ -> pass - - -{- | - decode a bytestring to a string, via utf8 --} -d :: ByteString -> String -d = T.unpack . decodeUtf8 - - -{- | - The default `show` implementation of `Method` isn't good enough, - specifically the value `show (Method "FOO")` == `"Method \"Foo\""`, which is - unsuitable for use when displaying the actual name of the method in a formal - context (read: in the `Allow` header). --} -showMethod :: Method -> String -showMethod (Method m) = (T.unpack . decodeUtf8) m -showMethod m = show m - - -{- | Shorthand logging -} debugM :: String -> IO () debugM = L.debugM "moonshine" - -{- | - Shorthand logging --} -warningM :: (MonadIO io) => String -> io () -warningM = liftIO . L.warningM "moonshine"