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)
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)
)
newtype Timer = T Distribution
newtype Gauge = G {unGauge :: G.Gauge}
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
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]
, 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
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
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
getUserConfig :: (MonadIO io, FromJSON config) => io config
getUserConfig = liftIO canteven
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
timer <- getDistribution (decodeUtf8 path) metricsStore
return (path, timedSnap timer snap)
liftSnap :: Snap () -> Moonshine ()
liftSnap s = Moonshine (\state@State {snap} ->
return (state {snap = snap >> s}, ())
)
timed
:: T.Text
-> Moonshine a
-> Moonshine a
timed name (Moonshine m) = Moonshine $ \state@State {snap, metricsStore} -> do
timer <- getDistribution name metricsStore
m state {snap = timedSnap timer snap}
makeTimer :: T.Text -> Moonshine Timer
makeTimer name = Moonshine (\state@State {metricsStore} -> do
dist <- getDistribution name metricsStore
return (state, T dist)
)
timerAdd :: (Real time, MonadIO io) => Timer -> time -> io ()
timerAdd (T timer) = liftIO . D.add timer . fromRational . toRational
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
requiredParam :: ByteString -> Snap ByteString
requiredParam name = do
param <- getParam name
case param of
Nothing -> badRequest ("missing parameter: " ++ d name)
Just value -> return value
requiredUtf8Param :: ByteString -> Snap Text
requiredUtf8Param = fmap decodeUtf8 . requiredParam
badRequest :: String -> Snap a
badRequest reason = do
writeBS (encodeUtf8 (T.pack (reason ++ "\n")))
response <- fmap (setResponseCode 400) getResponse
finishWith response
created :: Snap ()
created = modifyResponse (setResponseCode 201)
noContent :: Snap ()
noContent = modifyResponse (setResponseCode 204)
notFound :: Snap a
notFound = do
response <- fmap (setResponseCode 404) getResponse
finishWith response
conflict :: Snap ()
conflict = modifyResponse (setResponseCode 409)
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
assertMethod :: Method -> Snap a -> Snap a
assertMethod allowedMethod snap = do
requestMethod <- getsRequest rqMethod
if requestMethod == allowedMethod
then snap
else methodNotAllowed [allowedMethod]
writeJSON :: (ToJSON json) => json -> Snap ()
writeJSON j = do
modifyResponse (setHeader "Content-Type" "application/json")
writeBS . toStrict . encode $ j
writeEntity :: (ResponseEntity e) => e -> Snap()
writeEntity e = do
modifyResponse (setHeader "Content-Type" (getContentType e))
writeBS . getBytes $ e
type ContentType = ByteString
class ResponseEntity e where
getContentType :: e -> ContentType
getBytes :: e -> ByteString
class RequestEntity e where
decodeEntity :: Maybe ContentType -> L.ByteString -> DecodeResult e
data DecodeResult e
= Unsupported
| BadEntity String
| Ok e
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."
)
unsupportedMediaType :: Snap a
unsupportedMediaType = finishWith . setResponseCode 415 =<< getResponse
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
)
setBanner :: String -> IO ()
setBanner = setEnv bannerEnvName
gaugeInc :: (MonadIO io) => Gauge -> io ()
gaugeInc = liftIO . G.inc . unGauge
gaugeDec :: (MonadIO io) => Gauge -> io ()
gaugeDec = liftIO . G.dec . unGauge
gaugeSet :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeSet (G gauge) = liftIO . G.set gauge
gaugeSubtract :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeSubtract (G gauge) = liftIO . G.subtract gauge
gaugeAdd :: (MonadIO io) => Gauge -> Int64 -> io ()
gaugeAdd (G gauge) = liftIO . G.add gauge
makeGauge :: T.Text -> Moonshine Gauge
makeGauge name = Moonshine (\state@State {metricsStore} -> do
gauge <- EkgMetrics.createGauge name metricsStore
return (state, G gauge)
)
getMethod :: Snap Method
getMethod = getsRequest rqMethod
setServerVersion
:: String
-> Version
-> Moonshine ()
setServerVersion name =
liftSnap
. modifyResponse
. setHeader "Server"
. encodeUtf8
. T.pack
. ((name ++ "/") ++)
. showVersion
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
data Opt = Help
| Config String
deriving Show
data State =
State {
snap :: Snap (),
metricsStore :: EkgMetrics.Store
}
defaultServerConfig :: ServerConfig
defaultServerConfig = ServerConfig {
adminConnector =
[ConnectorConfig {scheme=HTTP, port=8001, cert=Nothing, key=Nothing}]
, applicationConnector =
[ConnectorConfig {scheme=HTTP, port=8000, cert=Nothing, key=Nothing}]
}
printBanner :: IO ()
printBanner = do
banner <- lookupEnv bannerEnvName
putStr $ fromMaybe
"FIXME: failed to magic setBanner. son, I am disappoint\n"
banner
bannerEnvName :: String
bannerEnvName = "mclovin-banner-magic"
getDistribution :: T.Text -> EkgMetrics.Store -> IO Distribution
getDistribution = EkgMetrics.createDistribution
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
cert <- mcert
key <- mkey
return $ setSSLCert cert $ setSSLKey key $ setSSLPort port mempty
timedSnap :: Distribution -> Snap () -> Snap ()
timedSnap timer snap = do
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
exactPath :: Snap a -> Snap a
exactPath s = do
pathInfo <- getsRequest rqPathInfo
liftIO $ debugM ("PathInfo: " ++ show pathInfo)
case pathInfo of
"" -> s
_ -> pass
d :: ByteString -> String
d = T.unpack . decodeUtf8
showMethod :: Method -> String
showMethod (Method m) = (T.unpack . decodeUtf8) m
showMethod m = show m
debugM :: String -> IO ()
debugM = L.debugM "moonshine"
warningM :: (MonadIO io) => String -> io ()
warningM = liftIO . L.warningM "moonshine"