diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2014 SumAll.com + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +moonshine +========= + +A web service framework for Haskell, similar in purpose to dropwizard. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/moonshine.cabal b/moonshine.cabal new file mode 100644 --- /dev/null +++ b/moonshine.cabal @@ -0,0 +1,42 @@ +-- Initial moonshine.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: moonshine +version: 1.2.2.1 +synopsis: A web service framework for Haskell, similar in purpose to dropwizard. +-- description: +homepage: https://github.com/SumAll/moonshine +license: Apache-2.0 +license-file: LICENSE +author: Rick Owens +maintainer: rowens@sumall.com +copyright: 2014 +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: + Web.Moonshine + -- other-modules: + other-extensions: DeriveGeneric + build-depends: + base >= 4.7 && < 5.0, + canteven-config >= 0.1 && < 0.2, + aeson, + bytestring, + directory, + ekg >= 0.4.0.4, + ekg-core, + filepath, + hslogger, + snap, + text, + time, + transformers, + yaml + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + diff --git a/src/Web/Moonshine.hs b/src/Web/Moonshine.hs new file mode 100644 --- /dev/null +++ b/src/Web/Moonshine.hs @@ -0,0 +1,768 @@ +{-# 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 +) 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.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.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) +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 Snap (route) +import qualified System.Log.Logger as L (debugM, warningM) +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) + +-- Public Types --------------------------------------------------------------- +-- Semi-Public Types ---------------------------------------------------------- + +{- | + The moonshine monad. +-} +data Moonshine a = + Moonshine (State -> IO (State , a)) + +instance Monad Moonshine where + return a = Moonshine (\state -> return (state, a)) + (Moonshine m) >>= fun = Moonshine $ \state -> do + (newState, val) <- m state + let Moonshine m2 = fun val + m2 newState + +instance Applicative Moonshine where + pure = return + (<*>) = ap + +instance Functor Moonshine where + fmap = liftM + +instance MonadIO Moonshine where + liftIO io = Moonshine (\state -> do + val <- io + return (state, val) + ) + + +{- | + The Timer type. +-} +newtype Timer = T Distribution + +{- | + The Gauge type. +-} +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] + } deriving (Generic) + +instance FromJSON ServerConfig + + +data ConnectorConfig = ConnectorConfig { + scheme :: Scheme + , port :: Int + , cert :: Maybe FilePath + , key :: Maybe FilePath + } deriving (Generic) + +instance FromJSON ConnectorConfig + + +data Scheme = HTTP | HTTPS + deriving (Generic) + +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 ----------------------------------------------------------- + +{- | + Execute an insance of the Moonshine monad. This starts up a server + and never returns. +-} +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 + +data MoonshineConfig = + MoonshineConfig { + mcServerConfig :: ServerConfig + } +instance FromJSON MoonshineConfig where + parseJSON v = + case v of + Object topLevel -> do + mcServerConfig <- topLevel .:? "server" .!= defaultServerConfig + return MoonshineConfig {mcServerConfig} + _ -> + fail $ "Couldn't parse system config from value: " ++ show v + + +{- | + 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. +-} +route :: [(ByteString, Moonshine ())] -> Moonshine () +route routes = Moonshine $ \state@State {snap, metricsStore} -> do + snapRoutes <- mapM (getUnboundSnapRoute state) routes + monitoredRoutes <- mapM (monitorRoute metricsStore) snapRoutes + return (state {snap = snap >> Snap.route monitoredRoutes}, ()) + where + getUnboundSnapRoute state (path, Moonshine m) = do + (State {snap}, ()) <- m state {snap = return ()} + return (path, snap) + + monitorRoute + :: EkgMetrics.Store + -> (ByteString, Snap ()) + -> IO (ByteString, Snap ()) + monitorRoute metricsStore (path, snap) = do -- IO monad + timer <- getDistribution (decodeUtf8 path) metricsStore + return (path, timedSnap timer snap) + + +{- | + Lifts a snap action into a moonshine action. +-} +liftSnap :: Snap () -> Moonshine () +liftSnap s = Moonshine (\state@State {snap} -> + return (state {snap = snap >> s}, ()) + ) + + +{- | + Wrap a `Moonshine` in a timer, so that timing data for invocations + will be logged to the metrics handler. +-} +timed + :: T.Text + -- ^ The name of the timer. + -> Moonshine a + -- ^ The action to be wrapped. + -> Moonshine a +timed name (Moonshine m) = Moonshine $ \state@State {snap, metricsStore} -> do + timer <- getDistribution name metricsStore + m state {snap = timedSnap timer snap} + + +{- | + Make a new timer with the given name. +-} +makeTimer :: T.Text -> Moonshine Timer +makeTimer name = Moonshine (\state@State {metricsStore} -> do + dist <- getDistribution name metricsStore + return (state, T dist) + ) + + +{- | + Add a time to a timer. +-} +timerAdd :: (Real time, MonadIO io) => Timer -> time -> io () +timerAdd (T timer) = liftIO . D.add timer . fromRational . toRational + + +{- | + Time how long it takes to perform some kind of IO. This function is + compatible with any `MonadIO`. +-} +timedIO :: (MonadIO io) => Timer -> io a -> io a +timedIO timer io = do + start <- liftIO getCurrentTime + result <- io + end <- liftIO getCurrentTime + timerAdd timer (diffUTCTime end start) + return result + + +{- | + 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 () +setBanner = setEnv bannerEnvName + + +{- | + Add one to a gauge value. +-} +gaugeInc :: (MonadIO io) => Gauge -> io () +gaugeInc = liftIO . G.inc . unGauge + + +{- | + Subtract one from a gauge value. +-} +gaugeDec :: (MonadIO io) => Gauge -> io () +gaugeDec = liftIO . G.dec . unGauge + + +{- | + Set the gauge the a specific value one from a gauge value. +-} +gaugeSet :: (MonadIO io) => Gauge -> Int64 -> io () +gaugeSet (G gauge) = liftIO . G.set gauge + + +{- | + Subtrace a value from a gauge. +-} +gaugeSubtract :: (MonadIO io) => Gauge -> Int64 -> io () +gaugeSubtract (G gauge) = liftIO . G.subtract gauge + + +{- | + Add a value to a gauge. +-} +gaugeAdd :: (MonadIO io) => Gauge -> Int64 -> io () +gaugeAdd (G gauge) = liftIO . G.add gauge + + +{- | + Create a new gauge with the given name. +-} +makeGauge :: T.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 + | Config String + deriving Show + +{- | + The internal running state used while executing the `Moonshine` monad. +-} +data State = + State { + snap :: Snap (), + metricsStore :: EkgMetrics.Store + } + + +-- Private Functions ---------------------------------------------------------- + +defaultServerConfig :: ServerConfig +defaultServerConfig = ServerConfig { + adminConnector = + [ConnectorConfig {scheme=HTTP, port=8001, cert=Nothing, key=Nothing}] + , applicationConnector = + [ConnectorConfig {scheme=HTTP, port=8000, cert=Nothing, key=Nothing}] + } + + +{- | + Find and output a banner. +-} +printBanner :: IO () +printBanner = do + banner <- lookupEnv bannerEnvName + putStr $ fromMaybe + "FIXME: failed to magic setBanner. son, I am disappoint\n" + banner + + +{- | + This is the name o the magic banner environment variable. +-} +bannerEnvName :: String +bannerEnvName = "mclovin-banner-magic" + + +{- | + A replacement for 'System.Remote.Monitoring.getDistribution' that uses + an 'EkgMetrics.Store' instead of a 'Server'. +-} +getDistribution :: T.Text -> EkgMetrics.Store -> IO Distribution +getDistribution = EkgMetrics.createDistribution + + +{- | + Start application listening on the ports given by the config. +-} +startServer :: ServerConfig -> EkgMetrics.Store -> Snap () -> IO () +startServer + ServerConfig { applicationConnector, adminConnector } + metricsStore + snap + = do + mapM_ startMetricsServer adminConnector + httpServe snapConfig snap + + where + startMetricsServer :: ConnectorConfig -> IO Server + startMetricsServer ConnectorConfig { scheme=HTTP, port } = do + registerGcMetrics metricsStore + debugM ("Starting up ekg on port: " ++ show port) + forkServerWith metricsStore "0.0.0.0" port + startMetricsServer ConnectorConfig { scheme=HTTPS } = + error "EKG does not support running on HTTPS" + + snapConfig :: Config m a + snapConfig = mconcat $ + 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 + toSnapConfig ConnectorConfig { scheme=HTTP, port } = setPort port mempty + toSnapConfig ConnectorConfig { scheme=HTTPS, port, cert=mcert, key=mkey } = + fromMaybe + (error "You must provide cert and key in order to use HTTPS.") + $ do -- Maybe monad + cert <- mcert + key <- mkey + return $ setSSLCert cert $ setSSLKey key $ setSSLPort port mempty + + +{- | + Add timing information to a snap action. +-} +timedSnap :: Distribution -> Snap () -> Snap () +timedSnap timer snap = do -- snap monad + start <- liftIO getCurrentTime + result <- snap + end <- liftIO getCurrentTime + addTiming start end + return result + where + addTiming start end = liftIO $ + D.add timer diff + where + diff = toDouble (diffUTCTime end start) + toDouble = fromRational . toRational + + +{- | + 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" +