module Yesod.Internal.Core
(
Yesod (..)
, YesodDispatch (..)
, RenderRoute (..)
, YesodBreadcrumbs (..)
, breadcrumbs
, maybeAuthorized
, widgetToPageContent
, defaultErrorHandler
, AuthResult (..)
, LogLevel (..)
, formatLogMessage
, fileLocationToString
, messageLoggerHandler
, yesodVersion
, yesodRender
) where
import Yesod.Content
import Yesod.Handler
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 Control.Monad.Trans.Writer (runWriterT)
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 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
#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 Eq u => RenderRoute u where
renderRoute :: u -> ([Text], [(Text, Text)])
class YesodDispatch a master where
yesodDispatch
:: Yesod master
=> a
-> Maybe CS.Key
-> [Text]
-> master
-> (Route a -> Route master)
-> Maybe W.Application
yesodRunner :: Yesod master
=> a
-> master
-> (Route a -> Route master)
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
yesodRunner = defaultYesodRunner
class RenderRoute (Route a) => Yesod a where
approot :: a -> Text
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
sessionIpAddress :: a -> Bool
sessionIpAddress _ = True
cookiePath :: a -> S8.ByteString
cookiePath _ = "/"
maximumContentLength :: a -> Maybe (Route a) -> Int
maximumContentLength _ _ = 2 * 1024 * 1024
messageLogger :: a
-> Loc
-> LogLevel
-> Text
-> IO ()
messageLogger _ loc level msg =
formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn
gzipCompressFiles :: a -> Bool
gzipCompressFiles _ = False
yepnopeJs :: a -> Maybe (Either Text (Route a))
yepnopeJs _ = Nothing
messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
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
=> a
-> master
-> (Route a -> Route master)
-> Maybe CS.Key
-> Maybe (Route a)
-> GHandler a master ChooseRep
-> W.Application
defaultYesodRunner _ m toMaster _ murl _ req
| maximumContentLength m (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 s master toMasterRoute mkey murl handler req = do
now <- liftIO getCurrentTime
let getExpires m = fromIntegral (m * 60) `addUTCTime` now
let exp' = getExpires $ clientSessionDuration master
let rh = takeWhile (/= ':') $ show $ W.remoteHost req
let host = if sessionIpAddress master then S8.pack rh else ""
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
setUltDest'
redirect RedirectTemporary url'
Unauthorized s' -> permissionDenied s'
handler
let sessionMap = Map.fromList
$ filter (\(x, _) -> x /= nonceKey) session'
yar <- handlerToYAR master s toMasterRoute (yesodRender master) 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 nonce sm
_ -> mempty
hs' =
case mkey of
Nothing -> hs
Just _ -> AddCookie
(clientSessionDuration master)
sessionName
sessionVal
: hs
hs'' = map (headerToPair (cookiePath master) getExpires) 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 (GWidget w) = do
master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w
let title = maybe mempty unTitle mTitle
let scripts = runUniqueList scripts'
let 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 addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
let renderLoc' render' (Local url) = render' url []
renderLoc' _ (Remote s) = s
let mkScriptTag (Script loc attrs) render' =
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
let mkLinkTag (Stylesheet loc attrs) render' =
foldl' addAttr TBH.link
( ("rel", "stylesheet")
: ("href", renderLoc' render' loc)
: attrs
)
let left (Left x) = Just x
left _ = Nothing
right (Right x) = Just x
right _ = Nothing
let head'' = [HAMLET|
$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 _ <- yepnopeJs master
$nothing
$forall s <- scripts
^{mkScriptTag s}
$maybe j <- jscript
$maybe s <- jsLoc
<script src="#{s}">
$nothing
<script>^{jelper j}
\^{head'}
|]
let (mcomplete, ynscripts) = ynHelper render scripts jscript jsLoc
let bodyYN = [HAMLET|
^{body}
$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}})
|]
return $ PageContent title head'' bodyYN
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
-> Route y
-> [(Text, Text)]
-> Text
yesodRender y u qs =
TE.decodeUtf8 $ toByteString $
fromMaybe
(joinPath y (approot y) ps
$ qs ++ qs')
(urlRenderOverride y u)
where
(ps, qs') = renderRoute u