{-# LANGUAGE CPP               #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE LambdaCase #-}
{-# language ScopedTypeVariables #-}
module Web.Scotty.Action
    ( addHeader
    , body
    , bodyReader
    , file
    , rawResponse
    , files
    , filesOpts
    , W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions
    , finish
    , header
    , headers
    , html
    , htmlLazy
    , json
    , jsonData
    , formData
    , next
    , pathParam
    , captureParam
    , formParam
    , queryParam
    , pathParamMaybe
    , captureParamMaybe
    , formParamMaybe
    , queryParamMaybe
    , pathParams
    , captureParams
    , formParams
    , queryParams
    , throw
    , raw
    , nested
    , readEither
    , redirect
    , redirect300
    , redirect301
    , redirect302
    , redirect303
    , redirect304
    , redirect307
    , redirect308
    , request
    , setHeader
    , status
    , stream
    , text
    , textLazy
    , getResponseStatus
    , getResponseHeaders
    , getResponseContent
    , Param
    , Parsable(..)
    , ActionT
      -- private to Scotty
    , runAction
    ) where

import           Blaze.ByteString.Builder   (fromLazyByteString)

import qualified Control.Exception          as E
import           Control.Monad              (when)
import           Control.Monad.IO.Class     (MonadIO(..))
import UnliftIO (MonadUnliftIO(..))
import           Control.Monad.Reader       (MonadReader(..), ReaderT(..), asks)
import Control.Monad.Trans.Resource (withInternalState, runResourceT)

import           Control.Concurrent.MVar

import qualified Data.Aeson                 as A
import Data.Bool (bool)
import qualified Data.ByteString.Char8      as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.CaseInsensitive       as CI
import           Data.Traversable (for)
import qualified Data.Map.Strict            as Map
import qualified Data.HashMap.Strict        as HM
import           Data.Int
import           Data.List (foldl')
import           Data.Maybe                 (maybeToList)
import qualified Data.Text                  as T
import           Data.Text.Encoding         as STE
import qualified Data.Text.Lazy             as TL
import qualified Data.Text.Lazy.Encoding    as TLE
import           Data.Time                  (UTCTime)
import           Data.Time.Format           (parseTimeM, defaultTimeLocale)
import           Data.Typeable              (typeOf)
import           Data.Word

import           Network.HTTP.Types
-- not re-exported until version 0.11
#if !MIN_VERSION_http_types(0,11,0)
import           Network.HTTP.Types.Status
#endif
import           Network.Wai (Request, Response, StreamingBody, Application, requestHeaders)
import Network.Wai.Handler.Warp (InvalidRequest(..))
import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions)

import           Numeric.Natural

import           Web.FormUrlEncoded (Form(..), FromForm(..))
import           Web.Scotty.Internal.Types
import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
import           UnliftIO.Exception (Handler(..), catches, throwIO)
import           System.IO (hPutStrLn, stderr)

import Network.Wai.Internal (ResponseReceived(..))


-- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order)
--   and construct the 'Response'
--
-- 'Nothing' indicates route failed (due to Next) and pattern matching should try the next available route.
-- 'Just' indicates a successful response.
runAction :: MonadUnliftIO m =>
             Options
          -> Maybe (ErrorHandler m) -- ^ this handler (if present) is in charge of user-defined exceptions
          -> ActionEnv
          -> ActionT m () -- ^ Route action to be evaluated
          -> m (Maybe Response)
runAction options mh env action = do
  ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat
    [ [actionErrorHandler]
    , maybeToList mh
    , [scottyExceptionHandler options, someExceptionHandler options]
    ]
  res <- getResponse env
  return $ bool Nothing (Just $ mkResponse res) ok

-- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'.
-- All other cases of 'ActionError' are converted to HTTP responses.
actionErrorHandler :: MonadIO m => ErrorHandler m
actionErrorHandler = Handler $ \case
  AERedirect s url -> do
    status s
    setHeader "Location" url
  AENext -> next
  AEFinish -> return ()

-- | Default handler for exceptions from scotty
scottyExceptionHandler :: MonadIO m => Options -> ErrorHandler m
scottyExceptionHandler Options{jsonMode} = Handler $ \case
  RequestTooLarge -> do
    status status413
    if jsonMode
      then json $ A.object ["status" A..= (413 :: Int), "description" A..= ("Request body is too large" :: T.Text)]
      else text "Request body is too large"
  MalformedJSON bs err -> do
    status status400
    if jsonMode
      then json $ A.object
        [ "status" A..= (400 :: Int)
        , "description" A..= ("jsonData: malformed" :: T.Text)
        , "body" A..= decodeUtf8Lenient (BL.toStrict bs)
        , "error" A..= err
        ]
      else raw $ BL.unlines
        [ "jsonData: malformed"
        , "Body: " <> bs
        , "Error: " <> BL.fromStrict (encodeUtf8 err)
        ]
  FailedToParseJSON bs err -> do
    status status422
    if jsonMode
      then json $ A.object
        [ "status" A..= (422 :: Int)
        , "description" A..= ("jsonData: failed to parse" :: T.Text)
        , "body" A..= decodeUtf8Lenient (BL.toStrict bs)
        , "error" A..= err
        ]
      else raw $ BL.unlines
        [ "jsonData: failed to parse"
        , "Body: " <> bs
        , "Error: " <> BL.fromStrict (encodeUtf8 err)
        ]
  MalformedForm err -> do
    status status400
    if jsonMode
      then json $ A.object
        [ "status" A..= (400 :: Int)
        , "description" A..= ("formData: malformed" :: T.Text)
        , "error" A..= err
        ]
      else raw $ BL.unlines
        [ "formData: malformed"
        , "Error: " <> BL.fromStrict (encodeUtf8 err)
        ]
  PathParameterNotFound k -> do
    status status500
    if jsonMode
      then json $ A.object
        [ "status" A..= (500 :: Int)
        , "description" A..= T.unwords [ "Path parameter", k, "not found"]
        ]
      else text $ T.unwords [ "Path parameter", k, "not found"]
  QueryParameterNotFound k -> do
    status status400
    if jsonMode
      then json $ A.object
        [ "status" A..= (400 :: Int)
        , "description" A..= T.unwords [ "Query parameter", k, "not found"]
        ]
      else text $ T.unwords [ "Query parameter", k, "not found"]
  FormFieldNotFound k -> do
    status status400
    if jsonMode
      then json $ A.object
        [ "status" A..= (400 :: Int)
        , "description" A..= T.unwords [ "Form field", k, "not found"]
        ]
      else text $ T.unwords [ "Form field", k, "not found"]
  FailedToParseParameter k v e -> do
    status status400
    if jsonMode
      then json $ A.object
        [ "status" A..= (400 :: Int)
        , "description" A..= T.unwords [ "Failed to parse parameter", k, v, ":", e]
        ]
      else text $ T.unwords [ "Failed to parse parameter", k, v, ":", e]
  WarpRequestException we -> case we of
    RequestHeaderFieldsTooLarge -> do
      status status413
      if jsonMode
        then json $ A.object
          [ "status" A..= (413 :: Int)
          , "description" A..= ("Request header fields too large" :: T.Text)
          ]
        else text "Request header fields too large"
    weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here
      status status400
      if jsonMode
        then json $ A.object
          [ "status" A..= (400 :: Int)
          , "description" A..= T.unwords ["Request Exception:", T.pack (show weo)]
          ]
        else text $ T.unwords ["Request Exception:", T.pack (show weo)]
  WaiRequestParseException we -> do
    status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413
    if jsonMode
      then json $ A.object
        [ "status" A..= (413 :: Int)
        , "description" A..= T.unwords ["wai-extra Exception:", T.pack (show we)]
        ]
      else text $ T.unwords ["wai-extra Exception:", T.pack (show we)]
  ResourceTException rte -> do
    status status500
    if jsonMode
      then json $ A.object
        [ "status" A..= (500 :: Int)
        , "description" A..= T.unwords ["resourcet Exception:", T.pack (show rte)]
        ]
      else text $ T.unwords ["resourcet Exception:", T.pack (show rte)]

-- | Uncaught exceptions turn into HTTP 500 Server Error codes
someExceptionHandler :: MonadIO m => Options -> ErrorHandler m
someExceptionHandler Options{verbose, jsonMode} =
  Handler $ \(E.SomeException e) -> do
    when (verbose > 0) $
      liftIO $
      hPutStrLn stderr $
      "Unhandled exception of " <> show (typeOf e) <> ": " <> show e
    status status500
    if jsonMode
      then json $ A.object
        [ "status" A..= (500 :: Int)
        , "description" A..= ("Internal Server Error" :: T.Text)
        ]
      else text "Internal Server Error"

-- | Throw an exception which can be caught within the scope of the current Action with 'catch'.
--
-- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes.
--
-- Uncaught exceptions turn into HTTP 500 responses.
throw :: (MonadIO m, E.Exception e) => e -> ActionT m a
throw = E.throw

-- | Abort execution of this action and continue pattern matching routes.
-- Like an exception, any code after 'next' is not executed.
--
-- NB : Internally, this is implemented with an exception that can only be
-- caught by the library, but not by the user.
--
-- As an example, these two routes overlap. The only way the second one will
-- ever run is if the first one calls 'next'.
--
-- > get "/foo/:bar" $ do
-- >   w :: Text <- pathParam "bar"
-- >   unless (w == "special") next
-- >   text "You made a request to /foo/special"
-- >
-- > get "/foo/:baz" $ do
-- >   w <- pathParam "baz"
-- >   text $ "You made a request to: " <> w
next :: Monad m => ActionT m a
next = E.throw AENext

-- | Synonym for 'redirect302'.
-- If you are unsure which redirect to use, you probably want this one.
--
-- > redirect "http://www.google.com"
--
-- OR
--
-- > redirect "/foo/bar"
redirect :: (Monad m) => T.Text -> ActionT m a
redirect = redirect302

-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect300 :: (Monad m) => T.Text -> ActionT m a
redirect300 = redirectStatus status300

-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect301 :: (Monad m) => T.Text -> ActionT m a
redirect301 = redirectStatus status301

-- | Redirect to given URL with status 302 (Found). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect302 :: (Monad m) => T.Text -> ActionT m a
redirect302 = redirectStatus status302

-- | Redirect to given URL with status 303 (See Other). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect303 :: (Monad m) => T.Text -> ActionT m a
redirect303 = redirectStatus status303

-- | Redirect to given URL with status 304 (Not Modified). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect304 :: (Monad m) => T.Text -> ActionT m a
redirect304 = redirectStatus status304

-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect307 :: (Monad m) => T.Text -> ActionT m a
redirect307 = redirectStatus status307

-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing
-- an uncatchable exception. Any code after the call to
-- redirect will not be run.
redirect308 :: (Monad m) => T.Text -> ActionT m a
redirect308 = redirectStatus status308

redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a
redirectStatus s = E.throw . AERedirect s

-- | Finish the execution of the current action. Like throwing an uncatchable
-- exception. Any code after the call to finish will not be run.
--
-- /Since: 0.10.3/
finish :: (Monad m) => ActionT m a
finish = E.throw AEFinish

-- | Get the 'Request' object.
request :: Monad m => ActionT m Request
request = ActionT $ envReq <$> ask

-- | Get list of uploaded files.
--
-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions'
files :: MonadUnliftIO m => ActionT m [File BL.ByteString]
files = runResourceT $ withInternalState $ \istate -> do
  (_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
  for fs (\(fname, f) -> do
                   bs <- liftIO $ BL.readFile (W.fileContent f)
                   pure (fname, f{ W.fileContent = bs})
                   )


-- | Get list of uploaded temp files and form parameters decoded from multipart payloads.
--
-- NB the temp files are deleted when the continuation exits.
filesOpts :: MonadUnliftIO m =>
             W.ParseRequestBodyOptions
          -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc
          -> ActionT m a
filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do
  (ps, fs) <- formParamsAndFilesWith istate prbo
  io ps fs



-- | Get a request header. Header name is case-insensitive.
header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
header k = do
    hs <- requestHeaders <$> request
    return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs

-- | Get all the request headers. Header names are case-insensitive.
headers :: (Monad m) => ActionT m [(T.Text, T.Text)]
headers = do
    hs <- requestHeaders <$> request
    return [ ( decodeUtf8Lenient (CI.original k)
             , decodeUtf8Lenient v)
           | (k,v) <- hs ]

-- | Get the request body.
--
-- NB This loads the whole request body in memory at once.
body :: (MonadIO m) => ActionT m BL.ByteString
body = ActionT ask >>= (liftIO . envBody)

-- | Get an IO action that reads body chunks
--
-- * This is incompatible with 'body' since 'body' consumes all chunks.
bodyReader :: Monad m => ActionT m (IO B.ByteString)
bodyReader = ActionT $ envBodyChunk <$> ask

-- | Parse the request body as a JSON object and return it.
--
--   If the JSON object is malformed, this sets the status to
--   400 Bad Request, and throws an exception.
--
--   If the JSON fails to parse, this sets the status to
--   422 Unprocessable Entity.
--
--   These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html.
--
-- NB : Internally this uses 'body'.
jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a
jsonData = do
    b <- body
    when (b == "") $ throwIO $ MalformedJSON b "no data"
    case A.eitherDecode b of
      Left err -> throwIO $ MalformedJSON b $ T.pack err
      Right value -> case A.fromJSON value of
        A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err
        A.Success a -> return a

-- | Parse the request body as @x-www-form-urlencoded@ form data and return it.
--
--   The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the
--   status is set to 400 and an exception is thrown.
formData :: (FromForm a, MonadUnliftIO m) => ActionT m a
formData = do
  form <- paramListToForm <$> formParams
  case fromForm form of
    Left err -> throwIO $ MalformedForm err
    Right value -> return value
  where
    -- This rather contrived implementation uses cons and reverse to avoid
    -- quadratic complexity when constructing a Form from a list of Param.
    -- It's equivalent to using HashMap.insertWith (++) which does have
    -- quadratic complexity due to appending at the end of list.
    paramListToForm :: [Param] -> Form
    paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HM.alter (prependValue v) k f) HM.empty

    prependValue :: a -> Maybe [a] -> Maybe [a]
    prependValue v = Just . maybe [v] (v :)

-- | Synonym for 'pathParam'
captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
captureParam = pathParam

-- | Look up a path parameter.
--
-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client.
--
-- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.
--
-- /Since: 0.20/
pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
pathParam k = do
  val <- ActionT $ lookup k . envPathParams <$> ask
  case val of
    Nothing -> throwIO $ PathParameterNotFound k
    Just v -> case parseParam $ TL.fromStrict v of
      Left _ -> next
      Right a -> pure a

-- | Look up a form parameter.
--
-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.
--
-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.
--
-- /Since: 0.20/
formParam :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b
formParam k = runResourceT $ withInternalState $ \istate -> do
  (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
  case lookup k ps of
    Nothing -> throwIO $ FormFieldNotFound k
    Just v -> case parseParam $ TL.fromStrict v of
      Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)
      Right a -> pure a

-- | Look up a query parameter.
--
-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client.
--
-- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.
--
-- /Since: 0.20/
queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
queryParam = paramWith QueryParameterNotFound envQueryParams

-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
--
-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers
-- must 'raiseStatus' or 'throw' to signal something went wrong.
--
-- /Since: 0.21/
pathParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)
pathParamMaybe = paramWithMaybe envPathParams

-- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
--
-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers
-- must 'raiseStatus' or 'throw' to signal something went wrong.
--
-- /Since: 0.21/
captureParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)
captureParamMaybe = paramWithMaybe envPathParams

-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
--
-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.
--
-- /Since: 0.21/
formParamMaybe :: (MonadUnliftIO m, Parsable a) =>
                  T.Text -> ActionT m (Maybe a)
formParamMaybe k = runResourceT $ withInternalState $ \istate -> do
  (ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
  case lookup k ps of
    Nothing -> pure Nothing
    Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v


-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
--
-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.
--
-- /Since: 0.21/
queryParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)
queryParamMaybe = paramWithMaybe envQueryParams

data ParamType = PathParam
               | FormParam
               | QueryParam
instance Show ParamType where
  show = \case
    PathParam -> "path"
    FormParam -> "form"
    QueryParam -> "query"

paramWith :: (MonadIO m, Parsable b) =>
             (T.Text -> ScottyException)
          -> (ActionEnv -> [Param])
          -> T.Text -- ^ parameter name
          -> ActionT m b
paramWith toError f k = do
    val <- ActionT $ (lookup k . f) <$> ask
    case val of
      Nothing -> throwIO $ toError k
      Just v -> case parseParam $ TL.fromStrict v of
        Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)
        Right a -> pure a

-- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
--
-- NB : Doesn't throw exceptions.
--
-- /Since: 0.21/
paramWithMaybe :: (Monad m, Parsable b) =>
                  (ActionEnv -> [Param])
               -> T.Text -- ^ parameter name
               -> ActionT m (Maybe b)
paramWithMaybe f k = do
    val <- ActionT $ asks (lookup k . f)
    case val of
      Nothing -> pure Nothing
      Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v

-- | Get path parameters
pathParams :: Monad m => ActionT m [Param]
pathParams = paramsWith envPathParams

-- | Get path parameters
captureParams :: Monad m => ActionT m [Param]
captureParams = paramsWith envPathParams

-- | Get form parameters
formParams :: MonadUnliftIO m => ActionT m [Param]
formParams = runResourceT $ withInternalState $ \istate -> do
  fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions

-- | Get query parameters
queryParams :: Monad m => ActionT m [Param]
queryParams = paramsWith envQueryParams

paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a
paramsWith f = ActionT (asks f)

-- === access the fields of the Response being constructed

-- | Access the HTTP 'Status' of the Response
--
-- /SINCE 0.21/
getResponseStatus :: (MonadIO m) => ActionT m Status
getResponseStatus = srStatus <$> getResponseAction
-- | Access the HTTP headers of the Response
--
-- /SINCE 0.21/
getResponseHeaders :: (MonadIO m) => ActionT m ResponseHeaders
getResponseHeaders = srHeaders <$> getResponseAction
-- | Access the content of the Response
--
-- /SINCE 0.21/
getResponseContent :: (MonadIO m) => ActionT m Content
getResponseContent = srContent <$> getResponseAction


