Dispatch.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Yesod.Core.Dispatch
    ( -- * Quasi-quoted routing
      parseRoutes
    , parseRoutesNoCheck
    , parseRoutesFile
    , parseRoutesFileNoCheck
    , mkYesod
    , mkYesodOpts
    , mkYesodWith
      -- ** More fine-grained
    , mkYesodData
    , mkYesodDataOpts
    , mkYesodSubData
    , mkYesodSubDataOpts
    , mkYesodDispatch
    , mkYesodDispatchOpts
    , mkYesodSubDispatch
    , mkYesodSubDispatchInstance
    , mkYesodSubDispatchInstanceOpts
      -- *** Splitting a subsite's nested routes across modules
      --
      -- | These re-exports let a separately-compiled module generate a
      -- subsite's @YesodSubDispatchNested@ instance by hand (see the
      -- subsite-route-splitting recipe in @docs/split-route-compilation.md@).
      -- 'mkNestedSubDispatchInstance' takes the resources as
      -- @['ResourceTree' 'String']@ (the 'parseRoutes' quasi-quoter's output)
      -- and parses them internally, so no manual type-parsing is needed.

      -- | @since 1.7.0.0
    , mkNestedSubDispatchInstance
      -- | @since 1.7.0.0
    , TyArgs (..)
      -- *** Route generation options
    , RouteOpts
    , defaultOpts
    , setEqDerived
    , setShowDerived
    , setReadDerived
    , setCreateResources
    , setFocusOnNestedRoute
    , unsetFocusOnNestedRoute
    , setParameterizedSubroute
    , setNestedRouteFallthrough
      -- *** Helpers
    , defaultGen
    , getGetMaxExpires
      -- ** Path pieces
    , PathPiece (..)
    , PathMultiPiece (..)
    , Texts
      -- * Convert to WAI
    , toWaiApp
    , toWaiAppPlain
    , UrlToDispatch(..)
    , mkYesodRunnerEnv
    , toWaiAppPlainNested
    , toWaiAppYre
    , toWaiAppYreNested
    , warp
    , warpDebug
    , warpEnv
    , mkDefaultMiddlewares
    , defaultMiddlewaresNoLogging
      -- * Subsite nested dispatch
    , YesodSubDispatchNested (..)
      -- * WAI subsites
    , WaiSubsite (..)
    , WaiSubsiteWithAuth (..)
    ) where

import Prelude hiding (exp)
import Yesod.Core.Internal.TH
import Language.Haskell.TH.Syntax (qLocation)
import Data.Proxy
import Yesod.Routes.Class

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.Char8 as S8
#if !MIN_VERSION_wai_extra(3,1,14)
import Data.Default (def)
#endif
import Yesod.Routes.Parse
import Yesod.Routes.TH (TyArgs (..))
import Yesod.Core.Types
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
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 Yesod.Core.Class.Dispatch.ToParentRoute

import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Gzip (
    gzip,
#if MIN_VERSION_wai_extra(3,1,14)
    defaultGzipSettings,
#endif
 )
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 = do
    yre <- mkYesodRunnerEnv site
    return $ toWaiAppYre yre

-- | Construct a 'YesodRunnerEnv' for a site, initializing its logger, session
-- backend, and other runtime state. This is the environment threaded through
-- dispatch; 'toWaiAppPlain' and friends build one for you, but it is exposed so
-- callers can construct and reuse a runner environment directly.
--
-- @since 1.7.0.0
mkYesodRunnerEnv :: Yesod site => site -> IO (YesodRunnerEnv site)
mkYesodRunnerEnv site = do
    logger <- makeLogger site
    sb <- makeSessionBackend site
    getMaxExpires <- getGetMaxExpires
    pure YesodRunnerEnv
        { yreLogger = logger
        , yreSite = site
        , yreSessionBackend = sb
        , yreGen = defaultGen
        , yreGetMaxExpires = getMaxExpires
        }

-- | 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'.
--
-- This function allows you to create an 'Application' that only responds
-- to a subset of the 'site' routes. This is really only useful for writing
-- tests, but it does allow you to write tests that only depend on a subset
-- of the handlers instead of all handlers.
--
-- @since 1.7.0.0
toWaiAppPlainNested
    :: ( site ~ ParentSite route
        , Yesod site
        , YesodDispatchNested route
        , ToParentRoute route
        )
    => Proxy route
    -> ParentArgs route
    -> site
    -> IO W.Application
toWaiAppPlainNested proxy parentArgs site = do
    yre <- mkYesodRunnerEnv site
    return $ toWaiAppYreNested proxy parentArgs yre

-- | 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 = bsToInt <$> getEntropy bytes
  where
    bits = finiteBitSize (undefined :: Int)
    bytes = div (bits + 7) 8
    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 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 = toWaiAppYreNested (Proxy :: Proxy (Route site)) ()

-- | 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 = do
    logger <- makeLogger site
    toWaiAppLogger logger site

toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger logger site = do
    sb <- makeSessionBackend site
    getMaxExpires <- getGetMaxExpires
    let yre = YesodRunnerEnv
                { yreLogger = logger
                , yreSite = site
                , yreSessionBackend = sb
                , yreGen = defaultGen
                , yreGetMaxExpires = getMaxExpires
                }
    messageLoggerSource
        site
        logger
        $(qLocation >>= liftLoc)
        "yesod-core"
        LevelInfo
        (toLogStr ("Application launched" :: S.ByteString))
    middleware <- mkDefaultMiddlewares logger
    return $ middleware $ toWaiAppYre 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 port site = do
    logger <- makeLogger site
    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
        Network.Wai.Handler.Warp.setPort port $
        Network.Wai.Handler.Warp.setServerName serverValue $
        Network.Wai.Handler.Warp.setOnException (\_ e ->
                when (shouldLog' e) $
                messageLoggerSource
                    site
                    logger
                    $(qLocation >>= liftLoc)
                    "yesod-core"
                    LevelError
                    (toLogStr $ "Exception from Warp: " ++ show e))
        Network.Wai.Handler.Warp.defaultSettings)
  where
    shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException

serverValue :: S8.ByteString
serverValue = S8.pack $ concat
    [ "Warp/"
    , Network.Wai.Handler.Warp.warpVersion
    , " + Yesod/"
    , showVersion Paths_yesod_core.version
    , " (core)"
    ]

-- | A default set of middlewares.
--
-- Since 1.2.0
mkDefaultMiddlewares :: Logger -> IO W.Middleware
mkDefaultMiddlewares logger = do
    logWare <- mkRequestLogger
#if MIN_VERSION_wai_extra(3,1,8)
        defaultRequestLoggerSettings
#else
        def
#endif
        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
        , outputFormat = Apache FromSocket
        }
    return $ logWare . defaultMiddlewaresNoLogging

-- | All of the default middlewares, excluding logging.
--
-- Since 1.2.12
defaultMiddlewaresNoLogging :: W.Middleware
defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip gzipSettings . methodOverride
  where
    gzipSettings =
#if MIN_VERSION_wai_extra(3,1,14)
        defaultGzipSettings
#else
        def
#endif

-- | Deprecated synonym for 'warp'.
warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug = 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 = do
    env <- getEnvironment
    case lookup "PORT" env of
        Nothing -> error "warpEnv: no PORT environment variable found"
        Just portS ->
            case readMaybe portS of
                Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
                Just port -> warp port site

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