{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Core.Dispatch
    ( -- * Quasi-quoted routing
      parseRoutes
    , parseRoutesNoCheck
    , parseRoutesFile
    , parseRoutesFileNoCheck
    , mkYesod
    , mkYesodWith
      -- ** More fine-grained
    , mkYesodData
    , mkYesodSubData
    , mkYesodDispatch
    , mkYesodSubDispatch
      -- *** Helpers
    , defaultGen
    , getGetMaxExpires
      -- ** Path pieces
    , PathPiece (..)
    , PathMultiPiece (..)
    , Texts
      -- * Convert to WAI
    , toWaiApp
    , toWaiAppPlain
    , toWaiAppYre
    , warp
    , warpDebug
    , warpEnv
    , mkDefaultMiddlewares
    , defaultMiddlewaresNoLogging
      -- * WAI subsites
    , WaiSubsite (..)
    , WaiSubsiteWithAuth (..)
    ) where

import Prelude hiding (exp)
import Yesod.Core.Internal.TH
import Language.Haskell.TH.Syntax (qLocation)

import Web.PathPieces

import qualified Network.Wai as W

import Data.ByteString.Lazy.Char8 ()

import Data.Bits ((.|.), finiteBitSize, shiftL)
import Data.Text (Text)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Builder (byteString, toLazyByteString)
import Network.HTTP.Types (status301, status307)
import Yesod.Routes.Parse
import Yesod.Core.Types
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
import Text.Read (readMaybe)
import System.Environment (getEnvironment)
import System.Entropy (getEntropy)
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)

import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.MethodOverride

import qualified Network.Wai.Handler.Warp
import System.Log.FastLogger
import Control.Monad.Logger
import Control.Monad (when)
import qualified Paths_yesod_core
import Data.Version (showVersion)

-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This function will provide no middlewares; if you want commonly
-- used middlewares, please use 'toWaiApp'.
toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
toWaiAppPlain :: site -> IO Application
toWaiAppPlain site
site = do
    Logger
logger <- site -> IO Logger
forall site. Yesod site => site -> IO Logger
makeLogger site
site
    Maybe SessionBackend
sb <- site -> IO (Maybe SessionBackend)
forall site. Yesod site => site -> IO (Maybe SessionBackend)
makeSessionBackend site
site
    IO Text
getMaxExpires <- IO (IO Text)
getGetMaxExpires
    Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv site -> Application
forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
toWaiAppYre YesodRunnerEnv :: forall site.
Logger
-> site
-> Maybe SessionBackend
-> IO Int
-> IO Text
-> YesodRunnerEnv site
YesodRunnerEnv
            { yreLogger :: Logger
yreLogger = Logger
logger
            , yreSite :: site
yreSite = site
site
            , yreSessionBackend :: Maybe SessionBackend
yreSessionBackend = Maybe SessionBackend
sb
            , yreGen :: IO Int
yreGen = IO Int
defaultGen
            , yreGetMaxExpires :: IO Text
yreGetMaxExpires = IO Text
getMaxExpires
            }

-- | Generate a random number uniformly distributed in the full range
-- of 'Int'.
--
-- Note: Before 1.6.20, this generates pseudo-random number in an
-- unspecified range. The range size may not be a power of 2. Since
-- 1.6.20, this uses a secure entropy source and generates in the full
-- range of 'Int'.
--
-- @since 1.6.21.0
defaultGen :: IO Int
defaultGen :: IO Int
defaultGen = ByteString -> Int
bsToInt (ByteString -> Int) -> IO ByteString -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
bytes
  where
    bits :: Int
bits = Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
forall a. HasCallStack => a
undefined :: Int)
    bytes :: Int
bytes = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int
8
    bsToInt :: ByteString -> Int
bsToInt = (Int -> Word8 -> Int) -> Int -> ByteString -> Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' (\Int
v Word8
i -> Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
v Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i) Int
0

-- | Pure low level function to construct WAI application. Usefull
-- when you need not standard way to run your app, or want to embed it
-- inside another app.
--
-- @since 1.4.29
toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application
toWaiAppYre :: YesodRunnerEnv site -> Application
toWaiAppYre YesodRunnerEnv site
yre Request
req =
    case site -> [Text] -> Either [Text] [Text]
