{-# 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"