{-# LANGUAGE OverloadedStrings #-}

module HttpServer (new) where

import Control.Concurrent.MVar (newEmptyMVar, takeMVar)
import Control.Monad
import Control.Monad.IO.Class
import Data.Foldable (for_)
import Data.Traversable (for)
import Data.Text (pack)
import Network.HTTP.Types
import Network.Wai (Application)
import Web.Scotty (delete, get, json, jsonData, put, regex, middleware, request, scottyApp, status, ActionM)

import qualified Data.Text.Lazy as LText
import qualified Network.Wai as Wai
import qualified Web.Scotty.Trans as Scotty

import HTTPMethodInvalid (canonicalizeHTTPMethods,limitHTTPMethods)
import JwtMiddleware (jwtMiddleware)
import Core (Core (..), EnqueueResult (..))
import Config (Config (..))
import Logger (postLog, LogLevel(LogError))
import qualified Store
import qualified Core
import qualified Metrics

new :: Core -> IO Application
new :: Core -> IO Application
new Core
core =
  ScottyM () -> IO Application
scottyApp (ScottyM () -> IO Application) -> ScottyM () -> IO Application
forall a b. (a -> b) -> a -> b
$ do
    -- First we check whether the request HTTP method is a recognised HTTP method.
    -- Any arbitrary ByteString is accepted as a request method and we store those 
    -- in the exposed metrics, this is a DoS vector.
    Middleware -> ScottyM ()
middleware Middleware
canonicalizeHTTPMethods
    -- Second middleware is the metrics middleware in order to intercept
    -- all requests and their corresponding responses
    Maybe IcepeakMetrics
-> (IcepeakMetrics -> ScottyM ()) -> ScottyM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Core -> Maybe IcepeakMetrics
coreMetrics Core
core) ((IcepeakMetrics -> ScottyM ()) -> ScottyM ())
-> (IcepeakMetrics -> ScottyM ()) -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ Middleware -> ScottyM ()
middleware (Middleware -> ScottyM ())
-> (IcepeakMetrics -> Middleware) -> IcepeakMetrics -> ScottyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IcepeakMetrics -> Middleware
metricsMiddleware
    -- Exit on unknown HTTP verb after the request has been stored in the metrics.
    Middleware -> ScottyM ()
middleware Middleware
limitHTTPMethods
    -- Use the Sentry logger if available
    -- Scottys error handler will only catch errors that are thrown from within
    -- a ```liftAndCatchIO``` function.
    (Text -> ActionT Text IO ()) -> ScottyM ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
(e -> ActionT e m ()) -> ScottyT e m ()
Scotty.defaultHandler (\Text
e -> do
        IO () -> ActionT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionT Text IO ()) -> IO () -> ActionT Text IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> LogLevel -> LogRecord -> IO ()
postLog (Core -> Logger
coreLogger Core
core) LogLevel
LogError (LogRecord -> IO ()) -> (Text -> LogRecord) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LogRecord
pack (String -> LogRecord) -> (Text -> String) -> Text -> LogRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
e
        Status -> ActionT Text IO ()
status Status
status503
        Text -> ActionT Text IO ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
Scotty.text Text
"Internal server error"
       )

    Bool -> ScottyM () -> ScottyM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configEnableJwtAuth (Config -> Bool) -> Config -> Bool
forall a b. (a -> b) -> a -> b
$ Core -> Config
coreConfig Core
core) (ScottyM () -> ScottyM ()) -> ScottyM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$
      Middleware -> ScottyM ()
middleware (Middleware -> ScottyM ()) -> Middleware -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ Maybe Signer -> Middleware
jwtMiddleware (Maybe Signer -> Middleware) -> Maybe Signer -> Middleware
forall a b. (a -> b) -> a -> b
$ Config -> Maybe Signer
configJwtSecret (Config -> Maybe Signer) -> Config -> Maybe Signer
forall a b. (a -> b) -> a -> b
$ Core -> Config
coreConfig Core
core

    RoutePattern -> ActionT Text IO () -> ScottyM ()