forall site. Yesod site => site -> [Text] -> Either [Text] [Text]
cleanPath site
site ([Text] -> Either [Text] [Text]) -> [Text] -> Either [Text] [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
W.pathInfo Request
req of
        Left [Text]
pieces -> site -> [Text] -> Application
forall master. Yesod master => master -> [Text] -> Application
sendRedirect site
site [Text]
pieces Request
req
        Right [Text]
pieces -> YesodRunnerEnv site -> Application
forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
yesodDispatch YesodRunnerEnv site
yre Request
req
            { pathInfo :: [Text]
W.pathInfo = [Text]
pieces
            }
  where
    site :: site
site = YesodRunnerEnv site -> site
forall site. YesodRunnerEnv site -> site
yreSite YesodRunnerEnv site
yre
    sendRedirect :: Yesod master => master -> [Text] -> W.Application
    sendRedirect :: master -> [Text] -> Application
sendRedirect master
y [Text]
segments' Request
env Response -> IO ResponseReceived
sendResponse =
         Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
status
                [ (HeaderName
"Content-Type", ByteString
"text/plain")
                , (HeaderName
"Location", ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
dest')
                ] ByteString
"Redirecting"
      where
        -- Ensure that non-GET requests get redirected correctly. See:
        -- https://github.com/yesodweb/yesod/issues/951
        status :: Status
status
            | Request -> ByteString
W.requestMethod Request
env ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GET" = Status
status301
            | Bool
otherwise                    = Status
status307

        dest :: Builder
dest = master -> Text -> [Text] -> [(Text, Text)] -> Builder
forall site.
Yesod site =>
site -> Text -> [Text] -> [(Text, Text)] -> Builder
joinPath master
y (master -> Request -> Text
forall master. Yesod master => master -> Request -> Text
resolveApproot master
y Request
env) [Text]
segments' []
        dest' :: Builder
dest' =
            if ByteString -> Bool
S.null (Request -> ByteString
W.rawQueryString Request
env)
                then Builder
dest
                else Builder
dest Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                     ByteString -> Builder
byteString (Request -> ByteString
W.rawQueryString Request
env)

-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
-- set may change with future releases, but currently covers:
--
-- * Logging
--
-- * GZIP compression
--
-- * Automatic HEAD method handling
--
-- * Request method override with the _method query string parameter
--
-- * Accept header override with the _accept query string parameter
toWaiApp :: YesodDispatch site => site -> IO W.Application
toWaiApp :: site -> IO Application
toWaiApp site
site = do
    Logger
logger <- site -> IO Logger
forall site. Yesod site => site -> IO Logger
makeLogger site
site
    Logger -> site -> IO Application
forall site. YesodDispatch site => Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site

toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger :: Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site = do
    Maybe SessionBackend
sb <- site -> IO (Maybe SessionBackend)
forall site. Yesod site => site -> IO (Maybe SessionBackend)
makeSessionBackend site
site
    IO Text
getMaxExpires <- IO (IO Text)
getGetMaxExpires
    let yre :: YesodRunnerEnv site
yre = YesodRunnerEnv :: forall site.
Logger
-> site
-> Maybe SessionBackend
-> IO Int
-> IO Text
-> YesodRunnerEnv site
YesodRunnerEnv
                { yreLogger :: Logger
yreLogger = Logger
logger
                , yreSite :: site
yreSite = site
site
                , yreSessionBackend :: Maybe SessionBackend
yreSessionBackend = Maybe SessionBackend
sb
                , yreGen :: IO Int
yreGen = IO Int
defaultGen
                , yreGetMaxExpires :: IO Text
yreGetMaxExpires = IO Text
getMaxExpires
                }
    site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource
        site
site
        Logger
logger
        $(qLocation >>= liftLoc)
        Text
"yesod-core"
        LogLevel
LevelInfo
        (ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString
"Application launched" :: S.ByteString))
    Middleware
middleware <- Logger -> IO Middleware
mkDefaultMiddlewares Logger
logger
    Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Middleware
middleware Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv site -> Application
forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
toWaiAppYre YesodRunnerEnv site
yre

-- | A convenience method to run an application using the Warp webserver on the
-- specified port. Automatically calls 'toWaiApp'. Provides a default set of
-- middlewares. This set may change at any point without a breaking version
-- number. Currently, it includes:
--
-- * Logging
--
-- * GZIP compression
--
-- * Automatic HEAD method handling
--
-- * Request method override with the _method query string parameter
--
-- * Accept header override with the _accept query string parameter
--
-- If you need more fine-grained control of middlewares, please use 'toWaiApp'
-- directly.
--
-- Since 1.2.0
warp :: YesodDispatch site => Int -> site -> IO ()
warp :: Int -> site -> IO ()
warp Int
port site
site = do
    Logger
logger <- site -> IO Logger
forall site. Yesod site => site -> IO Logger
makeLogger site
site
    Logger -> site -> IO Application
forall site. YesodDispatch site => Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site IO Application -> (Application -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Settings -> Application -> IO ()
Network.Wai.Handler.Warp.runSettings (
        Int -> Settings -> Settings
Network.Wai.Handler.Warp.setPort Int
port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        ByteString -> Settings -> Settings
Network.Wai.Handler.Warp.setServerName ByteString
serverValue (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
        (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Network.Wai.Handler.Warp.setOnException (\Maybe Request
_ SomeException
e ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
shouldLog' SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource
                    site
site
                    Logger
logger
                    $(qLocation >>= liftLoc)
                    Text
"yesod-core"
                    LogLevel
LevelError
                    (String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ String
"Exception from Warp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
        Settings
Network.Wai.Handler.Warp.defaultSettings)
  where
    shouldLog' :: SomeException -> Bool
shouldLog' = SomeException -> Bool
Network.Wai.Handler.Warp.defaultShouldDisplayException

serverValue :: S8.ByteString
serverValue :: ByteString
serverValue = String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Warp/"
    , String
Network.Wai.Handler.Warp.warpVersion
    , String
" + Yesod/"
    , Version -> String
showVersion Version
Paths_yesod_core.version
    , String
" (core)"
    ]

-- | A default set of middlewares.
--
-- Since 1.2.0
mkDefaultMiddlewares :: Logger -> IO W.Middleware
mkDefaultMiddlewares :: Logger -> IO Middleware
mkDefaultMiddlewares Logger
logger = do
    Middleware
logWare <- RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings
forall a. Default a => a
def
        { destination :: Destination
destination = LoggerSet -> Destination
Network.Wai.Middleware.RequestLogger.Logger (LoggerSet -> Destination) -> LoggerSet -> Destination
forall a b. (a -> b) -> a -> b
$ Logger -> LoggerSet
loggerSet Logger
logger
        , outputFormat :: OutputFormat
outputFormat = IPAddrSource -> OutputFormat
Apache IPAddrSource
FromSocket
        }
    Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ Middleware
logWare Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
defaultMiddlewaresNoLogging

-- | All of the default middlewares, excluding logging.
--
-- Since 1.2.12
defaultMiddlewaresNoLogging :: W.Middleware
defaultMiddlewaresNoLogging :: Middleware
defaultMiddlewaresNoLogging = Middleware
acceptOverride Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
autohead Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
methodOverride

-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug :: Int -> site -> IO ()
warpDebug = Int -> site -> IO ()
forall site. YesodDispatch site => Int -> site -> IO ()
warp
{-# DEPRECATED warpDebug "Please use warp instead" #-}

-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It
-- reads port information from the PORT environment variable, as used by tools
-- such as Keter and the FP Complete School of Haskell.
--
-- Note that the exact behavior of this function may be modified slightly over
-- time to work correctly with external tools, without a change to the type
-- signature.
warpEnv :: YesodDispatch site => site -> IO ()
warpEnv :: site -> IO ()
warpEnv site
site = do
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"PORT" [(String, String)]
env of
        Maybe String
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"warpEnv: no PORT environment variable found"
        Just String
portS ->
            case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
portS of
                Maybe Int
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"warpEnv: invalid PORT environment variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
portS
                Just Int
port -> Int -> site -> IO ()
forall site. YesodDispatch site => Int -> site -> IO ()
warp Int
port site
site

-- | Default constructor for 'yreGetMaxExpires' field. Low level
-- function for simple manual construction of 'YesodRunnerEnv'.
--
-- @since 1.4.29
getGetMaxExpires :: IO (IO Text)
getGetMaxExpires :: IO (IO Text)
getGetMaxExpires = UpdateSettings Text -> IO (IO Text)
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings
  { updateAction :: IO Text
updateAction = IO Text
getCurrentMaxExpiresRFC1123
  , updateFreq :: Int
updateFreq = Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000 -- Update once per day
  }