-- | Minimum implemention: 'parseParam'
class Parsable a where
    -- | Take a 'T.Text' value and parse it as 'a', or fail with a message.
    parseParam :: TL.Text -> Either TL.Text a

    -- | Default implementation parses comma-delimited lists.
    --
    -- > parseParamList t = mapM parseParam (T.split (== ',') t)
    parseParamList :: TL.Text -> Either TL.Text [a]
    parseParamList t = mapM parseParam (TL.split (== ',') t)

-- No point using 'read' for Text, ByteString, Char, and String.
instance Parsable T.Text where parseParam = Right . TL.toStrict
instance Parsable TL.Text where parseParam = Right
instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString
instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8
-- | Overrides default 'parseParamList' to parse String.
instance Parsable Char where
    parseParam t = case TL.unpack t of
                    [c] -> Right c
                    _   -> Left "parseParam Char: no parse"
    parseParamList = Right . TL.unpack -- String
-- | Checks if parameter is present and is null-valued, not a literal '()'.
-- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not.
instance Parsable () where
    parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse"

instance (Parsable a) => Parsable [a] where parseParam = parseParamList

instance Parsable Bool where
    parseParam t = if t' == TL.toCaseFold "true" || t' == TL.toCaseFold "on"
                   then Right True
                   else if t' == TL.toCaseFold "false"
                        then Right False
                        else Left "parseParam Bool: no parse"
        where t' = TL.toCaseFold t