get (String -> RoutePattern
regex String
"^") (ActionT Text IO () -> ScottyM ())
-> ActionT Text IO () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
      [LogRecord]
path <- Request -> [LogRecord]
Wai.pathInfo (Request -> [LogRecord])
-> ActionT Text IO Request -> ActionT Text IO [LogRecord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT Text IO Request
request
      Maybe Value
maybeValue <- IO (Maybe Value) -> ActionT Text IO (Maybe Value)
forall e (m :: * -> *) a.
(ScottyError e, MonadIO m) =>
IO a -> ActionT e m a
Scotty.liftAndCatchIO (IO (Maybe Value) -> ActionT Text IO (Maybe Value))
-> IO (Maybe Value) -> ActionT Text IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Core -> [LogRecord] -> IO (Maybe Value)
Core.getCurrentValue Core
core [LogRecord]
path
      ActionT Text IO ()
-> (Value -> ActionT Text IO ())
-> Maybe Value
-> ActionT Text IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Status -> ActionT Text IO ()
status Status
status404) Value -> ActionT Text IO ()
forall a. ToJSON a => a -> ActionT Text IO ()
json Maybe Value
maybeValue

    RoutePattern -> ActionT Text IO () -> ScottyM ()
put (String -> RoutePattern
regex String
"^") (ActionT Text IO () -> ScottyM ())
-> ActionT Text IO () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
      [LogRecord]
