module Yesod.Internal.Core
(
Yesod (..)
, YesodDispatch (..)
, RenderRoute (..)
, YesodBreadcrumbs (..)
, breadcrumbs
, maybeAuthorized
, widgetToPageContent
, defaultErrorHandler
, AuthResult (..)
, SessionBackend (..)
, defaultClientSessionBackend
, clientSessionBackend
, loadClientSession
, clientSessionBackend2
, loadClientSession2
, clientSessionDateCacher
, BackendSession
, ScriptLoadPosition (..)
, BottomOfHeadAsync
, loadJsYepnope
, yesodVersion
, yesodRender
, resolveApproot
, Approot (..)
, FileUpload (..)
, runFakeHandler
) where
import Yesod.Content
import Yesod.Handler hiding (lift, getExpires)
import Control.Monad.Logger (logErrorS)
import Yesod.Routes.Class
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
import Data.Word (Word64)
import Control.Arrow ((***))
import Control.Monad (forM)
import Yesod.Widget
import Yesod.Request
import qualified Network.Wai as W
import Yesod.Internal
import Yesod.Internal.Session
import Yesod.Internal.Request
import qualified Web.ClientSession as CS
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.IORef as I
import Data.Monoid
import Text.Hamlet
import Text.Julius
import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
import qualified Text.Blaze.Html5 as TBH
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Maybe (fromMaybe, isJust)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Resource (runResourceT)
import Web.Cookie (parseCookies)
import qualified Data.Map as Map
import Network.HTTP.Types (encodePath)
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import Blaze.ByteString.Builder (Builder, toByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.List (foldl')
import qualified Network.HTTP.Types as H
import Web.Cookie (SetCookie (..))
import Language.Haskell.TH.Syntax (Loc (..))
import Text.Blaze (preEscapedToMarkup)
import Data.Aeson (Value (Array, String))
import Data.Aeson.Encode (encode)
import qualified Data.Vector as Vector
import Network.Wai.Middleware.Gzip (GzipSettings, def)
import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)
import qualified Paths_yesod_core
import Data.Version (showVersion)
import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
import System.Log.FastLogger.Date (ZonedDate)
import System.IO (stdout)
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> Logger
-> master
-> sub
-> (Route sub -> Route master)
-> (Maybe (SessionBackend master) -> W.Application)
-> (Route sub -> Maybe (SessionBackend master) -> W.Application)
-> Text
-> [Text]
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner :: Yesod master
=> Logger
-> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe (SessionBackend master)
-> W.Application
yesodRunner = defaultYesodRunner
data Approot master = ApprootRelative
| ApprootStatic Text
| ApprootMaster (master -> Text)
| ApprootRequest (master -> W.Request -> Text)
type ResolvedApproot = Text
class RenderRoute a => Yesod a where
approot :: Approot a
approot = ApprootRelative
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
errorHandler = defaultErrorHandler
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
hamletToRepHtml [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>#{pageTitle p}
^{pageHead p}
<body>
$maybe msg <- mmsg
<p .message>#{msg}
^{pageBody p}
|]
urlRenderOverride :: a -> Route a -> Maybe Builder
urlRenderOverride _ _ = Nothing
isAuthorized :: Route a
-> Bool
-> GHandler s a AuthResult
isAuthorized _ _ = return Authorized
isWriteRequest :: Route a -> GHandler s a Bool
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
["GET", "HEAD", "OPTIONS", "TRACE"]
authRoute :: a -> Maybe (Route a)
authRoute _ = Nothing
cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath _ s =
if corrected == s
then Right $ map dropDash s
else Left corrected
where
corrected = filter (not . T.null) s
dropDash t
| T.all (== '-') t = T.drop 1 t
| otherwise = t
joinPath :: a
-> T.Text
-> [T.Text]
-> [(T.Text, T.Text)]
-> Builder
joinPath _ ar pieces' qs' =
fromText ar `mappend` encodePath pieces qs
where
pieces = if null pieces' then [""] else map addDash pieces'
qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing
go x = Just $ TE.encodeUtf8 x
addDash t
| T.all (== '-') t = T.cons '-' t
| otherwise = t
addStaticContent :: Text
-> Text
-> L.ByteString
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing
cookiePath :: a -> S8.ByteString
cookiePath _ = "/"
cookieDomain :: a -> Maybe S8.ByteString
cookieDomain _ = Nothing
maximumContentLength :: a -> Maybe (Route a) -> Word64
maximumContentLength _ _ = 2 * 1024 * 1024
getLogger :: a -> IO Logger
getLogger _ = mkLogger True stdout
messageLogger :: a
-> Logger
-> Loc
-> LogLevel
-> LogStr
-> IO ()
messageLogger a logger loc = messageLoggerSource a logger loc ""
messageLoggerSource :: a
-> Logger
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
messageLoggerSource a logger loc source level msg =
if shouldLog a source level
then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
else return ()
logLevel :: a -> LogLevel
logLevel _ = LevelInfo
gzipSettings :: a -> GzipSettings
gzipSettings _ = def
jsLoader :: a -> ScriptLoadPosition a
jsLoader _ = BottomOfBody
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
makeSessionBackend _ = fmap Just defaultClientSessionBackend
fileUpload :: a
-> Word64
-> FileUpload
fileUpload _ size
| size > 50000 = FileUploadDisk tempFileBackEnd
| otherwise = FileUploadMemory lbsBackEnd
shouldLog :: a -> LogSource -> LogLevel -> Bool
shouldLog a _ level = level >= logLevel a
yesodMiddleware :: GHandler sub a res -> GHandler sub a res
yesodMiddleware handler = do
setHeader "Vary" "Accept, Accept-Language"
handler
formatLogMessage :: IO ZonedDate
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO [LogStr]
formatLogMessage getdate loc src level msg = do
now <- getdate
return
[ LB now
, LB " ["
, LS $
case level of
LevelOther t -> T.unpack t
_ -> drop 5 $ show level
, LS $
if T.null src
then ""
else "#" ++ T.unpack src
, LB "] "
, msg
, LB " @("
, LS $ fileLocationToString loc
, LB ")\n"
]
fileLocationToString :: Loc -> String
fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
where
line = show . fst . loc_start
char = show . snd . loc_start
defaultYesodRunner :: Yesod master
=> Logger
-> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe (SessionBackend master)
-> W.Application
defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
| maxLen < len = return tooLargeResponse
| otherwise = do
let dontSaveSession _ _ = return []
now <- liftIO getCurrentTime
(session, saveSession) <- liftIO $ do
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen
let h = do
case murl of
Nothing -> handler
Just url -> do
isWrite <- isWriteRequest $ toMasterRoute url
ar <- isAuthorized (toMasterRoute url) isWrite
case ar of
Authorized -> return ()
AuthenticationRequired ->
case authRoute master of
Nothing ->
permissionDenied "Authentication required"
Just url' -> do
setUltDestCurrent
redirect url'
Unauthorized s' -> permissionDenied s'
handler
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
let ra = resolveApproot master req
let log' = messageLoggerSource master logger
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
(yesodRender master ra) errorHandler rr murl sessionMap h
extraHeaders <- case yar of
(YARPlain _ _ ct _ newSess) -> do
let nsToken = Map.toList $ maybe
newSess
(\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
(reqToken rr)
sessionHeaders <- liftIO (saveSession nsToken now)
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
_ -> return []
return $ yarToResponse yar extraHeaders
where
maxLen = maximumContentLength master $ fmap toMasterRoute murl
len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
readMay s =
case reads $ S8.unpack s of
[] -> Nothing
(x, _):_ -> Just x
handler = yesodMiddleware handler'
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
deriving (Eq, Show, Read)
class YesodBreadcrumbs y where
breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])
breadcrumbs = do
x' <- getCurrentRoute
tm <- getRouteToMaster
let x = fmap tm x'
case x of
Nothing -> return ("Not found", [])
Just y -> do
(title, next) <- breadcrumb y
z <- go [] next
return (title, z)
where
go back Nothing = return back
go back (Just this) = do
(title, next) <- breadcrumb this
go ((this, title) : back) next
applyLayout' :: Yesod master
=> Html
-> HtmlUrl (Route master)
-> GHandler sub master ChooseRep
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
setTitle title
toWidget body
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler NotFound = do
r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
applyLayout' "Not Found"
[hamlet|
$newline never
<h1>Not Found
<p>#{path'}
|]
defaultErrorHandler (PermissionDenied msg) =
applyLayout' "Permission Denied"
[hamlet|
$newline never
<h1>Permission denied
<p>#{msg}
|]
defaultErrorHandler (InvalidArgs ia) =
applyLayout' "Invalid Arguments"
[hamlet|
$newline never
<h1>Invalid Arguments
<ul>
$forall msg <- ia
<li>#{msg}
|]
defaultErrorHandler (InternalError e) = do
$logErrorS "yesod-core" e
applyLayout' "Internal Server Error"
[hamlet|
$newline never
<h1>Internal Server Error
<pre>#{e}
|]
defaultErrorHandler (BadMethod m) =
applyLayout' "Bad Method"
[hamlet|
$newline never
<h1>Method Not Supported
<p>Method <code>#{S8.unpack m}</code> not supported
|]
maybeAuthorized :: Yesod a
=> Route a
-> Bool
-> GHandler s a (Maybe (Route a))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
jsToHtml :: Javascript -> Html
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
jelper :: JavascriptUrl url -> HtmlUrl url
jelper = fmap jsToHtml
widgetToPageContent :: (Eq (Route master), Yesod master)
=> GWidget sub master ()
-> GHandler sub master (PageContent (Route master))
widgetToPageContent w = do
master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
render <- getUrlRenderParams
let renderLoc x =
case x of
Nothing -> Nothing
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
css <- forM (Map.toList style) $ \(mmedia, content) -> do
let rendered = toLazyText $ content render
x <- addStaticContent "css" "text/css; charset=utf-8"
$ encodeUtf8 rendered
return (mmedia,
case x of
Nothing -> Left $ preEscapedToMarkup rendered
Just y -> Right $ either id (uncurry render) y)
jsLoc <-
case jscript of
Nothing -> return Nothing
Just s -> do
x <- addStaticContent "js" "text/javascript; charset=utf-8"
$ encodeUtf8 $ renderJavascriptUrl render s
return $ renderLoc x
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
regularScriptLoad = [hamlet|
$newline never
$forall s <- scripts
^{mkScriptTag s}
$maybe j <- jscript
$maybe s <- jsLoc
<script src="#{s}">
$nothing
<script>^{jelper j}
|]
headAll = [hamlet|
$newline never
\^{head'}
$forall s <- stylesheets
^{mkLinkTag s}
$forall s <- css
$maybe t <- right $ snd s
$maybe media <- fst s
<link rel=stylesheet media=#{media} href=#{t}>
$nothing
<link rel=stylesheet href=#{t}>
$maybe content <- left $ snd s
$maybe media <- fst s
<style media=#{media}>#{content}
$nothing
<style>#{content}
$case jsLoader master
$of BottomOfBody
$of BottomOfHeadAsync asyncJsLoader
^{asyncJsLoader asyncScripts mcomplete}
$of BottomOfHeadBlocking
^{regularScriptLoad}
|]
let bodyScript = [hamlet|
$newline never
^{body}
^{regularScriptLoad}
|]
return $ PageContent title headAll (case jsLoader master of
BottomOfBody -> bodyScript
_ -> body)
where
renderLoc' render' (Local url) = render' url []
renderLoc' _ (Remote s) = s
addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
mkScriptTag (Script loc attrs) render' =
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
mkLinkTag (Stylesheet loc attrs) render' =
foldl' addAttr TBH.link
( ("rel", "stylesheet")
: ("href", renderLoc' render' loc)
: attrs
)
data ScriptLoadPosition master
= BottomOfBody
| BottomOfHeadBlocking
| BottomOfHeadAsync (BottomOfHeadAsync master)
type BottomOfHeadAsync master
= [Text]
-> Maybe (HtmlUrl (Route master))
-> (HtmlUrl (Route master))
left :: Either a b -> Maybe a
left (Left x) = Just x
left _ = Nothing
right :: Either a b -> Maybe b
right (Right x) = Just x
right _ = Nothing
jsonArray :: [Text] -> Html
jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
loadJsYepnope eyn scripts mcomplete =
[hamlet|
$newline never
$maybe yn <- left eyn
<script src=#{yn}>
$maybe yn <- right eyn
<script src=@{yn}>
$maybe complete <- mcomplete
<script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});
$nothing
<script>yepnope({load:#{jsonArray scripts}});
|]
asyncHelper :: (url -> [x] -> Text)
-> [Script (url)]
-> Maybe (JavascriptUrl (url))
-> Maybe Text
-> (Maybe (HtmlUrl url), [Text])
asyncHelper render scripts jscript jsLoc =
(mcomplete, scripts'')
where
scripts' = map goScript scripts
scripts'' =
case jsLoc of
Just s -> scripts' ++ [s]
Nothing -> scripts'
goScript (Script (Local url) _) = render url []
goScript (Script (Remote s) _) = s
mcomplete =
case jsLoc of
Just{} -> Nothing
Nothing ->
case jscript of
Nothing -> Nothing
Just j -> Just $ jelper j
yesodRender :: Yesod y
=> y
-> ResolvedApproot
-> Route y
-> [(Text, Text)]
-> Text
yesodRender y ar url params =
TE.decodeUtf8 $ toByteString $
fromMaybe
(joinPath y ar ps
$ params ++ params')
(urlRenderOverride y url)
where
(ps, params') = renderRoute url
resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot
resolveApproot master req =
case approot of
ApprootRelative -> ""
ApprootStatic t -> t
ApprootMaster f -> f master
ApprootRequest f -> f master req
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
defaultClientSessionBackend = do
key <- CS.getKey CS.defaultKeyFile
let timeout = fromIntegral (120 * 60 :: Int)
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
return $ clientSessionBackend2 key getCachedDate
clientSessionBackend :: Yesod master
=> CS.Key
-> Int
-> SessionBackend master
clientSessionBackend key timeout = SessionBackend
{ sbLoadSession = loadClientSession key timeout "_SESSION"
}
loadClientSession :: Yesod master
=> CS.Key
-> Int
-> S8.ByteString
-> master
-> W.Request
-> UTCTime
-> IO (BackendSession, SaveSession)
loadClientSession key timeout sessionName master req now = return (sess, save)
where
sess = fromMaybe [] $ do
raw <- lookup "Cookie" $ W.requestHeaders req
val <- lookup sessionName $ parseCookies raw
let host = ""
decodeClientSessionOld key now host val
save sess' now' = do
iv <- liftIO CS.randomIV
return [AddCookie def
{ setCookieName = sessionName
, setCookieValue = sessionVal iv
, setCookiePath = Just (cookiePath master)
, setCookieExpires = Just expires
, setCookieDomain = cookieDomain master
, setCookieHttpOnly = True
}]
where
host = ""
expires = fromIntegral (timeout * 60) `addUTCTime` now'
sessionVal iv = encodeClientSessionOld key iv expires host sess'
clientSessionBackend2 :: Yesod master
=> CS.Key
-> IO ClientSessionDateCache
-> SessionBackend master
clientSessionBackend2 key getCachedDate =
SessionBackend {
sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req
}
loadClientSession2 :: Yesod master
=> CS.Key
-> IO ClientSessionDateCache
-> S8.ByteString
-> master
-> W.Request
-> IO (BackendSession, SaveSession)
loadClientSession2 key getCachedDate sessionName master req = load
where
load = do
date <- getCachedDate
return (sess date, save date)
sess date = fromMaybe [] $ do
raw <- lookup "Cookie" $ W.requestHeaders req
val <- lookup sessionName $ parseCookies raw
let host = ""
decodeClientSession key date host val
save date sess' _ = do
iv <- liftIO CS.randomIV
return [AddCookie def
{ setCookieName = sessionName
, setCookieValue = encodeClientSession key iv date host sess'
, setCookiePath = Just (cookiePath master)
, setCookieExpires = Just (csdcExpires date)
, setCookieDomain = cookieDomain master
, setCookieHttpOnly = True
}]
where
host = ""
runFakeHandler :: (Yesod master, MonadIO m) =>
SessionMap
-> (master -> Logger)
-> master
-> GHandler master master a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger master handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
let handler' = do liftIO . I.writeIORef ret . Right =<< handler
return ()
let YesodApp yapp =
runHandler
handler'
(yesodRender master $ resolveApproot master fakeWaiRequest)
Nothing
id
master
master
(fileUpload master)
(messageLoggerSource master $ logger master)
errHandler err =
YesodApp $ \_ _ _ session -> do
liftIO $ I.writeIORef ret (Left err)
return $ YARPlain
H.status500
[]
typePlain
(toContent ("runFakeHandler: errHandler" :: S8.ByteString))
session
fakeWaiRequest =
W.Request
{ W.requestMethod = "POST"
, W.httpVersion = H.http11
, W.rawPathInfo = "/runFakeHandler/pathInfo"
, W.rawQueryString = ""
, W.serverName = "runFakeHandler-serverName"
, W.serverPort = 80
, W.requestHeaders = []
, W.isSecure = False
, W.remoteHost = error "runFakeHandler-remoteHost"
, W.pathInfo = ["runFakeHandler", "pathInfo"]
, W.queryString = []
, W.requestBody = mempty
, W.vault = mempty
#if MIN_VERSION_wai(1, 4, 0)
, W.requestBodyLength = W.KnownLength 0
#endif
}
fakeRequest =
Request
{ reqGetParams = []
, reqCookies = []
, reqWaiRequest = fakeWaiRequest
, reqLangs = []
, reqToken = Just "NaN"
, reqBodySize = 0
}
fakeContentType = []
_ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap
I.readIORef ret