instance Parsable Double where parseParam = readEither
instance Parsable Float where parseParam = readEither

instance Parsable Int where parseParam = readEither
instance Parsable Int8 where parseParam = readEither
instance Parsable Int16 where parseParam = readEither
instance Parsable Int32 where parseParam = readEither
instance Parsable Int64 where parseParam = readEither
instance Parsable Integer where parseParam = readEither

instance Parsable Word where parseParam = readEither
instance Parsable Word8 where parseParam = readEither
instance Parsable Word16 where parseParam = readEither
instance Parsable Word32 where parseParam = readEither
instance Parsable Word64 where parseParam = readEither
instance Parsable Natural where parseParam = readEither

-- | parse a UTCTime timestamp formatted as a ISO 8601 timestamp:
--
-- @yyyy-mm-ddThh:mm:ssZ@ , where the seconds can have a decimal part with up to 12 digits and no trailing zeros.
instance Parsable UTCTime where
    parseParam t =
      let
        fmt = "%FT%T%QZ"
      in
        case parseTimeM True defaultTimeLocale fmt (TL.unpack t) of
            Just d -> Right d
            _      -> Left $ "parseParam UTCTime: no parse of \"" <> t <> "\""

-- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex:
--
-- > instance Parsable Int where parseParam = readEither
readEither :: Read a => TL.Text -> Either TL.Text a
readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of
                [x] -> Right x
                []  -> Left "readEither: no parse"
                _   -> Left "readEither: ambiguous parse"

