moonshine 1.2.2.1 → 2.0.0.0

raw patch · 2 files changed

+57/−419 lines, 2 filesdep −directorydep −filepathdep ~canteven-configPVP ok

version bump matches the API change (PVP)

Dependencies removed: directory, filepath

Dependency ranges changed: canteven-config

API changes (from Hackage documentation)

Files

• moonshine.cabal +3/−5
• src/Web/Moonshine.hs +54/−414

@@ -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,

@@ -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"