module Yesod.Internal.Core
(
Yesod (..)
, YesodDispatch (..)
, RenderRoute (..)
, YesodBreadcrumbs (..)
, breadcrumbs
, maybeAuthorized
, widgetToPageContent
, defaultErrorHandler
, AuthResult (..)
, LogLevel (..)
, formatLogMessage
, fileLocationToString
, messageLoggerHandler
, yesodVersion
, yesodRender
, resolveApproot
, Approot (..)
) where
import Yesod.Content
import Yesod.Handler hiding (lift, getExpires)
import Yesod.Routes.Class
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 Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
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)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Web.Cookie (parseCookies)
import qualified Data.Map as Map
import Data.Time
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 qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO
import qualified Data.Text.Lazy.Builder as TB
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
import Text.Blaze (preEscapedLazyText)
import Data.Aeson (Value (Array, String))
import Data.Aeson.Encode (encode)
import qualified Data.Vector as Vector
import Network.Wai.Middleware.Gzip (GzipSettings, def)
#ifndef MEGA
import qualified Paths_yesod_core
import Data.Version (showVersion)
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
#else
yesodVersion :: String
yesodVersion = "0.9.4"
#endif
#if GHC7
#define HAMLET hamlet
#else
#define HAMLET $hamlet
#endif
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> master
-> sub
-> (Route sub -> Route master)
-> (Maybe CS.Key -> W.Application)
-> (Route sub -> Maybe CS.Key -> W.Application)
-> Text
-> [Text]
-> Maybe CS.Key
-> W.Application
yesodRunner :: Yesod master
=> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key
-> 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
encryptKey :: a -> IO (Maybe CS.Key)
encryptKey _ = fmap Just $ getKey defaultKeyFile
clientSessionDuration :: a -> Int
clientSessionDuration = const 120
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|
!!!
<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 s
else Left corrected
where
corrected = filter (not . T.null) s
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 pieces'
qs = map (TE.encodeUtf8 *** go) qs'
go "" = Nothing
go x = Just $ TE.encodeUtf8 x
addStaticContent :: Text
-> Text
-> L.ByteString
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing
cookiePath :: a -> S8.ByteString
cookiePath _ = "/"
maximumContentLength :: a -> Maybe (Route a) -> Int
maximumContentLength _ _ = 2 * 1024 * 1024
messageLogger :: a
-> Loc
-> LogLevel
-> Text
-> IO ()
messageLogger a loc level msg =
if level < logLevel a
then return ()
else
formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn
logLevel :: a -> LogLevel
logLevel _ = LevelInfo
gzipSettings :: a -> GzipSettings
gzipSettings _ = def
yepnopeJs :: a -> Maybe (Either Text (Route a))
yepnopeJs _ = Nothing
messageLoggerHandler :: Yesod m
=> Loc -> LogLevel -> Text -> GHandler s m ()
messageLoggerHandler loc level msg = do
y <- getYesod
liftIO $ messageLogger y loc level msg
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
deriving (Eq, Show, Read, Ord)
instance Lift LogLevel where
lift LevelDebug = [|LevelDebug|]
lift LevelInfo = [|LevelInfo|]
lift LevelWarn = [|LevelWarn|]
lift LevelError = [|LevelError|]
lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
formatLogMessage :: Loc
-> LogLevel
-> Text
-> IO TL.Text
formatLogMessage loc level msg = do
now <- getCurrentTime
return $ TB.toLazyText $
TB.fromText (T.pack $ show now)
`mappend` TB.fromText " ["
`mappend` TB.fromText (T.pack $ drop 5 $ show level)
`mappend` TB.fromText "] "
`mappend` TB.fromText msg
`mappend` TB.fromText " @("
`mappend` TB.fromText (T.pack $ fileLocationToString loc)
`mappend` TB.fromText ") "
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
=> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe CS.Key
-> W.Application
defaultYesodRunner _ master _ murl toMaster _ req
| maximumContentLength master (fmap toMaster murl) < len =
return $ W.responseLBS
(H.Status 413 "Too Large")
[("Content-Type", "text/plain")]
"Request body too large to be processed."
where
len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
readMay s =
case reads $ S8.unpack s of
[] -> Nothing
(x, _):_ -> Just x
defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
now <- liftIO getCurrentTime
let getExpires m = fromIntegral (m * 60) `addUTCTime` now
let exp' = getExpires $ clientSessionDuration master
let host = ""
let session' =
case mkey of
Nothing -> []
Just key -> fromMaybe [] $ do
raw <- lookup "Cookie" $ W.requestHeaders req
val <- lookup sessionName $ parseCookies raw
decodeSession key now host val
rr <- liftIO $ parseWaiRequest req session' mkey
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 (\(x, _) -> x /= nonceKey) session'
let ra = resolveApproot master req
yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h
let mnonce = reqNonce rr
iv <- maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
return $ yarToResponse (hr iv mnonce getExpires host exp') yar
where
hr iv mnonce getExpires host exp' hs ct sm =
hs'''
where
sessionVal =
case (mkey, mnonce) of
(Just key, Just nonce)
-> encodeSession key iv exp' host
$ Map.toList
$ Map.insert nonceKey (TE.encodeUtf8 nonce) sm
_ -> mempty
hs' =
case mkey of
Nothing -> hs
Just _ -> AddCookie def
{ setCookieName = sessionName
, setCookieValue = sessionVal
, setCookiePath = Just (cookiePath master)
, setCookieExpires = Just $ getExpires (clientSessionDuration master)
, setCookieDomain = Nothing
, setCookieHttpOnly = True
}
: hs
hs'' = map headerToPair hs'
hs''' = ("Content-Type", ct) : hs''
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
addHamlet 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|
<h1>Not Found
<p>#{path'}
|]
defaultErrorHandler (PermissionDenied msg) =
applyLayout' "Permission Denied"
[HAMLET|
<h1>Permission denied
<p>#{msg}
|]
defaultErrorHandler (InvalidArgs ia) =
applyLayout' "Invalid Arguments"
[HAMLET|
<h1>Invalid Arguments
<ul>
$forall msg <- ia
<li>#{msg}
|]
defaultErrorHandler (InternalError e) =
applyLayout' "Internal Server Error"
[HAMLET|
<h1>Internal Server Error
<p>#{e}
|]
defaultErrorHandler (BadMethod m) =
applyLayout' "Bad Method"
[HAMLET|
<h1>Method Not Supported
<p>Method "#{S8.unpack m}" 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) = preEscapedLazyText $ 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 $ preEscapedLazyText 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, ynscripts) = ynHelper render scripts jscript jsLoc
headAll = [HAMLET|
\^{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}
$maybe eyn <- yepnopeJs master
$maybe yn <- left eyn
<script src=#{yn}>
$maybe yn <- right eyn
<script src=@{yn}>
$maybe complete <- mcomplete
<script>yepnope({load:#{ynscripts},complete:function(){^{complete}}})
$nothing
<script>yepnope({load:#{ynscripts}})
$nothing
$forall s <- scripts
^{mkScriptTag s}
$maybe j <- jscript
$maybe s <- jsLoc
<script src="#{s}">
$nothing
<script>^{jelper j}
|]
return $ PageContent title headAll body
where
left (Left x) = Just x
left _ = Nothing
right (Right x) = Just x
right _ = Nothing
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
)
ynHelper :: (url -> [x] -> Text)
-> [Script (url)]
-> Maybe (JavascriptUrl (url))
-> Maybe Text
-> (Maybe (HtmlUrl (url)), Html)
ynHelper render scripts jscript jsLoc =
(mcomplete, unsafeLazyByteString $ encode $ Array $ Vector.fromList $ map String 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