-- | Set the HTTP response status.
status :: MonadIO m => Status -> ActionT m ()
status = modifyResponse . setStatus

-- Not exported, but useful in the functions below.
changeHeader :: MonadIO m
             => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])
             -> T.Text -> T.Text -> ActionT m ()
changeHeader f k =
  modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8

-- | Add to the response headers. Header names are case-insensitive.
addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
addHeader = changeHeader add

-- | Set one of the response headers. Will override any previously set value for that header.
-- Header names are case-insensitive.
setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
setHeader = changeHeader replace

-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
-- header to \"text/plain; charset=utf-8\" if it has not already been set.
text :: (MonadIO m) => T.Text -> ActionT m ()
text t = do
    changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"
    raw $ BL.fromStrict $ encodeUtf8 t

-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
-- header to \"text/plain; charset=utf-8\" if it has not already been set.
textLazy :: (MonadIO m) => TL.Text -> ActionT m ()
textLazy t = do
    changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"
    raw $ TLE.encodeUtf8 t

-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
-- header to \"text/html; charset=utf-8\" if it has not already been set.
html :: (MonadIO m) => T.Text -> ActionT m ()
html t = do
    changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"
    raw $ BL.fromStrict $ encodeUtf8 t

-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
-- header to \"text/html; charset=utf-8\" if it has not already been set.
htmlLazy :: (MonadIO m) => TL.Text -> ActionT m ()
htmlLazy t = do
    changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"
    raw $ TLE.encodeUtf8 t

-- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably
-- want to do that on your own with 'setHeader'. Setting a status code will have no effect
-- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse').
file :: MonadIO m => FilePath -> ActionT m ()
file = modifyResponse . setContent . ContentFile

rawResponse :: MonadIO m => Response -> ActionT m ()
rawResponse = modifyResponse . setContent . ContentResponse

-- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\"
-- header to \"application/json; charset=utf-8\" if it has not already been set.
json :: (A.ToJSON a, MonadIO m) => a -> ActionT m ()
json v = do
    changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8"
    raw $ A.encode v

-- | Set the body of the response to a Source. Doesn't set the
-- \"Content-Type\" header, so you probably want to do that on your
-- own with 'setHeader'.
stream :: MonadIO m => StreamingBody -> ActionT m ()
stream = modifyResponse . setContent . ContentStream

-- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the
-- \"Content-Type\" header, so you probably want to do that on your
-- own with 'setHeader'.
raw :: MonadIO m => BL.ByteString -> ActionT m ()
raw = modifyResponse . setContent . ContentBuilder . fromLazyByteString

-- | Nest a whole WAI application inside a Scotty handler.
-- See Web.Scotty for further documentation
nested :: (MonadIO m) => Network.Wai.Application -> ActionT m ()
nested app = do
  -- Is MVar really the best choice here? Not sure.
  r <- request
  ref <- liftIO $ newEmptyMVar
  _ <- liftIO $ app r (\res -> putMVar ref res >> return ResponseReceived)
  res <- liftIO $ readMVar ref
  rawResponse res