diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Yesod/Content.hs b/Yesod/Content.hs new file mode 100644 --- /dev/null +++ b/Yesod/Content.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Content + ( -- * Content + Content (..) + , emptyContent + , ToContent (..) + -- * Mime types + -- ** Data type + , ContentType + , typeHtml + , typePlain + , typeJson + , typeXml + , typeAtom + , typeRss + , typeJpeg + , typePng + , typeGif + , typeJavascript + , typeCss + , typeFlv + , typeOgv + , typeOctet + -- * Utilities + , simpleContentType + -- * Representations + , ChooseRep + , HasReps (..) + , defChooseRep + -- ** Specific content types + , RepHtml (..) + , RepJson (..) + , RepHtmlJson (..) + , RepPlain (..) + , RepXml (..) + -- * Utilities + , formatW3 + , formatRFC1123 + , formatRFC822 + ) where + +import Data.Maybe (mapMaybe) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Text.Lazy (Text, pack) +import qualified Data.Text as T + +import Data.Time +import System.Locale + +import qualified Data.Text.Encoding +import qualified Data.Text.Lazy.Encoding + +import Data.Enumerator (Enumerator) +import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) +import Data.Monoid (mempty) + +import Text.Hamlet (Html) +import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) +import Data.String (IsString (fromString)) + +data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. + | ContentEnum (forall a. Enumerator Builder IO a) + | ContentFile FilePath + +-- | Zero-length enumerator. +emptyContent :: Content +emptyContent = ContentBuilder mempty $ Just 0 + +instance IsString Content where + fromString = toContent + +-- | Anything which can be converted into 'Content'. Most of the time, you will +-- want to use the 'ContentBuilder' constructor. An easier approach will be to use +-- a pre-defined 'toContent' function, such as converting your data into a lazy +-- bytestring and then calling 'toContent' on that. +-- +-- Please note that the built-in instances for lazy data structures ('String', +-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include +-- the content length for the 'ContentBuilder' constructor. +class ToContent a where + toContent :: a -> Content + +instance ToContent Builder where + toContent = flip ContentBuilder Nothing +instance ToContent B.ByteString where + toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs +instance ToContent L.ByteString where + toContent = flip ContentBuilder Nothing . fromLazyByteString +instance ToContent T.Text where + toContent = toContent . Data.Text.Encoding.encodeUtf8 +instance ToContent Text where + toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 +instance ToContent String where + toContent = toContent . pack +instance ToContent Html where + toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing + +-- | A function which gives targetted representations of content based on the +-- content-types the user accepts. +type ChooseRep = + [ContentType] -- ^ list of content-types user accepts, ordered by preference + -> IO (ContentType, Content) + +-- | Any type which can be converted to representations. +class HasReps a where + chooseRep :: a -> ChooseRep + +-- | A helper method for generating 'HasReps' instances. +-- +-- This function should be given a list of pairs of content type and conversion +-- functions. If none of the content types match, the first pair is used. +defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep +defChooseRep reps a ts = do + let (ct, c) = + case mapMaybe helper ts of + (x:_) -> x + [] -> case reps of + [] -> error "Empty reps to defChooseRep" + (x:_) -> x + c' <- c a + return (ct, c') + where + helper ct = do + c <- lookup ct reps + return (ct, c) + +instance HasReps ChooseRep where + chooseRep = id + +instance HasReps () where + chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)] + +instance HasReps (ContentType, Content) where + chooseRep = const . return + +instance HasReps [(ContentType, Content)] where + chooseRep a cts = return $ + case filter (\(ct, _) -> go ct `elem` map go cts) a of + ((ct, c):_) -> (ct, c) + _ -> case a of + (x:_) -> x + _ -> error "chooseRep [(ContentType, Content)] of empty" + where + go = simpleContentType + +newtype RepHtml = RepHtml Content +instance HasReps RepHtml where + chooseRep (RepHtml c) _ = return (typeHtml, c) +newtype RepJson = RepJson Content +instance HasReps RepJson where + chooseRep (RepJson c) _ = return (typeJson, c) +data RepHtmlJson = RepHtmlJson Content Content +instance HasReps RepHtmlJson where + chooseRep (RepHtmlJson html json) = chooseRep + [ (typeHtml, html) + , (typeJson, json) + ] +newtype RepPlain = RepPlain Content +instance HasReps RepPlain where + chooseRep (RepPlain c) _ = return (typePlain, c) +newtype RepXml = RepXml Content +instance HasReps RepXml where + chooseRep (RepXml c) _ = return (typeXml, c) + +type ContentType = B.ByteString + +typeHtml :: ContentType +typeHtml = "text/html; charset=utf-8" + +typePlain :: ContentType +typePlain = "text/plain; charset=utf-8" + +typeJson :: ContentType +typeJson = "application/json; charset=utf-8" + +typeXml :: ContentType +typeXml = "text/xml" + +typeAtom :: ContentType +typeAtom = "application/atom+xml" + +typeRss :: ContentType +typeRss = "application/rss+xml" + +typeJpeg :: ContentType +typeJpeg = "image/jpeg" + +typePng :: ContentType +typePng = "image/png" + +typeGif :: ContentType +typeGif = "image/gif" + +typeJavascript :: ContentType +typeJavascript = "text/javascript; charset=utf-8" + +typeCss :: ContentType +typeCss = "text/css; charset=utf-8" + +typeFlv :: ContentType +typeFlv = "video/x-flv" + +typeOgv :: ContentType +typeOgv = "video/ogg" + +typeOctet :: ContentType +typeOctet = "application/octet-stream" + +-- | Removes \"extra\" information at the end of a content type string. In +-- particular, removes everything after the semicolon, if present. +-- +-- For example, \"text/html; charset=utf-8\" is commonly used to specify the +-- character encoding for HTML data. This function would return \"text/html\". +simpleContentType :: B.ByteString -> B.ByteString +simpleContentType = S8.takeWhile (/= ';') + +-- | Format a 'UTCTime' in W3 format. +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" + +-- | Format as per RFC 1123. +formatRFC1123 :: UTCTime -> String +formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" + +-- | Format as per RFC 822. +formatRFC822 :: UTCTime -> String +formatRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" diff --git a/Yesod/Core.hs b/Yesod/Core.hs new file mode 100644 --- /dev/null +++ b/Yesod/Core.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-- | The basic typeclass for a Yesod application. +module Yesod.Core + ( -- * Type classes + Yesod (..) + , YesodDispatch (..) + , RenderRoute (..) + -- ** Breadcrumbs + , YesodBreadcrumbs (..) + , breadcrumbs + -- * Utitlities + , maybeAuthorized + , widgetToPageContent + -- * Defaults + , defaultErrorHandler + -- * Data types + , AuthResult (..) + -- * Misc + , yesodVersion + , yesodRender +#if TEST + , coreTestSuite +#endif + ) where + +import Yesod.Content +import Yesod.Handler + +import qualified Paths_yesod_core +import Data.Version (showVersion) +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 as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State hiding (get, put) +import Text.Hamlet +import Text.Cassius +import Text.Julius +import Web.Routes +import Text.Blaze (preEscapedLazyText) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Maybe (fromMaybe) +import Control.Monad.IO.Class (liftIO) +import Web.Cookie (parseCookies) +import qualified Data.Map as Map +import Data.Time + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit hiding (Test) +import qualified Data.Text +import qualified Data.Text.Encoding +#endif + +#if GHC7 +#define HAMLET hamlet +#else +#define HAMLET $hamlet +#endif + +class Eq u => RenderRoute u where + renderRoute :: u -> ([String], [(String, String)]) + +-- | This class is automatically instantiated when you use the template haskell +-- mkYesod function. You should never need to deal with it directly. +class YesodDispatch a master where + yesodDispatch + :: Yesod master + => a + -> Maybe CS.Key + -> [String] + -> 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 + +-- | Define settings for a Yesod applications. The only required setting is +-- 'approot'; other than that, there are intelligent defaults. +class RenderRoute (Route a) => Yesod a where + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. + -- + -- If you want to be lazy, you can supply an empty string under the + -- following conditions: + -- + -- * Your application is served from the root of the domain. + -- + -- * You do not use any features that require absolute URLs, such as Atom + -- feeds and XML sitemaps. + approot :: a -> String + + -- | The encryption key to be used for encrypting client sessions. + -- Returning 'Nothing' disables sessions. + encryptKey :: a -> IO (Maybe CS.Key) + encryptKey _ = fmap Just $ getKey defaultKeyFile + + -- | Number of minutes before a client session times out. Defaults to + -- 120 (2 hours). + clientSessionDuration :: a -> Int + clientSessionDuration = const 120 + + -- | Output error response pages. + errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler = defaultErrorHandler + + -- | Applies some form of layout to the contents of a page. + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + mmsg <- getMessage + hamletToRepHtml [HAMLET| +!!! + + + + #{pageTitle p} + ^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + ^{pageBody p} +|] + + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid + -- sending cookies. + urlRenderOverride :: a -> Route a -> Maybe String + urlRenderOverride _ _ = Nothing + + -- | Determine if a request is authorized or not. + -- + -- Return 'Nothing' is the request is authorized, 'Just' a message if + -- unauthorized. If authentication is required, you should use a redirect; + -- the Auth helper provides this functionality automatically. + isAuthorized :: Route a + -> Bool -- ^ is this a write request? + -> GHandler s a AuthResult + isAuthorized _ _ = return Authorized + + -- | Determines whether the current request is a write request. By default, + -- this assumes you are following RESTful principles, and determines this + -- from request method. In particular, all except the following request + -- methods are considered write: GET HEAD OPTIONS TRACE. + -- + -- This function is used to determine if a request is authorized; see + -- 'isAuthorized'. + isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest _ = do + wai <- waiRequest + return $ not $ W.requestMethod wai `elem` + ["GET", "HEAD", "OPTIONS", "TRACE"] + + -- | The default route for authentication. + -- + -- Used in particular by 'isAuthorized', but library users can do whatever + -- they want with it. + authRoute :: a -> Maybe (Route a) + authRoute _ = Nothing + + -- | A function used to clean up path segments. It returns 'Right' with a + -- clean path or 'Left' with a new set of pieces the user should be + -- redirected to. The default implementation enforces: + -- + -- * No double slashes + -- + -- * There is no trailing slash. + -- + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [String] -> Either [String] [String] + cleanPath _ s = + if corrected == s + then Right s + else Left corrected + where + corrected = filter (not . null) s + + -- | Join the pieces of a path together into an absolute URL. This should + -- be the inverse of 'splitPath'. + joinPath :: a + -> String -- ^ application root + -> [String] -- ^ path pieces + -> [(String, String)] -- ^ query string + -> String + joinPath _ ar pieces qs = ar ++ '/' : encodePathInfo pieces qs + + -- | This function is used to store some static content to be served as an + -- external file. The most common case of this is stashing CSS and + -- JavaScript content in an external file; the "Yesod.Widget" module uses + -- this feature. + -- + -- The return value is 'Nothing' if no storing was performed; this is the + -- default implementation. A 'Just' 'Left' gives the absolute URL of the + -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is + -- necessary when you are serving the content outside the context of a + -- Yesod application, such as via memcached. + addStaticContent :: String -- ^ filename extension + -> String -- ^ mime-type + -> L.ByteString -- ^ content + -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) + addStaticContent _ _ _ = return Nothing + + -- | Whether or not to tie a session to a specific IP address. Defaults to + -- 'True'. + sessionIpAddress :: a -> Bool + sessionIpAddress _ = True + +defaultYesodRunner :: Yesod master + => a + -> master + -> (Route a -> Route master) + -> Maybe CS.Key + -> Maybe (Route a) + -> GHandler a master ChooseRep + -> W.Application +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 + return $ yarToResponse (hr mnonce getExpires host exp') yar + where + hr mnonce getExpires host exp' hs ct sm = + hs''' + where + sessionVal = + case (mkey, mnonce) of + (Just key, Just nonce) + -> encodeSession key exp' host + $ Map.toList + $ Map.insert nonceKey nonce sm + _ -> S.empty + hs' = + case mkey of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration master) + sessionName + sessionVal + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", ct) : hs'' + +data AuthResult = Authorized | AuthenticationRequired | Unauthorized String + deriving (Eq, Show, Read) + +-- | A type-safe, concise method of creating breadcrumbs for pages. For each +-- resource, you declare the title of the page and the parent resource (if +-- present). +class YesodBreadcrumbs y where + -- | Returns the title and the parent resource, if available. If you return + -- a 'Nothing', then this is considered a top-level page. + breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) + +-- | Gets the title of the current page and the hierarchy of parent pages, +-- along with their respective titles. +breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) +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 -- ^ title + -> Hamlet (Route master) -- ^ body + -> GHandler sub master ChooseRep +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + addHamlet body + +-- | The default error handler for 'errorHandler'. +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep +defaultErrorHandler NotFound = do + r <- waiRequest + let path' = bsToChars $ W.pathInfo r + applyLayout' "Not Found" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Not Found +<p>#{path'} +|] +defaultErrorHandler (PermissionDenied msg) = + applyLayout' "Permission Denied" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Permission denied +<p>#{msg} +|] +defaultErrorHandler (InvalidArgs ia) = + applyLayout' "Invalid Arguments" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Invalid Arguments +<ul> + $forall msg <- ia + <li>#{msg} +|] +defaultErrorHandler (InternalError e) = + applyLayout' "Internal Server Error" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Internal Server Error +<p>#{e} +|] +defaultErrorHandler (BadMethod m) = + applyLayout' "Bad Method" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Method Not Supported +<p>Method "#{m}" not supported +|] + +-- | Return the same URL if the user is authorized to see it. +-- +-- Built on top of 'isAuthorized'. This is useful for building page that only +-- contain links to pages the user is allowed to see. +maybeAuthorized :: Yesod a + => Route a + -> Bool -- ^ is this a write request? + -> GHandler s a (Maybe (Route a)) +maybeAuthorized r isWrite = do + x <- isAuthorized r isWrite + return $ if x == Authorized then Just r else Nothing + +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent (GWidget w) = do + w' <- flip evalStateT 0 + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT w + let ((((((((), + Body body), + Last mTitle), + scripts'), + stylesheets'), + style), + jscript), + Head head') = w' + let title = maybe mempty unTitle mTitle + let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' + let stylesheets = map (locationToHamlet . unStylesheet) + $ runUniqueList stylesheets' + let cssToHtml = preEscapedLazyText . renderCss + celper :: Cassius url -> Hamlet url + celper = fmap cssToHtml + jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b + jelper :: Julius url -> Hamlet url + jelper = fmap jsToHtml + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + cssLoc <- + case style of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 $ renderCassius render s + return $ renderLoc x + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ encodeUtf8 $ renderJulius render s + return $ renderLoc x + + let head'' = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +$forall s <- scripts + <script src="^{s}"> +$forall s <- stylesheets + <link rel="stylesheet" href="^{s}"> +$maybe s <- style + $maybe s <- cssLoc + <link rel="stylesheet" href="#{s}"> + $nothing + <style>^{celper s} +$maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> + $nothing + <script>^{jelper j} +\^{head'} +|] + return $ PageContent title head'' body + +yesodVersion :: String +yesodVersion = showVersion Paths_yesod_core.version + +yesodRender :: Yesod y + => y + -> Route y + -> [(String, String)] + -> String +yesodRender y u qs = + fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') + (urlRenderOverride y u) + where + (ps, qs') = renderRoute u + +#if TEST +coreTestSuite :: Test +coreTestSuite = testGroup "Yesod.Yesod" + [ testProperty "join/split path" propJoinSplitPath + , testCase "join/split path [\".\"]" caseJoinSplitPathDquote + , testCase "utf8 split path" caseUtf8SplitPath + , testCase "utf8 join path" caseUtf8JoinPath + ] + +data TmpYesod = TmpYesod +data TmpRoute = TmpRoute deriving Eq +type instance Route TmpYesod = TmpRoute +instance Yesod TmpYesod where approot _ = "" + +fromString :: String -> S8.ByteString +fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack + +propJoinSplitPath :: [String] -> Bool +propJoinSplitPath ss = + splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) + == Right ss' + where + ss' = filter (not . null) ss + +caseJoinSplitPathDquote :: Assertion +caseJoinSplitPathDquote = do + splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."] + splitPath TmpYesod (fromString "/y./") @?= Right ["y."] + joinPath TmpYesod "" ["z."] [] @?= "/z./" + x @?= Right ss + where + x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' []) + ss' = filter (not . null) ss + ss = ["a."] + +caseUtf8SplitPath :: Assertion +caseUtf8SplitPath = do + Right ["שלום"] @=? + splitPath TmpYesod (fromString "/שלום/") + Right ["page", "Fooé"] @=? + splitPath TmpYesod (fromString "/page/Fooé/") + Right ["\156"] @=? + splitPath TmpYesod (fromString "/\156/") + Right ["ð"] @=? + splitPath TmpYesod (fromString "/%C3%B0/") + +caseUtf8JoinPath :: Assertion +caseUtf8JoinPath = do + "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] +#endif diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs new file mode 100644 --- /dev/null +++ b/Yesod/Dispatch.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Dispatch + ( -- * Quasi-quoted routing + parseRoutes + , mkYesod + , mkYesodSub + -- ** More fine-grained + , mkYesodData + , mkYesodSubData + , mkYesodDispatch + , mkYesodSubDispatch + -- ** Path pieces + , SinglePiece (..) + , MultiPiece (..) + , Strings + -- * Convert to WAI + , toWaiApp + , toWaiAppPlain +#if TEST + , dispatchTestSuite +#endif + ) where + +import Prelude hiding (exp) +import Yesod.Core +import Yesod.Handler +import Yesod.Internal.Dispatch + +import Web.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Language.Haskell.TH.Syntax + +import qualified Network.Wai as W +import Network.Wai.Middleware.Jsonp +import Network.Wai.Middleware.Gzip + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as S +import Data.ByteString.Lazy.Char8 () + +import Web.ClientSession +import Data.Char (isUpper) + +import Web.Routes (decodePathInfo) + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck +import System.IO.Unsafe +#endif + +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. +-- Use 'parseRoutes' to create the 'Resource's. +mkYesod :: String -- ^ name of the argument datatype + -> [Resource] + -> Q [Dec] +mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False + +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. +-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not +-- executable by itself, but instead provides functionality to +-- be embedded in other sites. +mkYesodSub :: String -- ^ name of the argument datatype + -> Cxt + -> [Resource] + -> Q [Dec] +mkYesodSub name clazzes = + fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True + where + (name':rest) = words name + +-- | Sometimes, you will want to declare your routes in one file and define +-- your handlers elsewhere. For example, this is the only way to break up a +-- monolithic file into smaller parts. Use this function, paired with +-- 'mkYesodDispatch', to do just that. +mkYesodData :: String -> [Resource] -> Q [Dec] +mkYesodData name res = mkYesodDataGeneral name [] False res + +mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res + +mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec] +mkYesodDataGeneral name clazzes isSub res = do + let (name':rest) = words name + (x, _) <- mkYesodGeneral name' rest clazzes isSub res + let rname = mkName $ "resources" ++ name + eres <- lift res + let y = [ SigD rname $ ListT `AppT` ConT ''Resource + , FunD rname [Clause [] (NormalB eres) []] + ] + return $ x ++ y + +-- | See 'mkYesodData'. +mkYesodDispatch :: String -> [Resource] -> Q [Dec] +mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False + +mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True + where (name':rest) = words name + +mkYesodGeneral :: String -- ^ foundation name + -> [String] -- ^ parameters for foundation + -> Cxt -- ^ classes + -> Bool -- ^ is subsite? + -> [Resource] + -> Q ([Dec], [Dec]) +mkYesodGeneral name args clazzes isSub res = do + let name' = mkName name + args' = map mkName args + arg = foldl AppT (ConT name') $ map VarT args' + th' <- mapM thResourceFromResource res + let th = map fst th' + w' <- createRoutes th + let routesName = mkName $ name ++ "Route" + let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] + let x = TySynInstD ''Route [arg] $ ConT routesName + + render <- createRender th + let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName) + [ FunD (mkName "renderRoute") render + ] + + yd <- mkYesodDispatch' th' + let master = mkName "master" + let ctx = if isSub + then ClassP (mkName "Yesod") [VarT master] : clazzes + else [] + let ytyp = if isSub + then ConT ''YesodDispatch `AppT` arg `AppT` VarT master + else ConT ''YesodDispatch `AppT` arg `AppT` arg + let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]] + return ([w, x, x'], [y]) + +thResourceFromResource :: Resource -> Q (THResource, Maybe String) +thResourceFromResource (Resource n ps atts) + | all (all isUpper) atts = return ((n, Simple ps atts), Nothing) +thResourceFromResource (Resource n ps [stype, toSubArg]) = do + let stype' = ConT $ mkName stype + parse <- [|error "ssParse"|] + dispatch <- [|error "ssDispatch"|] + render <- [|renderRoute|] + tmg <- [|error "ssToMasterArg"|] + return ((n, SubSite + { ssType = ConT ''Route `AppT` stype' + , ssParse = parse + , ssRender = render + , ssDispatch = dispatch + , ssToMasterArg = tmg + , ssPieces = ps + }), Just toSubArg) + +thResourceFromResource (Resource n _ _) = + error $ "Invalid attributes for resource: " ++ n + +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This is the same as 'toWaiAppPlain', except it includes three +-- middlewares: GZIP compression, JSON-P and path cleaning. This is the +-- recommended approach for most users. +toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application +toWaiApp y = do + a <- toWaiAppPlain y + return $ gzip False + $ jsonp + a + +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This differs from 'toWaiApp' in that it uses no middlewares. +toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application +toWaiAppPlain a = do + key' <- encryptKey a + return $ toWaiApp' a key' + +toWaiApp' :: (Yesod y, YesodDispatch y y) + => y + -> Maybe Key + -> W.Application +toWaiApp' y key' env = do + let segments = + case decodePathInfo $ B.unpack $ W.pathInfo env of + "":x -> x + x -> x + case yesodDispatch y key' segments y id of + Just app -> app env + Nothing -> + case cleanPath y segments of + Right segments' -> + case yesodDispatch y key' segments' y id of + Just app -> app env + Nothing -> yesodRunner y y id key' Nothing notFound env + Left segments' -> + let dest = joinPath y (approot y) segments' [] + dest' = + if S.null (W.queryString env) + then dest + else dest ++ '?' : B.unpack (W.queryString env) + in return $ W.responseLBS W.status301 + [ ("Content-Type", "text/plain") + , ("Location", B.pack $ dest') + ] "Redirecting" + +#if TEST + +dispatchTestSuite :: Test +dispatchTestSuite = testGroup "Yesod.Dispatch" + [ testProperty "encode/decode session" propEncDecSession + , testProperty "get/put time" propGetPutTime + ] + +propEncDecSession :: [(String, String)] -> Bool +propEncDecSession session' = unsafePerformIO $ do + key <- getDefaultKey + now <- getCurrentTime + let expire = addUTCTime 1 now + let rhost = B.pack "some host" + let val = encodeSession key expire rhost session' + return $ Just session' == decodeSession key now rhost val + +propGetPutTime :: UTCTime -> Bool +propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) + +instance Arbitrary UTCTime where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ addUTCTime (fromRational b) + $ UTCTime (ModifiedJulianDay a) 0 + +#endif diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs new file mode 100644 --- /dev/null +++ b/Yesod/Handler.hs @@ -0,0 +1,800 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +--------------------------------------------------------- +-- +-- Module : Yesod.Handler +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman <michael@snoyman.com> +-- Stability : unstable +-- Portability : portable +-- +-- Define Handler stuff. +-- +--------------------------------------------------------- +module Yesod.Handler + ( -- * Type families + Route + , YesodSubRoute (..) + -- * Handler monad + , GHandler + , GGHandler + -- ** Read information from handler + , getYesod + , getYesodSub + , getUrlRender + , getUrlRenderParams + , getCurrentRoute + , getRouteToMaster + -- * Special responses + -- ** Redirecting + , RedirectType (..) + , redirect + , redirectParams + , redirectString + , redirectToPost + -- ** Errors + , notFound + , badMethod + , permissionDenied + , invalidArgs + -- ** Short-circuit responses. + , sendFile + , sendResponse + , sendResponseStatus + , sendResponseCreated + , sendWaiResponse + -- * Setting headers + , setCookie + , deleteCookie + , setHeader + , setLanguage + -- ** Content caching and expiration + , cacheSeconds + , neverExpires + , alreadyExpired + , expiresAt + -- * Session + , SessionMap + , lookupSession + , getSession + , setSession + , deleteSession + -- ** Ultimate destination + , setUltDest + , setUltDestString + , setUltDest' + , redirectUltDest + -- ** Messages + , setMessage + , getMessage + -- * Helpers for specific content + -- ** Hamlet + , hamletToContent + , hamletToRepHtml + -- ** Misc + , newIdent + , liftIOHandler + -- * Internal Yesod + , runHandler + , YesodApp (..) + , runSubsiteGetter + , toMasterHandler + , toMasterHandlerDyn + , toMasterHandlerMaybe + , localNoCurrent + , HandlerData + , ErrorResponse (..) + , YesodAppResult (..) + , handlerToYAR + , yarToResponse + , headerToPair +#if TEST + , handlerTestSuite +#endif + ) where + +import Prelude hiding (catch) +import Yesod.Request +import Yesod.Internal +import Data.Time (UTCTime) + +import Control.Exception hiding (Handler, catch, finally) +import qualified Control.Exception as E +import Control.Applicative + +import Control.Monad (liftM, join) + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..)) + +import System.IO +import qualified Network.Wai as W +import Control.Failure (Failure (failure)) + +import Text.Hamlet + +import Control.Monad.IO.Peel (MonadPeelIO) +import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) +import qualified Data.Map as Map +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee (..)) +import Network.Wai.Parse (parseHttpAccept) + +#if TEST +import Test.Framework (testGroup, Test) +#endif + +import Yesod.Content +import Data.Maybe (fromMaybe) +import Web.Cookie (SetCookie (..), renderSetCookie) +import Blaze.ByteString.Builder (toByteString) +import Data.Enumerator (run_, ($$)) +import Control.Arrow (second, (***)) +import qualified Network.Wai.Parse as NWP + +-- | The type-safe URLs associated with a site argument. +type family Route a + +class YesodSubRoute s y where + fromSubRoute :: s -> y -> Route s -> Route y + +data HandlerData sub master = HandlerData + { handlerRequest :: Request + , handlerSub :: sub + , handlerMaster :: master + , handlerRoute :: Maybe (Route sub) + , handlerRender :: (Route master -> [(String, String)] -> String) + , handlerToMaster :: Route sub -> Route master + } + +handlerSubData :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubData tm ts = handlerSubDataMaybe tm ts . Just + +handlerSubDataMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubDataMaybe tm ts route hd = hd + { handlerSub = ts $ handlerMaster hd + , handlerToMaster = tm + , handlerRoute = route + } + +-- | Used internally for promoting subsite handler functions to master site +-- handler functions. Should not be needed by users. +toMasterHandler :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> GGHandler sub master mo a + -> GGHandler sub' master mo a +toMasterHandler tm ts route (GHandler h) = + GHandler $ withReaderT (handlerSubData tm ts route) h + +toMasterHandlerDyn :: Monad mo + => (Route sub -> Route master) + -> GGHandler sub' master mo sub + -> Route sub + -> GGHandler sub master mo a + -> GGHandler sub' master mo a +toMasterHandlerDyn tm getSub route (GHandler h) = do + sub <- getSub + GHandler $ withReaderT (handlerSubData tm (const sub) route) h + +class SubsiteGetter g m s | g -> s where + runSubsiteGetter :: g -> m s + +instance (master ~ master' + ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where + runSubsiteGetter getter = do + y <- getYesod + return $ getter y + +instance (anySub ~ anySub' + ,master ~ master' + ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where + runSubsiteGetter = id + +toMasterHandlerMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> GGHandler sub master mo a + -> GGHandler sub' master mo a +toMasterHandlerMaybe tm ts route (GHandler h) = + GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h + +-- | A generic handler monad, which can have a different subsite and master +-- site. This monad is a combination of 'ReaderT' for basic arguments, a +-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling +-- special responses. It is declared as a newtype to make compiler errors more +-- readable. +newtype GGHandler sub master m a = + GHandler + { unGHandler :: GHInner sub master m a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) + +instance MonadTrans (GGHandler s m) where + lift = GHandler . lift . lift . lift . lift + +type GHandler sub master = GGHandler sub master (Iteratee ByteString IO) + +data GHState = GHState + { ghsSession :: SessionMap + , ghsRBC :: Maybe RequestBodyContents + , ghsIdent :: Int + } + +type GHInner s m monad = + ReaderT (HandlerData s m) ( + ErrorT HandlerContents ( + WriterT (Endo [Header]) ( + StateT GHState ( + monad + )))) + +type SessionMap = Map.Map String String + +type Endo a = a -> a + +-- | An extension of the basic WAI 'W.Application' datatype to provide extra +-- features needed by Yesod. Users should never need to use this directly, as +-- the 'GHandler' monad and template haskell code should hide it away. +newtype YesodApp = YesodApp + { unYesodApp + :: (ErrorResponse -> YesodApp) + -> Request + -> [ContentType] + -> SessionMap + -> Iteratee ByteString IO YesodAppResult + } + +data YesodAppResult + = YARWai W.Response + | YARPlain W.Status [Header] ContentType Content SessionMap + +data HandlerContents = + HCContent W.Status ChooseRep + | HCError ErrorResponse + | HCSendFile ContentType FilePath + | HCRedirect RedirectType ByteString + | HCCreated ByteString + | HCWai W.Response + +instance Error HandlerContents where + strMsg = HCError . InternalError + +instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where + failure = GHandler . lift . throwError . HCError +instance RequestReader (GHandler sub master) where -- FIXME kill this typeclass, does not work for GGHandler + getRequest = handlerRequest <$> GHandler ask + runRequestBody = do + x <- GHandler $ lift $ lift $ lift get + case ghsRBC x of + Just rbc -> return rbc + Nothing -> do + rr <- waiRequest + rbc <- lift $ rbHelper rr + GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } + return rbc + +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents +rbHelper req = + (map fix1 *** map fix2) <$> iter + where + iter = NWP.parseRequestBody NWP.lbsSink req + fix1 = bsToChars *** bsToChars + fix2 (x, NWP.FileInfo a b c) = + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) + +-- | Get the sub application argument. +getYesodSub :: Monad m => GGHandler sub master m sub +getYesodSub = handlerSub `liftM` GHandler ask + +-- | Get the master site appliation argument. +getYesod :: Monad m => GGHandler sub master m master +getYesod = handlerMaster `liftM` GHandler ask + +-- | Get the URL rendering function. +getUrlRender :: Monad m => GGHandler sub master m (Route master -> String) +getUrlRender = do + x <- handlerRender `liftM` GHandler ask + return $ flip x [] + +-- | The URL rendering function with query-string parameters. +getUrlRenderParams + :: Monad m + => GGHandler sub master m (Route master -> [(String, String)] -> String) +getUrlRenderParams = handlerRender `liftM` GHandler ask + +-- | Get the route requested by the user. If this is a 404 response- where the +-- user requested an invalid route- this function will return 'Nothing'. +getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) +getCurrentRoute = handlerRoute `liftM` GHandler ask + +-- | Get the function to promote a route for a subsite to a route for the +-- master site. +getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) +getRouteToMaster = handlerToMaster `liftM` GHandler ask + +-- | Function used internally by Yesod in the process of converting a +-- 'GHandler' into an 'W.Application'. Should not be needed by users. +runHandler :: HasReps c + => GHandler sub master c + -> (Route master -> [(String, String)] -> String) + -> Maybe (Route sub) + -> (Route sub -> Route master) + -> master + -> sub + -> YesodApp +runHandler handler mrender sroute tomr ma sa = + YesodApp $ \eh rr cts initSession -> do + let toErrorHandler e = + case fromException e of + Just x -> x + Nothing -> InternalError $ show e + let hd = HandlerData + { handlerRequest = rr + , handlerSub = sa + , handlerMaster = ma + , handlerRoute = sroute + , handlerRender = mrender + , handlerToMaster = tomr + } + let initSession' = GHState initSession Nothing 1 + ((contents', headers), finalSession) <- catchIter ( + fmap (second ghsSession) + $ flip runStateT initSession' + $ runWriterT + $ runErrorT + $ flip runReaderT hd + $ unGHandler handler + ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) + let contents = either id (HCContent W.status200 . chooseRep) contents' + let handleError e = do + yar <- unYesodApp (eh e) safeEh rr cts finalSession + case yar of + YARPlain _ hs ct c sess -> + let hs' = headers hs + in return $ YARPlain (getStatus e) hs' ct c sess + YARWai _ -> return yar + let sendFile' ct fp = + return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession + case contents of + HCContent status a -> do + (ct, c) <- liftIO $ chooseRep a cts + return $ YARPlain status (headers []) ct c finalSession + HCError e -> handleError e + HCRedirect rt loc -> do + let hs = Header "Location" loc : headers [] + return $ YARPlain + (getRedirectStatus rt) hs typePlain emptyContent + finalSession + HCSendFile ct fp -> catchIter + (sendFile' ct fp) + (handleError . toErrorHandler) + HCCreated loc -> do + let hs = Header "Location" loc : headers [] + return $ YARPlain + (W.Status 201 (S8.pack "Created")) + hs + typePlain + emptyContent + finalSession + HCWai r -> return $ YARWai r + +catchIter :: Exception e + => Iteratee ByteString IO a + -> (e -> Iteratee ByteString IO a) + -> Iteratee ByteString IO a +catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f) + +safeEh :: ErrorResponse -> YesodApp +safeEh er = YesodApp $ \_ _ _ session -> do + liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er + return $ YARPlain + W.status500 + [] + typePlain + (toContent ("Internal Server Error" :: S.ByteString)) + session + +-- | Redirect to the given route. +redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a +redirect rt url = redirectParams rt url [] + +-- | Redirects to the given route with the associated query-string parameters. +redirectParams :: Monad mo + => RedirectType -> Route master -> [(String, String)] + -> GGHandler sub master mo a +redirectParams rt url params = do + r <- getUrlRenderParams + redirectString rt $ S8.pack $ r url params + +-- | Redirect to the given URL. +redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a +redirectString rt = GHandler . lift . throwError . HCRedirect rt + +ultDestKey :: String +ultDestKey = "_ULT" + +-- | Sets the ultimate destination variable to the given route. +-- +-- An ultimate destination is stored in the user session and can be loaded +-- later by 'redirectUltDest'. +setUltDest :: Monad mo => Route master -> GGHandler sub master mo () +setUltDest dest = do + render <- getUrlRender + setUltDestString $ render dest + +-- | Same as 'setUltDest', but use the given string. +setUltDestString :: Monad mo => String -> GGHandler sub master mo () +setUltDestString = setSession ultDestKey + +-- | Same as 'setUltDest', but uses the current page. +-- +-- If this is a 404 handler, there is no current page, and then this call does +-- nothing. +setUltDest' :: Monad mo => GGHandler sub master mo () +setUltDest' = do + route <- getCurrentRoute + case route of + Nothing -> return () + Just r -> do + tm <- getRouteToMaster + gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask + render <- getUrlRenderParams + setUltDestString $ render (tm r) gets' + +-- | Redirect to the ultimate destination in the user's session. Clear the +-- value from the session. +-- +-- The ultimate destination is set with 'setUltDest'. +redirectUltDest :: Monad mo + => RedirectType + -> Route master -- ^ default destination if nothing in session + -> GGHandler sub master mo () +redirectUltDest rt def = do + mdest <- lookupSession ultDestKey + deleteSession ultDestKey + maybe (redirect rt def) (redirectString rt . S8.pack) mdest + +msgKey :: String +msgKey = "_MSG" + +-- | Sets a message in the user's session. +-- +-- See 'getMessage'. +setMessage :: Monad mo => Html -> GGHandler sub master mo () +setMessage = setSession msgKey . lbsToChars . renderHtml + +-- | Gets the message in the user's session, if available, and then clears the +-- variable. +-- +-- See 'setMessage'. +getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) +getMessage = do + mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey + deleteSession msgKey + return mmsg + +-- | Bypass remaining handler code and output the given file. +-- +-- For some backends, this is more efficient than reading in the file to +-- memory, since they can optimize file sending via a system call to sendfile. +sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a +sendFile ct = GHandler . lift . throwError . HCSendFile ct + +-- | Bypass remaining handler code and output the given content with a 200 +-- status code. +sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a +sendResponse = GHandler . lift . throwError . HCContent W.status200 + . chooseRep + +-- | Bypass remaining handler code and output the given content with the given +-- status code. +sendResponseStatus :: (Monad mo, HasReps c) => W.Status -> c -> GGHandler s m mo a +sendResponseStatus s = GHandler . lift . throwError . HCContent s + . chooseRep + +-- | Send a 201 "Created" response with the given route as the Location +-- response header. +sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a +sendResponseCreated url = do + r <- getUrlRender + GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url + +-- | Send a 'W.Response'. Please note: this function is rarely +-- necessary, and will /disregard/ any changes to response headers and session +-- that you have already specified. This function short-circuits. It should be +-- considered only for very specific needs. If you are not sure if you need it, +-- you don't. +sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b +sendWaiResponse = GHandler . lift . throwError . HCWai + +-- | Return a 404 not found page. Also denotes no handler available. +notFound :: Failure ErrorResponse m => m a +notFound = failure NotFound + +-- | Return a 405 method not supported page. +badMethod :: (RequestReader m, Failure ErrorResponse m) => m a +badMethod = do + w <- waiRequest + failure $ BadMethod $ bsToChars $ W.requestMethod w + +-- | Return a 403 permission denied page. +permissionDenied :: Failure ErrorResponse m => String -> m a +permissionDenied = failure . PermissionDenied + +-- | Return a 400 invalid arguments page. +invalidArgs :: Failure ErrorResponse m => [String] -> m a +invalidArgs = failure . InvalidArgs + +------- Headers +-- | Set the cookie on the client. +setCookie :: Monad mo + => Int -- ^ minutes to timeout + -> ByteString -- ^ key + -> ByteString -- ^ value + -> GGHandler sub master mo () +setCookie a b = addHeader . AddCookie a b + +-- | Unset the cookie on the client. +deleteCookie :: Monad mo => ByteString -> GGHandler sub master mo () +deleteCookie = addHeader . DeleteCookie + +-- | Set the language in the user session. Will show up in 'languages' on the +-- next request. +setLanguage :: Monad mo => String -> GGHandler sub master mo () +setLanguage = setSession langKey + +-- | Set an arbitrary response header. +setHeader :: Monad mo + => W.ResponseHeader -> ByteString -> GGHandler sub master mo () +setHeader a = addHeader . Header a + +-- | Set the Cache-Control header to indicate this response should be cached +-- for the given number of seconds. +cacheSeconds :: Monad mo => Int -> GGHandler s m mo () +cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat + [ "max-age=" + , show i + , ", public" + ] + +-- | Set the Expires header to some date in 2037. In other words, this content +-- is never (realistically) expired. +neverExpires :: Monad mo => GGHandler s m mo () +neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" + +-- | Set an Expires header in the past, meaning this content should not be +-- cached. +alreadyExpired :: Monad mo => GGHandler s m mo () +alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" + +-- | Set an Expires header to the given date. +expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () +expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 + +-- | Set a variable in the user's session. +-- +-- The session is handled by the clientsession package: it sets an encrypted +-- and hashed cookie on the client. This ensures that all data is secure and +-- not tampered with. +setSession :: Monad mo + => String -- ^ key + -> String -- ^ value + -> GGHandler sub master mo () +setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k + +-- | Unsets a session variable. See 'setSession'. +deleteSession :: Monad mo => String -> GGHandler sub master mo () +deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete + +modSession :: (SessionMap -> SessionMap) -> GHState -> GHState +modSession f x = x { ghsSession = f $ ghsSession x } + +-- | Internal use only, not to be confused with 'setHeader'. +addHeader :: Monad mo => Header -> GGHandler sub master mo () +addHeader = GHandler . lift . lift . tell . (:) + +getStatus :: ErrorResponse -> W.Status +getStatus NotFound = W.status404 +getStatus (InternalError _) = W.status500 +getStatus (InvalidArgs _) = W.status400 +getStatus (PermissionDenied _) = W.status403 +getStatus (BadMethod _) = W.status405 + +getRedirectStatus :: RedirectType -> W.Status +getRedirectStatus RedirectPermanent = W.status301 +getRedirectStatus RedirectTemporary = W.status302 +getRedirectStatus RedirectSeeOther = W.status303 + +-- | Different types of redirects. +data RedirectType = RedirectPermanent + | RedirectTemporary + | RedirectSeeOther + deriving (Show, Eq) + +localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a +localNoCurrent = + GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler + +-- | Lookup for session data. +lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue) +lookupSession n = GHandler $ do + m <- liftM ghsSession $ lift $ lift $ lift get + return $ Map.lookup n m + +-- | Get all session variables. +getSession :: Monad mo => GGHandler s m mo SessionMap +getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get + +#if TEST + +handlerTestSuite :: Test +handlerTestSuite = testGroup "Yesod.Handler" + [ + ] + +#endif + +handlerToYAR :: (HasReps a, HasReps b) + => m -- ^ master site foundation + -> s -- ^ sub site foundation + -> (Route s -> Route m) + -> (Route m -> [(String, String)] -> String) -- ^ url render + -> (ErrorResponse -> GHandler s m a) + -> Request + -> Maybe (Route s) + -> SessionMap + -> GHandler s m b + -> Iteratee ByteString IO YesodAppResult +handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = + unYesodApp ya eh' rr types sessionMap + where + ya = runHandler h render murl toMasterRoute y s + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s + types = httpAccept $ reqWaiRequest rr + errorHandler' = localNoCurrent . errorHandler + +type HeaderRenderer = [Header] + -> ContentType + -> SessionMap + -> [(W.ResponseHeader, ByteString)] + +yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response +yarToResponse _ (YARWai a) = a +yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) = + case c of + ContentBuilder b mlen -> + let hs' = maybe finalHeaders finalHeaders' mlen + in W.ResponseBuilder s hs' b + ContentFile fp -> W.ResponseFile s finalHeaders fp + ContentEnum e -> + W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders + where + finalHeaders = renderHeaders hs ct sessionFinal + finalHeaders' len = ("Content-Length", S8.pack $ show len) + : finalHeaders + {- + getExpires m = fromIntegral (m * 60) `addUTCTime` now + sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + -} + +httpAccept :: W.Request -> [ContentType] +httpAccept = parseHttpAccept + . fromMaybe S.empty + . lookup "Accept" + . W.requestHeaders + +-- | Convert Header to a key/value pair. +headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time + -> Header + -> (W.ResponseHeader, ByteString) +headerToPair getExpires (AddCookie minutes key value) = + ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie + { setCookieName = key + , setCookieValue = value + , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookieExpires = Just $ getExpires minutes + , setCookieDomain = Nothing + }) +headerToPair _ (DeleteCookie key) = + ( "Set-Cookie" + , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT" + ) +headerToPair _ (Header key value) = (key, value) + +-- | Get a unique identifier. +newIdent :: Monad mo => GGHandler sub master mo String +newIdent = GHandler $ lift $ lift $ lift $ do + x <- get + let i' = ghsIdent x + 1 + put x { ghsIdent = i' } + return $ "h" ++ show i' + +liftIOHandler :: MonadIO mo + => GGHandler sub master IO a + -> GGHandler sub master mo a +liftIOHandler x = do + k <- peel + join $ liftIO $ k x + +instance MonadTransPeel (GGHandler s m) where + peel = GHandler $ do + k <- liftPeel $ liftPeel $ liftPeel peel + return $ liftM GHandler . k . unGHandler + +-- | Redirect to a POST resource. +-- +-- This is not technically a redirect; instead, it returns an HTML page with a +-- POST form, and some Javascript to automatically submit the form. This can be +-- useful when you need to post a plain link somewhere that needs to cause +-- changes on the server. +redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a +redirectToPost dest = hamletToRepHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +\<!DOCTYPE html> + +<html> + <head> + <title>Redirecting... + <body onload="document.getElementById('form').submit()"> + <form id="form" method="post" action="@{dest}"> + <noscript> + <p>Javascript has been disabled; please click on the button below to be redirected. + <input type="submit" value="Continue"> +|] >>= sendResponse + +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. +hamletToContent :: Monad mo + => Hamlet (Route master) -> GGHandler sub master mo Content +hamletToContent h = do + render <- getUrlRenderParams + return $ toContent $ h render + +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Monad mo + => Hamlet (Route master) -> GGHandler sub master mo RepHtml +hamletToRepHtml = liftM RepHtml . hamletToContent diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs new file mode 100644 --- /dev/null +++ b/Yesod/Internal.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | Normal users should never need access to these. +module Yesod.Internal + ( -- * Error responses + ErrorResponse (..) + -- * Header + , Header (..) + -- * Cookie names + , langKey + -- * Widgets + , Location (..) + , UniqueList (..) + , Script (..) + , Stylesheet (..) + , Title (..) + , Head (..) + , Body (..) + , locationToHamlet + , runUniqueList + , toUnique + -- * UTF8 helpers + , bsToChars + , lbsToChars + , charsToBs + -- * Names + , sessionName + , nonceKey + ) where + +import Text.Hamlet (Hamlet, hamlet, Html) +import Data.Monoid (Monoid (..)) +import Data.List (nub) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +import qualified Network.Wai as W +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +#if GHC7 +#define HAMLET hamlet +#else +#define HAMLET $hamlet +#endif + +-- | Responses to indicate some form of an error occurred. These are different +-- from 'SpecialResponse' in that they allow for custom error pages. +data ErrorResponse = + NotFound + | InternalError String + | InvalidArgs [String] + | PermissionDenied String + | BadMethod String + deriving (Show, Eq, Typeable) +instance Exception ErrorResponse + +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int ByteString ByteString + | DeleteCookie ByteString + | Header W.ResponseHeader ByteString + deriving (Eq, Show) + +langKey :: String +langKey = "_LANG" + +data Location url = Local url | Remote String + deriving (Show, Eq) +locationToHamlet :: Location url -> Hamlet url +locationToHamlet (Local url) = [HAMLET|\@{url} +|] +locationToHamlet (Remote s) = [HAMLET|\#{s} +|] + +newtype UniqueList x = UniqueList ([x] -> [x]) +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y +runUniqueList :: Eq x => UniqueList x -> [x] +runUniqueList (UniqueList x) = nub $ x [] +toUnique :: x -> UniqueList x +toUnique = UniqueList . (:) + +newtype Script url = Script { unScript :: Location url } + deriving (Show, Eq) +newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html } + +newtype Head url = Head (Hamlet url) + deriving Monoid +newtype Body url = Body (Hamlet url) + deriving Monoid + +lbsToChars :: L.ByteString -> String +lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode + +bsToChars :: S.ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode + +charsToBs :: String -> S.ByteString +charsToBs = T.encodeUtf8 . T.pack + +nonceKey :: String +nonceKey = "_NONCE" + +sessionName :: ByteString +sessionName = "_SESSION" diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs new file mode 100644 --- /dev/null +++ b/Yesod/Internal/Dispatch.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | A bunch of Template Haskell used in the Yesod.Dispatch module. +module Yesod.Internal.Dispatch + ( mkYesodDispatch' + ) where + +import Prelude hiding (exp) +import Language.Haskell.TH.Syntax +import Web.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Control.Monad (foldM) +import Yesod.Handler (badMethod) +import Yesod.Content (chooseRep) +import qualified Network.Wai as W +import Yesod.Core (yesodRunner, yesodDispatch) +import Data.List (foldl') +import Data.Char (toLower) +import qualified Data.ByteString.Char8 as S8 + +{-| + +Alright, let's explain how routing works. We want to take a [String] and found +out which route it applies to. For static pieces, we need to ensure an exact +match against the segment. For a single or multi piece, we need to check the +result of fromSinglePiece/fromMultiPiece, respectively. + +We want to create a tree of case statements basically resembling: + +case testRoute1 of + Just app -> Just app + Nothing -> + case testRoute2 of + Just app -> Just app + Nothing -> + case testRoute3 of + Just app -> Just app + Nothing -> Nothing + +Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int): + +case segments of + "name" : as -> + case as of + [] -> Nothing + b:bs -> + case fromSinglePiece b of + Left _ -> Nothing + Right name -> + case bs of + "age":cs -> + case cs of + [] -> Nothing + d:ds -> + case fromSinglePiece d of + Left _ -> Nothing + Right age -> + case ds of + [] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)... + _ -> Nothing + _ -> Nothing + _ -> Nothing + +Obviously we would never want to write code by hand like this, but generating it is not too bad. + +This function generates a clause for the yesodDispatch function based on a set of routes. +-} +mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause +mkYesodDispatch' res = do + sub <- newName "sub" + master <- newName "master" + mkey <- newName "mkey" + segments <- newName "segments" + toMasterRoute <- newName "toMasterRoute" + nothing <- [|Nothing|] + body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res + return $ Clause + [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute] + (NormalB body) + [] + where + go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do + test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub) + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) [] + ] + go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do + test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods) + just <- [|Just|] + app <- newName "app" + return $ CaseE test + [ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] + , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] + ] + go _ _ _ _ _ _ _ = error "Invalid combination" + +mkSimpleExp :: Exp -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods + -> Q Exp +mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do + just <- [|Just|] + nothing <- [|Nothing|] + onSuccess <- newName "onSuccess" + req <- newName "req" + badMethod' <- [|badMethod|] + rm <- [|S8.unpack . W.requestMethod|] + let caseExp = rm `AppE` VarE req + yr <- [|yesodRunner|] + cr <- [|fmap chooseRep|] + let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] + let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars []) + runHandler' h = NormalB $ yr `AppE` sub + `AppE` VarE master + `AppE` toMasterRoute + `AppE` VarE mkey + `AppE` (just `AppE` url) + `AppE` h + `AppE` VarE req + let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] + let clauses = + case methods of + [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []] + _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++ + [Match WildP (runHandler' badMethod') []]) []] + let exp = CaseE segments + [ Match + (ConP (mkName "[]") []) + (NormalB $ just `AppE` VarE onSuccess) + [FunD onSuccess clauses] + , Match + WildP + (NormalB nothing) + [] + ] + return exp +mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSimpleExp (VarE srest) pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE segments + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE segments + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSimpleExp segments [MultiPiece _] frontVars x = do + next' <- newName "next'" + srest <- [|[]|] + innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + fmp <- [|fromMultiPiece|] + let exp = CaseE (fmp `AppE` segments) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + return exp +mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece" + +mkSubsiteExp :: Name -- ^ segments + -> [Piece] + -> ([Exp] -> [Exp]) -- ^ variables already parsed + -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub + -> Q Exp +mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do + yd <- [|yesodDispatch|] + dot <- [|(.)|] + let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars [] + -- proper handling for sub-subsites + let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars [] + let app = yd `AppE` sub' + `AppE` VarE mkey + `AppE` VarE segments + `AppE` VarE master + `AppE` con + just <- [|Just|] + return $ just `AppE` app +mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece" +mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do + srest <- newName "segments" + innerExp <- mkSubsiteExp srest pieces frontVars x + nothing <- [|Nothing|] + let exp = CaseE (VarE segments) + [ Match + (InfixP (LitP $ StringL s) (mkName ":") (VarP srest)) + (NormalB innerExp) + [] + , Match WildP (NormalB nothing) [] + ] + return exp +mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do + srest <- newName "segments" + next' <- newName "next'" + innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x + nothing <- [|Nothing|] + next <- newName "next" + fsp <- [|fromSinglePiece|] + let exp' = CaseE (fsp `AppE` VarE next) + [ Match + (ConP (mkName "Left") [WildP]) + (NormalB nothing) + [] + , Match + (ConP (mkName "Right") [VarP next']) + (NormalB innerExp) + [] + ] + let exp = CaseE (VarE segments) + [ Match + (InfixP (VarP next) (mkName ":") (VarP srest)) + (NormalB exp') + [] + , Match WildP (NormalB nothing) [] + ] + return exp diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/Yesod/Internal/Request.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Internal.Request + ( parseWaiRequest + ) where + +import Yesod.Request +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP +import Data.Maybe (fromMaybe) +import Yesod.Internal +import qualified Network.Wai as W +import qualified Data.ByteString as S +import System.Random (randomR, newStdGen) +import Web.Cookie (parseCookies) + +parseWaiRequest :: W.Request + -> [(String, String)] -- ^ session + -> Maybe a + -> IO Request +parseWaiRequest env session' key' = do + let gets' = map (bsToChars *** bsToChars) + $ NWP.parseQueryString $ W.queryString env + let reqCookie = fromMaybe S.empty $ lookup "Cookie" + $ W.requestHeaders env + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie + acceptLang = lookup "Accept-Language" $ W.requestHeaders env + langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang + langs' = case lookup langKey session' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey cookies' of + Nothing -> langs' + Just x -> x : langs' + langs''' = case lookup langKey gets' of + Nothing -> langs'' + Just x -> x : langs'' + nonce <- case (key', lookup nonceKey session') of + (Nothing, _) -> return Nothing + (_, Just x) -> return $ Just x + (_, Nothing) -> do + g <- newStdGen + return $ Just $ fst $ randomString 10 g + return $ Request gets' cookies' env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs new file mode 100644 --- /dev/null +++ b/Yesod/Internal/Session.hs @@ -0,0 +1,53 @@ +module Yesod.Internal.Session + ( encodeSession + , decodeSession + ) where + +import qualified Web.ClientSession as CS +import Data.Serialize +import Data.Time +import Data.ByteString (ByteString) +import Control.Monad (guard) + +encodeSession :: CS.Key + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> ByteString -- ^ cookie value +encodeSession key expire rhost session' = + CS.encrypt key $ encode $ SessionCookie expire rhost session' + +decodeSession :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> Maybe [(String, String)] +decodeSession key now rhost encrypted = do + decrypted <- CS.decrypt key encrypted + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode decrypted + guard $ expire > now + guard $ rhost' == rhost + return session' + +data SessionCookie = SessionCookie UTCTime ByteString [(String, String)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = putTime a >> put b >> put c + get = do + a <- getTime + b <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime t@(UTCTime d _) = do + put $ toModifiedJulianDay d + let ndt = diffUTCTime t $ UTCTime d 0 + put $ toRational ndt + +getTime :: Get UTCTime +getTime = do + d <- get + ndt <- get + return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 diff --git a/Yesod/Request.hs b/Yesod/Request.hs new file mode 100644 --- /dev/null +++ b/Yesod/Request.hs @@ -0,0 +1,151 @@ +--------------------------------------------------------- +-- +-- Module : Yesod.Request +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman <michael@snoyman.com> +-- Stability : Stable +-- Portability : portable +-- +-- | Provides a parsed version of the raw 'W.Request' data. +-- +--------------------------------------------------------- +module Yesod.Request + ( + -- * Request datatype + RequestBodyContents + , Request (..) + , RequestReader (..) + , FileInfo (..) + -- * Convenience functions + , waiRequest + , languages + -- * Lookup parameters + , lookupGetParam + , lookupPostParam + , lookupCookie + , lookupFile + -- ** Multi-lookup + , lookupGetParams + , lookupPostParams + , lookupCookies + , lookupFiles + -- * Parameter type synonyms + , ParamName + , ParamValue + , ParamError + ) where + +import qualified Network.Wai as W +import qualified Data.ByteString.Lazy as BL +import Control.Monad.IO.Class +import Control.Monad (liftM) +import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r +import Data.Maybe (listToMaybe) + +type ParamName = String +type ParamValue = String +type ParamError = String + +-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler + +-- | The reader monad specialized for 'Request'. +class Monad m => RequestReader m where + getRequest :: m Request + runRequestBody :: m RequestBodyContents + +-- | Get the list of supported languages supplied by the user. +-- +-- Languages are determined based on the following three (in descending order +-- of preference): +-- +-- * The _LANG get parameter. +-- +-- * The _LANG cookie. +-- +-- * The _LANG user session variable. +-- +-- * Accept-Language HTTP header. +-- +-- This is handled by parseWaiRequest (not exposed). +languages :: RequestReader m => m [String] +languages = reqLangs `liftM` getRequest + +-- | Get the request\'s 'W.Request' value. +waiRequest :: RequestReader m => m W.Request +waiRequest = reqWaiRequest `liftM` getRequest + +-- | A tuple containing both the POST parameters and submitted files. +type RequestBodyContents = + ( [(ParamName, ParamValue)] + , [(ParamName, FileInfo)] + ) + +data FileInfo = FileInfo + { fileName :: String + , fileContentType :: String + , fileContent :: BL.ByteString + } + deriving (Eq, Show) + +-- | The parsed request information. +data Request = Request + { reqGetParams :: [(ParamName, ParamValue)] + , reqCookies :: [(ParamName, ParamValue)] + , reqWaiRequest :: W.Request + -- | Languages which the client supports. + , reqLangs :: [String] + -- | A random, session-specific nonce used to prevent CSRF attacks. + , reqNonce :: Maybe String + } + +lookup' :: Eq a => a -> [(a, b)] -> [b] +lookup' a = map snd . filter (\x -> a == fst x) + +-- | Lookup for GET parameters. +lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] +lookupGetParams pn = do + rr <- getRequest + return $ lookup' pn $ reqGetParams rr + +-- | Lookup for GET parameters. +lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupGetParam = liftM listToMaybe . lookupGetParams + +-- | Lookup for POST parameters. +lookupPostParams :: RequestReader m + => ParamName + -> m [ParamValue] +lookupPostParams pn = do + (pp, _) <- runRequestBody + return $ lookup' pn pp + +lookupPostParam :: (MonadIO m, RequestReader m) + => ParamName + -> m (Maybe ParamValue) +lookupPostParam = liftM listToMaybe . lookupPostParams + +-- | Lookup for POSTed files. +lookupFile :: (MonadIO m, RequestReader m) + => ParamName + -> m (Maybe FileInfo) +lookupFile = liftM listToMaybe . lookupFiles + +-- | Lookup for POSTed files. +lookupFiles :: RequestReader m + => ParamName + -> m [FileInfo] +lookupFiles pn = do + (_, files) <- runRequestBody + return $ lookup' pn files + +-- | Lookup for cookie data. +lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupCookie = liftM listToMaybe . lookupCookies + +-- | Lookup for cookie data. +lookupCookies :: RequestReader m => ParamName -> m [ParamValue] +lookupCookies pn = do + rr <- getRequest + return $ lookup' pn $ reqCookies rr diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs new file mode 100644 --- /dev/null +++ b/Yesod/Widget.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier +-- generator, allowing you to create truly modular HTML components. +module Yesod.Widget + ( -- * Datatype + GWidget + , GGWidget (..) + , PageContent (..) + -- * Creating + -- ** Head of page + , setTitle + , addHamletHead + , addHtmlHead + -- ** Body + , addHamlet + , addHtml + , addWidget + , addSubWidget + -- ** CSS + , addCassius + , addStylesheet + , addStylesheetRemote + , addStylesheetEither + -- ** Javascript + , addJulius + , addScript + , addScriptRemote + , addScriptEither + -- * Utilities + , extractBody + ) where + +import Data.Monoid +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State +import Text.Hamlet +import Text.Cassius +import Text.Julius +import Yesod.Handler + (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) +import Control.Applicative (Applicative) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Yesod.Internal +import Control.Monad (liftM) + +import Control.Monad.IO.Peel (MonadPeelIO) + +-- | A generic widget, allowing specification of both the subsite and master +-- site datatypes. This is basically a large 'WriterT' stack keeping track of +-- dependencies along with a 'StateT' to track unique identifiers. +newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a } + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) + +instance MonadTrans (GGWidget s m) where + lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift + +type GWidget s m = GGWidget s m (GHandler s m) +type GWInner sub master monad = + WriterT (Body (Route master)) ( + WriterT (Last Title) ( + WriterT (UniqueList (Script (Route master))) ( + WriterT (UniqueList (Stylesheet (Route master))) ( + WriterT (Maybe (Cassius (Route master))) ( + WriterT (Maybe (Julius (Route master))) ( + WriterT (Head (Route master)) ( + StateT Int ( + monad + )))))))) +instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where + mempty = return () + mappend x y = x >> y + +instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where + newtype HamletMonad (GGWidget s m monad a) b = + GWidget' { runGWidget' :: GGWidget s m monad b } + type HamletUrl (GGWidget s m monad a) = Route m + toHamletValue = runGWidget' + htmlToHamletMonad = GWidget' . addHtml + urlToHamletMonad url params = GWidget' $ + addHamlet $ \r -> preEscapedString (r url params) + fromHamletValue = GWidget' +instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where + return = GWidget' . return + x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y + +addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a +addSubWidget sub w = do master <- lift getYesod + let sr = fromSubRoute sub master + i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get + w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w + let ((((((((a, + body), + title), + scripts), + stylesheets), + style), + jscript), + h), + i') = w' + GWidget $ do + tell body + lift $ tell title + lift $ lift $ tell scripts + lift $ lift $ lift $ tell stylesheets + lift $ lift $ lift $ lift $ tell style + lift $ lift $ lift $ lift $ lift $ tell jscript + lift $ lift $ lift $ lift $ lift $ lift $ tell h + lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' + return a + +-- | Set the page title. Calling 'setTitle' multiple times overrides previously +-- set values. +setTitle :: Monad m => Html -> GGWidget sub master m () +setTitle = GWidget . lift . tell . Last . Just . Title + +-- | Add a 'Hamlet' to the head tag. +addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m () +addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head + +-- | Add a 'Html' to the head tag. +addHtmlHead :: Monad m => Html -> GGWidget sub master m () +addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const + +-- | Add a 'Hamlet' to the body tag. +addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m () +addHamlet = GWidget . tell . Body + +-- | Add a 'Html' to the body tag. +addHtml :: Monad m => Html -> GGWidget sub master m () +addHtml = GWidget . tell . Body . const + +-- | Add another widget. This is defined as 'id', by can help with types, and +-- makes widget blocks look more consistent. +addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo () +addWidget = id + +-- | Add some raw CSS to the style tag. +addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () +addCassius = GWidget . lift . lift . lift . lift . tell . Just + +-- | Link to the specified local stylesheet. +addStylesheet :: Monad m => Route master -> GGWidget sub master m () +addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local + +-- | Link to the specified remote stylesheet. +addStylesheetRemote :: Monad m => String -> GGWidget sub master m () +addStylesheetRemote = + GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote + +addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () +addStylesheetEither = either addStylesheet addStylesheetRemote + +addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m () +addScriptEither = either addScript addScriptRemote + +-- | Link to the specified local script. +addScript :: Monad m => Route master -> GGWidget sub master m () +addScript = GWidget . lift . lift . tell . toUnique . Script . Local + +-- | Link to the specified remote script. +addScriptRemote :: Monad m => String -> GGWidget sub master m () +addScriptRemote = + GWidget . lift . lift . tell . toUnique . Script . Remote + +-- | Include raw Javascript in the page's script tag. +addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () +addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just + +-- | Pull out the HTML tag contents and return it. Useful for performing some +-- manipulations. It can be easier to use this sometimes than 'wrapWidget'. +extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m)) +extractBody (GWidget w) = + GWidget $ mapWriterT (liftM go) w + where + go ((), Body h) = (h, Body mempty) + +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> Hamlet url +data PageContent url = PageContent + { pageTitle :: Html + , pageHead :: Hamlet url + , pageBody :: Hamlet url + } diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,12 @@ +import Test.Framework (defaultMain) + +import Yesod.Content +import Yesod.Dispatch +import Yesod.Handler + +main :: IO () +main = defaultMain + [ contentTestSuite + , dispatchTestSuite + , handlerTestSuite + ] diff --git a/yesod-core.cabal b/yesod-core.cabal new file mode 100644 --- /dev/null +++ b/yesod-core.cabal @@ -0,0 +1,85 @@ +name: yesod-core +version: 0.7.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman <michael@snoyman.com> +maintainer: Michael Snoyman <michael@snoyman.com> +synopsis: Creation of type-safe, RESTful web applications. +description: + Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. + . + The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. +category: Web, Yesod +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://docs.yesodweb.com/ + +flag test + description: Build the executable to run unit tests + default: False + +flag ghc7 + +library + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: time >= 1.1.4 && < 1.3 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 + , bytestring >= 0.9.1.4 && < 0.10 + , text >= 0.5 && < 0.12 + , template-haskell + , web-routes-quasi >= 0.6.3 && < 0.7 + , hamlet >= 0.7 && < 0.8 + , blaze-builder >= 0.2.1 && < 0.3 + , transformers >= 0.2 && < 0.3 + , clientsession >= 0.4.0 && < 0.5 + , random >= 1.0.0.2 && < 1.1 + , cereal >= 0.2 && < 0.4 + , old-locale >= 1.0.0.2 && < 1.1 + , web-routes >= 0.23 && < 0.24 + , failure >= 0.1 && < 0.2 + , containers >= 0.2 && < 0.5 + , monad-peel >= 0.1 && < 0.2 + , enumerator >= 0.4 && < 0.5 + , cookie >= 0.0 && < 0.1 + , blaze-html >= 0.4 && < 0.5 + exposed-modules: Yesod.Content + Yesod.Core + Yesod.Dispatch + Yesod.Handler + Yesod.Request + Yesod.Widget + other-modules: Yesod.Internal + Yesod.Internal.Session + Yesod.Internal.Request + Yesod.Internal.Dispatch + Paths_yesod_core + ghc-options: -Wall + +executable runtests + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + if flag(test) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2 && < 3 + else + Buildable: False + ghc-options: -Wall + main-is: runtests.hs + +source-repository head + type: git + location: git://github.com/snoyberg/yesod-core.git