path <- Request -> [LogRecord]
Wai.pathInfo (Request -> [LogRecord])
-> ActionT Text IO Request -> ActionT Text IO [LogRecord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT Text IO Request
request
      Value
value <- ActionM Value
forall a. FromJSON a => ActionM a
jsonData
      EnqueueResult
result <- Core -> Modification -> ActionT Text IO EnqueueResult
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
Core -> Modification -> ActionT e m EnqueueResult
postModification Core
core ([LogRecord] -> Value -> Modification
Store.Put [LogRecord]
path Value
value)
      EnqueueResult -> ActionT Text IO ()
buildResponse EnqueueResult
result

    RoutePattern -> ActionT Text IO () -> ScottyM ()
delete (String -> RoutePattern
regex String
"^") (ActionT Text IO () -> ScottyM ())
-> ActionT Text IO () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
      [LogRecord]
path <- Request -> [LogRecord]
Wai.pathInfo (Request -> [LogRecord])
-> ActionT Text IO Request -> ActionT Text IO [LogRecord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT Text IO Request
request
      EnqueueResult
result <- Core -> Modification -> ActionT Text IO EnqueueResult
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
Core -> Modification -> ActionT e m EnqueueResult
postModification Core
core ([LogRecord] -> Modification
Store.Delete [LogRecord]
path)
      EnqueueResult -> ActionT Text IO ()
buildResponse EnqueueResult
result


-- | Enqueue modification and wait for it to be processed, if desired by the client.
postModification :: (Scotty.ScottyError e, MonadIO m) => Core -> Store.Modification -> Scotty.ActionT e m EnqueueResult
postModification :: Core -> Modification -> ActionT e m EnqueueResult
postModification Core
core Modification
op = do
  -- the parameter is parsed as type (), therefore only presence or absence is important
  Maybe ()
durable <- Text -> ActionT e m (Maybe ())
forall a e (m :: * -> *).
(Parsable a, ScottyError e, Monad m) =>
Text -> ActionT e m (Maybe a)
maybeParam Text
"durable"
  Maybe (MVar ())
waitVar <- IO (Maybe (MVar ())) -> ActionT e m (Maybe (MVar ()))
forall e (m :: * -> *) a.
(ScottyError e, MonadIO m) =>
IO a -> ActionT e m a
Scotty.liftAndCatchIO (IO (Maybe (MVar ())) -> ActionT e m (Maybe (MVar ())))
-> IO (Maybe (MVar ())) -> ActionT e m (Maybe (MVar ()))
forall a b. (a -> b) -> a -> b
$ Maybe () -> (() -> IO (MVar ())) -> IO (Maybe (MVar ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe ()
durable ((() -> IO (MVar ())) -> IO (Maybe (MVar ())))
-> (() -> IO (MVar ())) -> IO (Maybe (MVar ()))
forall a b. (a -> b) -> a -> b
$ \() -> IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  EnqueueResult
result <- IO EnqueueResult -> ActionT e m EnqueueResult
forall e (m :: * -> *) a.
(ScottyError e, MonadIO m) =>
IO a -> ActionT e m a
Scotty.liftAndCatchIO (IO EnqueueResult -> ActionT e m EnqueueResult)
-> IO EnqueueResult -> ActionT e m EnqueueResult
forall a b. (a -> b) -> a -> b
$ Command -> Core -> IO EnqueueResult
Core.tryEnqueueCommand (Modification -> Maybe (MVar ()) -> Command
Core.Modify Modification
op Maybe (MVar ())
waitVar) Core
core
  Bool -> ActionT e m () -> ActionT e m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EnqueueResult
result EnqueueResult -> EnqueueResult -> Bool
forall a. Eq a => a -> a -> Bool
== EnqueueResult
Enqueued) (ActionT e m () -> ActionT e m ())
-> ActionT e m () -> ActionT e m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> ActionT e m ()
forall e (m :: * -> *) a.
(ScottyError e, MonadIO m) =>
IO a -> ActionT e m a
Scotty.liftAndCatchIO (IO () -> ActionT e m ()) -> IO () -> ActionT e m ()
forall a b. (a -> b) -> a -> b
$ Maybe (MVar ()) -> (MVar () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (MVar ())
waitVar ((MVar () -> IO ()) -> IO ()) -> (MVar () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar
  EnqueueResult -> ActionT e m EnqueueResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnqueueResult
result

buildResponse :: EnqueueResult -> ActionM ()
buildResponse :: EnqueueResult -> ActionT Text IO ()
buildResponse EnqueueResult
Enqueued = Status -> ActionT Text IO ()
status Status
accepted202
buildResponse EnqueueResult
Dropped  = Status -> ActionT Text IO ()
status Status
serviceUnavailable503

metricsMiddleware :: Metrics.IcepeakMetrics -> Wai.Middleware
metricsMiddleware :: IcepeakMetrics -> Middleware
metricsMiddleware IcepeakMetrics
metrics Application
app Request
req Response -> IO ResponseReceived
sendResponse = Application
app Request
req Response -> IO ResponseReceived
sendWithMetrics
  where
    sendWithMetrics :: Response -> IO ResponseReceived
sendWithMetrics Response
resp = do
      Method -> Status -> IcepeakMetrics -> IO ()
Metrics.notifyRequest (Request -> Method
Wai.requestMethod Request
req) (Response -> Status
Wai.responseStatus Response
resp) IcepeakMetrics
metrics
      Response -> IO ResponseReceived
sendResponse Response
resp

maybeParam :: (Scotty.Parsable a, Scotty.ScottyError e, Monad m) => LText.Text -> Scotty.ActionT e m (Maybe a)
maybeParam :: Text -> ActionT e m (Maybe a)
maybeParam Text
name = ([(Text, Text)] -> Maybe a)
-> ActionT e m [(Text, Text)] -> ActionT e m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Maybe a
parseMaybe (Text -> Maybe a)
-> ([(Text, Text)] -> Maybe Text) -> [(Text, Text)] -> Maybe a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name) ActionT e m [(Text, Text)]
forall (m :: * -> *) e. Monad m => ActionT e m [(Text, Text)]
Scotty.params where
  parseMaybe :: Text -> Maybe a
parseMaybe = (Text -> Maybe a) -> (a -> Maybe a) -> Either Text a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> Text -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either Text a -> Maybe a)
-> (Text -> Either Text a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a. Parsable a => Text -> Either Text a
Scotty.parseParam