{-# 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 :: forall site. YesodDispatch site => site -> IO Application
toWaiAppPlain site
site = do
    Logger
logger <- forall site. Yesod site => site -> IO Logger
makeLogger site
site
    Maybe SessionBackend
sb <- forall site. Yesod site => site -> IO (Maybe SessionBackend)
makeSessionBackend site
site
    IO Text
getMaxExpires <- IO (IO Text)
getGetMaxExpires
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
toWaiAppYre 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getEntropy Int
bytes
  where
    bits :: Int
bits = forall b. FiniteBits b => b -> Int
finiteBitSize (forall a. HasCallStack => a
undefined :: Int)
    bytes :: Int
bytes = forall a. Integral a => a -> a -> a
div (Int
bits forall a. Num a => a -> a -> a
+ Int
7) Int
8
    bsToInt :: ByteString -> Int
bsToInt = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' (\Int
v Word8
i -> forall a. Bits a => a -> Int -> a
shiftL Int
v Int
8 forall a. Bits a => a -> a -> a
.|. 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 :: forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
toWaiAppYre YesodRunnerEnv site
yre Request
req =
    case forall site. Yesod site => site -> [Text] -> Either [Text] [Text]
cleanPath site
site forall a b. (a -> b) -> a -> b
$ Request -> [Text]
W.pathInfo Request
req of
        Left [Text]
pieces -> forall master. Yesod master => master -> [Text] -> Application
sendRedirect site
site [Text]
pieces Request
req
        Right [Text]
pieces -> forall site.
YesodDispatch site =>
YesodRunnerEnv site -> Application
yesodDispatch YesodRunnerEnv site
yre Request
req
            { pathInfo :: [Text]
W.pathInfo = [Text]
pieces
            }
  where
    site :: site
site = forall site. YesodRunnerEnv site -> site
yreSite YesodRunnerEnv site
yre
    sendRedirect :: Yesod master => master -> [Text] -> W.Application
    sendRedirect :: forall master. Yesod master => master -> [Text] -> Application
sendRedirect master
y [Text]
segments' Request
env Response -> IO ResponseReceived
sendResponse =
         Response -> IO ResponseReceived
sendResponse 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 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 forall a. Eq a => a -> a -> Bool
== ByteString
"GET" = Status
status301
            | Bool
otherwise                    = Status
status307

        dest :: Builder
dest = forall site.
Yesod site =>
site -> Text -> [Text] -> [(Text, Text)] -> Builder
joinPath master
y (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 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 :: forall site. YesodDispatch site => site -> IO Application
toWaiApp site
site = do
    Logger
logger <- forall site. Yesod site => site -> IO Logger
makeLogger site
site
    forall site. YesodDispatch site => Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site

toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger :: forall site. YesodDispatch site => Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site = do
    Maybe SessionBackend
sb <- forall site. Yesod site => site -> IO (Maybe SessionBackend)
makeSessionBackend site
site
    IO Text
getMaxExpires <- IO (IO Text)
getGetMaxExpires
    let yre :: YesodRunnerEnv site
yre = 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
                }
    forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource
        site
site
        Logger
logger
        $(qLocation >>= liftLoc)
        Text
"yesod-core"
        LogLevel
LevelInfo
        (forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString
"Application launched" :: S.ByteString))
    Middleware
middleware <- Logger -> IO Middleware
mkDefaultMiddlewares Logger
logger
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Middleware
middleware forall a b. (a -> b) -> a -> b
$ 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 :: forall site. YesodDispatch site => Int -> site -> IO ()
warp Int
port site
site = do
    Logger
logger <- forall site. Yesod site => site -> IO Logger
makeLogger site
site
    forall site. YesodDispatch site => Logger -> site -> IO Application
toWaiAppLogger Logger
logger site
site 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 forall a b. (a -> b) -> a -> b
$
        ByteString -> Settings -> Settings
Network.Wai.Handler.Warp.setServerName ByteString
serverValue forall a b. (a -> b) -> a -> b
$
        (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Network.Wai.Handler.Warp.setOnException (\Maybe Request
_ SomeException
e ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
shouldLog' SomeException
e) forall a b. (a -> b) -> a -> b
$
                forall site.
Yesod site =>
site -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
messageLoggerSource
                    site
site
                    Logger
logger
                    $(qLocation >>= liftLoc)
                    Text
"yesod-core"
                    LogLevel
LevelError
                    (forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ [Char]
"Exception from Warp: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
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 = [Char] -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Warp/"
    , [Char]
Network.Wai.Handler.Warp.warpVersion
    , [Char]
" + Yesod/"
    , Version -> [Char]
showVersion Version
Paths_yesod_core.version
    , [Char]
" (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 forall a. Default a => a
def
        { destination :: Destination
destination = LoggerSet -> Destination
Network.Wai.Middleware.RequestLogger.Logger forall a b. (a -> b) -> a -> b
$ Logger -> LoggerSet
loggerSet Logger
logger
        , outputFormat :: OutputFormat
outputFormat = IPAddrSource -> OutputFormat
Apache IPAddrSource
FromSocket
        }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Middleware
logWare 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
autohead forall b c a. (b -> c) -> (a -> b) -> a -> c
. GzipSettings -> Middleware
gzip forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
methodOverride

-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug :: forall site. YesodDispatch site => Int -> site -> IO ()
warpDebug = 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 :: forall site. YesodDispatch site => site -> IO ()
warpEnv site
site = do
    [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"PORT" [([Char], [Char])]
env of
        Maybe [Char]
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"warpEnv: no PORT environment variable found"
        Just [Char]
portS ->
            case forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
portS of
                Maybe Int
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"warpEnv: invalid PORT environment variable: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
portS
                Just Int
port -> 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 = forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings
  { updateAction :: IO Text
updateAction = IO Text
getCurrentMaxExpiresRFC1123
  , updateFreq :: Int
updateFreq = Int
24 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
* Int
1000000 -- Update once per day
  }