From c88bbfa33ede105901ebc79725d1fd5f2f2dc5ca Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 10:59:12 +0200 Subject: [PATCH] yesod-core split --- ChangeLog.md | 90 ------ Setup.lhs | 6 +- Yesod.hs | 42 ++- Yesod/Content.hs | 267 ----------------- Yesod/Dispatch.hs | 539 ---------------------------------- Yesod/Hamlet.hs | 59 ---- Yesod/Handler.hs | 588 -------------------------------------- Yesod/Helpers/AtomFeed.hs | 96 ------- Yesod/Helpers/Sitemap.hs | 79 ----- Yesod/Helpers/Static.hs | 252 ---------------- Yesod/Internal.hs | 103 ------- Yesod/Request.hs | 168 ----------- Yesod/Widget.hs | 189 ------------ Yesod/Yesod.hs | 537 ---------------------------------- blog.hs | 108 ------- blog2.hs | 71 ----- freeform.hs | 40 --- haddock.sh | 2 - helloworld.hs | 7 - mail.hs | 14 - runtests.hs | 18 -- test/.ignored | 0 test/bar/baz | 0 test/foo | 0 test/tmp/ignored | 0 yesod.cabal | 84 +----- 26 files changed, 40 insertions(+), 3319 deletions(-) delete mode 100644 ChangeLog.md delete mode 100644 Yesod/Content.hs delete mode 100644 Yesod/Dispatch.hs delete mode 100644 Yesod/Hamlet.hs delete mode 100644 Yesod/Handler.hs delete mode 100644 Yesod/Helpers/AtomFeed.hs delete mode 100644 Yesod/Helpers/Sitemap.hs delete mode 100644 Yesod/Helpers/Static.hs delete mode 100644 Yesod/Internal.hs delete mode 100644 Yesod/Request.hs delete mode 100644 Yesod/Widget.hs delete mode 100644 Yesod/Yesod.hs delete mode 100644 blog.hs delete mode 100644 blog2.hs delete mode 100644 freeform.hs delete mode 100755 haddock.sh delete mode 100644 helloworld.hs delete mode 100644 mail.hs delete mode 100644 runtests.hs delete mode 100644 test/.ignored delete mode 100644 test/bar/baz delete mode 100644 test/foo delete mode 100644 test/tmp/ignored diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index d9808462..00000000 --- a/ChangeLog.md +++ /dev/null @@ -1,90 +0,0 @@ -### Yesod 0.5.0 (August 29, 2010) - -* Forms no longer have special types for special views; instead, there is a -toFormField attribute when declaring entities to specify a form rendering -function. - -* URL settings for jQuery and Nic are now in their own typeclasses. This will -be the approach used in the future when adding more widgets and forms that -require Javascript libraries. - -* You can explicitly specify the id and name attributes to be used in forms if -you like. When omitted, a unique name is automatically generated. - -* The isAuthorized function now takes a function specifying whether the -request is a write request. This should make it simpler to develop read/write -authorization systems. Bonus points: if you use HTTP request methods properly, -the isWriteRequest function will automatically determine whether a request is -a read or write request. - -* You can now specify splitPath and joinPath functions yourself. Previously, -the built-in versions had very specific URL rules, such as enforcing a -trailing slash. If you want something more flexible, you can override these -functions. - -* addStaticContent is used to serve CSS and Javascript code from widgets from -external files. This allows caching to take place as you'd normally like. - -* Static files served from the static subsite can have a hash string added to -the query string; this is done automatically when using the getStaticFiles -function. This allows you to set your expires headers far in the future. - -* A new Yesod.Mail module provides datatypes and functions for creating -multipart MIME email messages and sending them via the sendmail executable. -Since these functions generate lazy bytestrings, you can use any delivery -mechanism you want. - -* Change the type of defaultLayout to use Widgets instead of PageContent. This -makes it easier to avoid double-including scripts and stylesheets. - -* Major reworking of the Auth subsite to make it easier to use. - -* Update of the site scaffolder to include much more functionality. Also -removed the Handler type alias from the library, as the scaffolder now -provides that. - -### New in Yesod 0.4.0 - -A big thanks on this release to Simon Michael, who pointed out a number of -places where the docs were unclear, the API was unintuitive, or the names were -inconsistent. - -* Widgets. These allow you to create composable pieces of a webpage that -keep track of their own Javascript and CSS. It includes a function for -obtaining unique identifiers to avoid name collisions, and does automatic -dependency combining; in other words, if you have two widgets that depend on -jQuery, the combined widget will only include it once. - -* Combined the Yesod.Form and Yesod.Formable module into a single, consistent, -widget-based API. It includes basic input functions as well as fancier -Javascript-driven functions; for example, there is a plain day entry field, -and a day entry field which automatically loads the jQuery UI date picker. - -* Added the yesod executable which performs basic scaffolding. - -* Cleaned up a bunch of API function names for consistency. For example, -Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming -scheme. - -* Changed the type of basicHandler to require less typing, and added -basicHandler' which allows you to modify the line output to STDOUT (or skip it -altogether). - -* Switched the Handler monad from ContT to MEitherT (provided by the neither -package). ContT does not have a valid MonadCatchIO instance, which is used for -the sqlite persitent backend. - -* Facebook support in the Auth helper. - -* Ensure that HTTP request methods are given in ALL CAPS. - -* Cleaned up signatures of many methods in the Yesod typeclass. In particular, -due to changes in web-routes-quasi, many of those functions can now live in -the Handler monad, making it easier to use standard functions on them. - -* The static file helper now has extensible file-extension-to-mimetype -mappings. - -* Added the sendResponse function for handler short-circuiting. - -* Renamed Routes to Route. diff --git a/Setup.lhs b/Setup.lhs index 1125d1d3..06e2708f 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -2,10 +2,6 @@ > module Main where > import Distribution.Simple -> import System.Cmd (system) > main :: IO () -> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) - -> runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return () +> main = defaultMain diff --git a/Yesod.hs b/Yesod.hs index 31dd3b88..9ff8202c 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,41 +1,55 @@ {-# LANGUAGE CPP #-} -- | This module simply re-exports from other modules for your convenience. module Yesod - ( module Yesod.Request + ( -- * Re-exports from yesod-core + module Yesod.Request , module Yesod.Content - , module Yesod.Yesod + , module Yesod.Core , module Yesod.Handler , module Yesod.Dispatch - , module Yesod.Hamlet , module Yesod.Widget + -- * Commonly referenced functions/datatypes , Application , lift , liftIO , MonadPeelIO - , mempty + -- * Utilities , showIntegral , readIntegral + -- * Hamlet library + -- ** Hamlet + , hamlet + , xhamlet + , Hamlet + , Html + , renderHamlet + , renderHtml + , string + , preEscapedString + , cdata + -- ** Julius + , julius + , Julius + , renderJulius + -- ** Cassius + , cassius + , Cassius + , renderCassius ) where -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Dispatch hiding (testSuite) -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (runHandler, testSuite) -#else import Yesod.Content import Yesod.Dispatch -import Yesod.Yesod +import Yesod.Core import Yesod.Handler hiding (runHandler) -#endif +import Text.Hamlet +import Text.Cassius +import Text.Julius import Yesod.Request import Yesod.Widget import Network.Wai (Application) -import Yesod.Hamlet import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) import Control.Monad.IO.Peel (MonadPeelIO) showIntegral :: Integral a => a -> String diff --git a/Yesod/Content.hs b/Yesod/Content.hs deleted file mode 100644 index 9be7a2f8..00000000 --- a/Yesod/Content.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} - -module Yesod.Content - ( -- * Content - Content (..) - , emptyContent - , ToContent (..) - -- * Mime types - -- ** Data type - , ContentType - , typeHtml - , typePlain - , typeJson - , typeXml - , typeAtom - , typeJpeg - , typePng - , typeGif - , typeJavascript - , typeCss - , typeFlv - , typeOgv - , typeOctet - -- ** File extensions - , typeByExt - , ext - -- * Utilities - , simpleContentType - -- * Representations - , ChooseRep - , HasReps (..) - , defChooseRep - -- ** Specific content types - , RepHtml (..) - , RepJson (..) - , RepHtmlJson (..) - , RepPlain (..) - , RepXml (..) - -- * Utilities - , formatW3 - , formatRFC1123 -#if TEST - , testSuite -#endif - ) where - -import Data.Maybe (mapMaybe) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Text.Lazy (Text) -import qualified Data.Text as T - -import Data.Time -import System.Locale - -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy.Encoding - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -import Data.Enumerator (Enumerator) -import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) -import Data.Monoid (mempty) - -import qualified Data.JSON.Types as J -import qualified Text.JSON.Enumerator as J - -data Content = ContentBuilder Builder - | ContentEnum (forall a. Enumerator Builder IO a) - | ContentFile FilePath - --- | Zero-length enumerator. -emptyContent :: Content -emptyContent = ContentBuilder mempty - --- | Anything which can be converted into 'Content'. Most of the time, you will --- want to use the 'ContentEnum' 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. -class ToContent a where - toContent :: a -> Content - -instance ToContent B.ByteString where - toContent = ContentBuilder . fromByteString -instance ToContent L.ByteString where - toContent = ContentBuilder . 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 . T.pack -instance ToContent J.Value where - toContent = ContentBuilder . J.renderValue - --- | 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 "")] - -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 = String - -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" - -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 :: String -> String -simpleContentType = fst . span (/= ';') - --- | A default extension to mime-type dictionary. -typeByExt :: [(String, ContentType)] -typeByExt = - [ ("jpg", typeJpeg) - , ("jpeg", typeJpeg) - , ("js", typeJavascript) - , ("css", typeCss) - , ("html", typeHtml) - , ("png", typePng) - , ("gif", typeGif) - , ("txt", typePlain) - , ("flv", typeFlv) - , ("ogv", typeOgv) - ] - --- | Get a file extension (everything after last period). -ext :: String -> String -ext = reverse . fst . break (== '.') . reverse - -#if TEST ----- Testing -testSuite :: Test -testSuite = testGroup "Yesod.Resource" - [ testProperty "ext" propExt - , testCase "typeByExt" caseTypeByExt - ] - -propExt :: String -> Bool -propExt s = - let s' = filter (/= '.') s - in s' == ext ("foobarbaz." ++ s') - -caseTypeByExt :: Assertion -caseTypeByExt = do - Just typeJavascript @=? lookup (ext "foo.js") typeByExt - Just typeHtml @=? lookup (ext "foo.html") typeByExt -#endif - --- | 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" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs deleted file mode 100644 index d45654ac..00000000 --- a/Yesod/Dispatch.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -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 - , basicHandler - , basicHandler' -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (testSuite) -#else -import Yesod.Yesod -import Yesod.Handler -#endif - -import Yesod.Request -import Yesod.Internal - -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.CleanPath (cleanPath) -import Network.Wai.Middleware.Jsonp -import Network.Wai.Middleware.Gzip - -import qualified Network.Wai.Handler.SimpleServer as SS -import qualified Network.Wai.Handler.CGI as CGI -import System.Environment (getEnvironment) - -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (toLazyByteString) - -import Control.Concurrent.MVar -import Control.Arrow ((***)) - -import Data.Time - -import Control.Monad -import Data.Maybe -import Web.ClientSession -import qualified Web.ClientSession as CS -import Data.Char (isUpper) -import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) - -import Data.Serialize -import qualified Data.Serialize as Ser -import Network.Wai.Parse hiding (FileInfo) -import qualified Network.Wai.Parse as NWP -import Data.String (fromString) -import Web.Routes -import Control.Arrow (first) -import System.Random (randomR, newStdGen) - -import qualified Data.Map as Map - -import Control.Applicative ((<$>)) -import Data.Enumerator (($$), run_) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck -import System.IO.Unsafe -import Yesod.Content hiding (testSuite) -import Data.Serialize.Get -import Data.Serialize.Put -#else -import Yesod.Content -#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 -- ^ argument name - -> [String] -- ^ parameters for site argument - -> 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 arg) res -- FIXME now we cannot have multi-nested subsites - w' <- createRoutes th - let routesName = mkName $ name ++ "Route" - let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] - let x = TySynInstD ''Route [arg] $ ConT routesName - - parse' <- createParse th - parse'' <- newName "parse" - let parse = LetE [FunD parse'' parse'] $ VarE parse'' - - render' <- createRender th - render'' <- newName "render" - let render = LetE [FunD render'' render'] $ VarE render'' - - tmh <- [|toMasterHandlerDyn|] - modMaster <- [|fmap chooseRep|] - dispatch' <- createDispatch modMaster tmh th - dispatch'' <- newName "dispatch" - let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' - - site <- [|Site|] - let site' = site `AppE` dispatch `AppE` render `AppE` parse - let (ctx, ytyp, yfunc) = - if isSub - then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") - else ([], ConT ''YesodSite `AppT` arg, "getSite") - let y = InstanceD ctx ytyp - [ FunD (mkName yfunc) [Clause [] (NormalB site') []] - ] - return ([w, x], [y]) - -isStatic :: Piece -> Bool -isStatic StaticPiece{} = True -isStatic _ = False - -thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps atts) - | all (all isUpper) atts = return (n, Simple ps atts) -thResourceFromResource master (Resource n ps [stype, toSubArg]) - -- static route to subsite - = do - let stype' = ConT $ mkName stype - gss <- [|getSubSite|] - let inside = ConT ''Maybe `AppT` - (ConT ''GHandler `AppT` stype' `AppT` master `AppT` - ConT ''ChooseRep) - let typ = ConT ''Site `AppT` - (ConT ''Route `AppT` stype') `AppT` - (ArrowT `AppT` ConT ''String `AppT` inside) - let gss' = gss `SigE` typ - parse' <- [|parsePathSegments|] - let parse = parse' `AppE` gss' - render' <- [|formatPathSegments|] - let render = render' `AppE` gss' - dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] - let dispatch = dispatch' `AppE` gss' - tmg <- mkToMasterArg ps toSubArg - return (n, SubSite - { ssType = ConT ''Route `AppT` stype' - , ssParse = parse - , ssRender = render - , ssDispatch = dispatch - , ssToMasterArg = tmg - , ssPieces = ps - }) - - -thResourceFromResource _ (Resource n _ _) = - error $ "Invalid attributes for resource: " ++ n - -mkToMasterArg :: [Piece] -> String -> Q Exp -mkToMasterArg ps fname = do - let nargs = length $ filter (not.isStatic) ps - f = VarE $ mkName fname - args <- sequence $ take nargs $ repeat $ newName "x" - rsg <- [| runSubsiteGetter|] - let xps = map VarP args - xes = map VarE args - e' = foldl (\x y -> x `AppE` y) f xes - e = rsg `AppE` e' - return $ LamE xps e - -sessionName :: String -sessionName = "_SESSION" - --- | 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, YesodSite 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 only uses the cleanpath --- middleware. -toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiAppPlain a = do - key' <- if enableClientSessions a - then Just `fmap` encryptKey a - else return Nothing - return $ cleanPath (splitPath a) (B.pack $ approot a) - $ toWaiApp' a key' - -toWaiApp' :: (Yesod y, YesodSite y) - => y - -> Maybe Key - -> [String] - -> W.Request - -> IO W.Response -toWaiApp' y key' segments env = do - now <- getCurrentTime - let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration y - let host = if sessionIpAddress y then W.remoteHost env else "" - let session' = - case key' of - Nothing -> [] - Just key'' -> fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key'' now host val - let site = getSite - method = B.unpack $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) segments - eurl = parsePathSegments site pathSegments - render u qs = - let (ps, qs') = formatPathSegments site u - in fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - let errorHandler' = localNoCurrent . errorHandler - rr <- parseWaiRequest env session' - let h = do - onRequest - case eurl of - Left _ -> errorHandler' NotFound - Right url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute y of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s - case handleSite site render url method of - Nothing -> errorHandler' $ BadMethod method - Just h' -> h' - let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler' er) render eurl' id y id - let ya = runHandler h render eurl' id y id - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - yar <- unYesodApp ya eh rr types sessionMap - case yar of - YARPlain s hs ct c sessionFinal -> do - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let 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'' - return $ - case c of - ContentBuilder b -> W.responseBuilder s hs''' b - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' - YAREnum e -> return $ W.ResponseEnumerator e - -httpAccept :: W.Request -> [ContentType] -httpAccept = map B.unpack - . parseHttpAccept - . fromMaybe B.empty - . lookup "Accept" - . W.requestHeaders - --- | Runs an application with CGI if CGI variables are present (namely --- PATH_INFO); otherwise uses SimpleServer. -basicHandler :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> y - -> IO () -basicHandler port y = basicHandler' port (Just "localhost") y - - --- | Same as 'basicHandler', but allows you to specify the hostname to display --- to the user. If 'Nothing' is provided, then no output is produced. -basicHandler' :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> Maybe String -- ^ host name, 'Nothing' to show nothing - -> y - -> IO () -basicHandler' port mhost y = do - app <- toWaiApp y - vars <- getEnvironment - case lookup "PATH_INFO" vars of - Nothing -> do - case mhost of - Nothing -> return () - Just h -> putStrLn $ concat - ["http://", h, ":", show port, "/"] - SS.run port app - Just _ -> CGI.run app - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> IO Request -parseWaiRequest env session' = do - let gets' = map (bsToChars *** bsToChars) - $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] 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'' - rbthunk <- iothunk $ rbHelper env - nonce <- case lookup nonceKey session' of - Just x -> return x - Nothing -> do - g <- newStdGen - return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk 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 - -nonceKey :: String -nonceKey = "_NONCE" - -rbHelper :: W.Request -> IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> run_ (enum $$ iter) - where - enum = W.requestBody req - iter = parseRequestBody lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. -iothunk :: IO a -> IO (IO a) -iothunk = fmap go . newMVar . Left where - go :: MVar (Either (IO a) a) -> IO a - go mvar = modifyMVar mvar go' - go' :: Either (IO a) a -> IO (Either (IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - --- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header - -> (W.ResponseHeader, B.ByteString) -headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie - { setCookieName = B.pack key -- FIXME check for non-ASCII - , setCookieValue = B.pack value -- FIXME check for non-ASCII - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? - , setCookieExpires = Just $ getExpires minutes - , setCookieDomain = Nothing - }) - where - builderToBS = S.concat . L.toChunks . toLazyByteString -headerToPair _ (DeleteCookie key) = - ("Set-Cookie", charsToBs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = - (fromString key, charsToBs value) - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> B.ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> B.ByteString -- ^ cookie value -encodeSession key expire rhost session' = - encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- 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 B.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 <- Ser.get - c <- Ser.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 <- Ser.get - ndt <- Ser.get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 - -#if TEST - -testSuite :: Test -testSuite = 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/Hamlet.hs b/Yesod/Hamlet.hs deleted file mode 100644 index e472981e..00000000 --- a/Yesod/Hamlet.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Hamlet - ( -- * Hamlet library - -- ** Hamlet - hamlet - , xhamlet - , Hamlet - , Html - , renderHamlet - , renderHtml - , string - , preEscapedString - , cdata - -- ** Julius - , julius - , Julius - , renderJulius - -- ** Cassius - , cassius - , Cassius - , renderCassius - -- * Convert to something displayable - , hamletToContent - , hamletToRepHtml - -- * Page templates - , PageContent (..) - ) - where - -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Content -import Yesod.Handler - --- | 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 - } - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ renderHamlet render h - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs deleted file mode 100644 index 1420a8f4..00000000 --- a/Yesod/Handler.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} ---------------------------------------------------------- --- --- Module : Yesod.Handler --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : unstable --- Portability : portable --- --- Define Handler stuff. --- ---------------------------------------------------------- -module Yesod.Handler - ( -- * Type families - Route - , YesodSubRoute (..) - -- * Handler monad - , GHandler - -- ** Read information from handler - , getYesod - , getYesodSub - , getUrlRender - , getUrlRenderParams - , getCurrentRoute - , getRouteToMaster - -- * Special responses - -- ** Redirecting - , RedirectType (..) - , redirect - , redirectParams - , redirectString - -- ** Errors - , notFound - , badMethod - , permissionDenied - , invalidArgs - -- ** Short-circuit responses. - , sendFile - , sendResponse - , sendResponseStatus - , sendResponseCreated - , sendResponseEnumerator - -- * 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 - -- * Internal Yesod - , runHandler - , YesodApp (..) - , runSubsiteGetter - , toMasterHandler - , toMasterHandlerDyn - , toMasterHandlerMaybe - , localNoCurrent - , HandlerData - , ErrorResponse (..) - , YesodAppResult (..) -#if TEST - , testSuite -#endif - ) where - -import Prelude hiding (catch) -import Yesod.Request -import Yesod.Internal -import Data.Neither -import Data.Time (UTCTime) - -import Control.Exception hiding (Handler, catch, finally) -import qualified Control.Exception as E -import Control.Applicative - -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 System.IO -import qualified Network.Wai as W -import Control.Failure (Failure (failure)) - -import Text.Hamlet - -import Control.Monad.IO.Peel (MonadPeelIO) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as S8 - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit hiding (Test) -import Yesod.Content hiding (testSuite) -import Data.IORef -#else -import Yesod.Content -#endif - --- | 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 - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandler tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubData tm ts route) h - -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub - -> Route sub - -> GHandler sub master a - -> GHandler sub' master 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) - -> GHandler sub master a - -> GHandler sub' master 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 GHandler sub master a = - GHandler - { unGHandler :: GHInner sub master a - } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) - -type GHInner s m = - ReaderT (HandlerData s m) ( - MEitherT HandlerContents ( - WriterT (Endo [Header]) ( - StateT SessionMap ( -- session - IO - )))) - -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 - -> IO YesodAppResult - } - -data YesodAppResult - = YAREnum (forall a. W.ResponseEnumerator a) - | YARPlain W.Status [Header] ContentType Content SessionMap - -data HandlerContents = - HCContent W.Status ChooseRep - | HCError ErrorResponse - | HCSendFile ContentType FilePath - | HCRedirect RedirectType String - | HCCreated String - | HCEnum (forall a. W.ResponseEnumerator a) - -instance Failure ErrorResponse (GHandler sub master) where - failure = GHandler . lift . throwMEither . HCError -instance RequestReader (GHandler sub master) where - getRequest = handlerRequest <$> GHandler ask - --- | Get the sub application argument. -getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> GHandler ask - --- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = handlerMaster <$> GHandler ask - --- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> String) -getUrlRender = do - x <- handlerRender <$> GHandler ask - return $ flip x [] - --- | The URL rendering function with query-string parameters. -getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) -getUrlRenderParams = handlerRender <$> 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 :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute <$> GHandler ask - --- | Get the function to promote a route for a subsite to a route for the --- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster <$> 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 - -> (master -> sub) - -> YesodApp -runHandler handler mrender sroute tomr ma tosa = - YesodApp $ \eh rr cts initSession -> do - let toErrorHandler = - InternalError - . (show :: Control.Exception.SomeException -> String) - let hd = HandlerData - { handlerRequest = rr - , handlerSub = tosa ma - , handlerMaster = ma - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr - } - ((contents', headers), finalSession) <- E.catch ( - flip runStateT initSession - $ runWriterT - $ runMEitherT - $ flip runReaderT hd - $ unGHandler handler - ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither 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 - YAREnum _ -> return yar - let sendFile' ct fp = - return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession - case contents of - HCContent status a -> do - (ct, c) <- 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 -> E.catch - (sendFile' ct fp) - (handleError . toErrorHandler) - HCCreated loc -> do -- FIXME add status201 to WAI - let hs = Header "Location" loc : headers [] - return $ YARPlain - (W.Status 201 (S8.pack "Created")) - hs - typePlain - emptyContent - finalSession - HCEnum e -> return $ YAREnum e - -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") - session - --- | Redirect to the given route. -redirect :: RedirectType -> Route master -> GHandler sub master a -redirect rt url = redirectParams rt url [] - --- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Route master -> [(String, String)] - -> GHandler sub master a -redirectParams rt url params = do - r <- getUrlRenderParams - redirectString rt $ r url params - --- | Redirect to the given URL. -redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt = GHandler . lift . throwMEither . 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 :: Route master -> GHandler sub master () -setUltDest dest = do - render <- getUrlRender - setUltDestString $ render dest - --- | Same as 'setUltDest', but use the given string. -setUltDestString :: String -> GHandler sub master () -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' :: GHandler sub master () -setUltDest' = do - route <- getCurrentRoute - case route of - Nothing -> return () - Just r -> do - tm <- getRouteToMaster - gets' <- reqGetParams <$> getRequest - 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 :: RedirectType - -> Route master -- ^ default destination if nothing in session - -> GHandler sub master () -redirectUltDest rt def = do - mdest <- lookupSession ultDestKey - deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt) mdest - -msgKey :: String -msgKey = "_MSG" - --- | Sets a message in the user's session. --- --- See 'getMessage'. -setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . lbsToChars . renderHtml - --- | Gets the message in the user's session, if available, and then clears the --- variable. --- --- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) -getMessage = do - mmsg <- fmap (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 :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = GHandler . lift . throwMEither . HCSendFile ct - --- | Bypass remaining handler code and output the given content with a 200 --- status code. -sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent W.status200 - . chooseRep - --- | Bypass remaining handler code and output the given content with the given --- status code. -sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a -sendResponseStatus s = GHandler . lift . throwMEither . HCContent s - . chooseRep - --- | Send a 201 "Created" response with the given route as the Location --- response header. -sendResponseCreated :: Route m -> GHandler s m a -sendResponseCreated url = do - r <- getUrlRender - GHandler $ lift $ throwMEither $ HCCreated $ r url - --- | Send a 'W.ResponseEnumerator'. 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 they specific needs. If you are not sure if you need it, --- you don't. -sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b -sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum - --- | 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 :: Int -- ^ minutes to timeout - -> String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setCookie a b = addHeader . AddCookie a b - --- | Unset the cookie on the client. -deleteCookie :: String -> GHandler sub master () -deleteCookie = addHeader . DeleteCookie - --- | Set the language in the user session. Will show up in 'languages' on the --- next request. -setLanguage :: String -> GHandler sub master () -setLanguage = setSession langKey - --- | Set an arbitrary response header. -setHeader :: String -> String -> GHandler sub master () -setHeader a = addHeader . Header a - --- | Set the Cache-Control header to indicate this response should be cached --- for the given number of seconds. -cacheSeconds :: Int -> GHandler s m () -cacheSeconds i = setHeader "Cache-Control" $ 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 :: GHandler s m () -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 :: GHandler s m () -alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" - --- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () -expiresAt = setHeader "Expires" . 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 :: String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . Map.insert k - --- | Unsets a session variable. See 'setSession'. -deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . Map.delete - --- | Internal use only, not to be confused with 'setHeader'. -addHeader :: Header -> GHandler sub master () -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 :: GHandler s m a -> GHandler s m a -localNoCurrent = - GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler - --- | Lookup for session data. -lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) -lookupSession n = GHandler $ do - m <- lift $ lift $ lift get - return $ Map.lookup n m - --- | Get all session variables. -getSession :: GHandler s m SessionMap -getSession = GHandler $ lift $ lift $ lift get - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Handler" - [ - ] - -#endif diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs deleted file mode 100644 index 8a5ea4a8..00000000 --- a/Yesod/Helpers/AtomFeed.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.AtomFeed --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating atom news feeds. --- ---------------------------------------------------------- - --- | Generation of Atom newsfeeds. See --- . -module Yesod.Helpers.AtomFeed - ( AtomFeed (..) - , AtomFeedEntry (..) - , atomFeed - , atomLink - , RepAtom (..) - ) where - -import Yesod -import Data.Time.Clock (UTCTime) - -newtype RepAtom = RepAtom Content -instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (typeAtom, c) - -atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom -atomFeed = fmap RepAtom . hamletToContent . template - -data AtomFeed url = AtomFeed - { atomTitle :: String - , atomLinkSelf :: url - , atomLinkHome :: url - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry url] - } - -data AtomFeedEntry url = AtomFeedEntry - { atomEntryLink :: url - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: Html - } - -template :: AtomFeed url -> Hamlet url -template arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif - -%feed!xmlns="http://www.w3.org/2005/Atom" - %title $atomTitle.arg$ - %link!rel=self!href=@atomLinkSelf.arg@ - %link!href=@atomLinkHome.arg@ - %updated $formatW3.atomUpdated.arg$ - %id @atomLinkHome.arg@ - $forall atomEntries.arg entry - ^entryTemplate.entry^ -|] - -entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%entry - %id @atomEntryLink.arg@ - %link!href=@atomEntryLink.arg@ - %updated $formatW3.atomEntryUpdated.arg$ - %title $atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ -|] - --- | Generates a link tag in the head of a widget. -atomLink :: Route m - -> String -- ^ title - -> GWidget s m () -atomLink u title = addHamletHead -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ -|] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs deleted file mode 100644 index 34807eb5..00000000 --- a/Yesod/Helpers/Sitemap.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Sitemap --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating Google sitemap files. --- ---------------------------------------------------------- - --- | Generates XML sitemap files. --- --- See . -module Yesod.Helpers.Sitemap - ( sitemap - , robots - , SitemapUrl (..) - , SitemapChangeFreq (..) - ) where - -import Yesod -import Data.Time (UTCTime) - -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never - -showFreq :: SitemapChangeFreq -> String -showFreq Always = "always" -showFreq Hourly = "hourly" -showFreq Daily = "daily" -showFreq Weekly = "weekly" -showFreq Monthly = "monthly" -showFreq Yearly = "yearly" -showFreq Never = "never" - -data SitemapUrl url = SitemapUrl - { sitemapLoc :: url - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } - -template :: [SitemapUrl url] -> Hamlet url -template urls = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" - $forall urls url - %url - %loc @sitemapLoc.url@ - %lastmod $formatW3.sitemapLastMod.url$ - %changefreq $showFreq.sitemapChangeFreq.url$ - %priority $show.priority.url$ -|] - -sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml -sitemap = fmap RepXml . hamletToContent . template - --- | A basic robots file which just lists the "Sitemap: " line. -robots :: Route sub -- ^ sitemap url - -> GHandler sub master RepPlain -robots smurl = do - tm <- getRouteToMaster - render <- getUrlRender - return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 index 7a9048f5..00000000 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Static --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- - --- | Serve static files from a Yesod app. --- --- This is most useful for standalone testing. When running on a production --- server (like Apache), just let the server do the static serving. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , StaticRoute (..) - -- * Lookup files in filesystem - , fileLookupDir - , staticFiles - -- * Embed files - , mkEmbedFiles - , getStaticHandler - -- * Hashing - , base64md5 -#if TEST - , testSuite -#endif - ) where - -import System.Directory -import Control.Monad -import Data.Maybe (fromMaybe) - -import Yesod hiding (lift) -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Web.Routes - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | A function for looking up file contents. For serving from the file system, --- see 'fileLookupDir'. -data Static = Static - { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) - -- | Mapping from file extension to content type. See 'typeByExt'. - , staticTypes :: [(String, ContentType)] - } - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [String] [(String, String)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute - -instance YesodSubSite Static master where - getSubSite = Site - { handleSite = \_ (StaticRoute ps _) m -> - case m of - "GET" -> Just $ fmap chooseRep $ getStaticRoute ps - _ -> Nothing - , formatPathSegments = \(StaticRoute x y) -> (x, y) - , parsePathSegments = \x -> Right $ StaticRoute x [] - } - --- | Lookup files in a specific directory. --- --- If you are just using this in combination with the static subsite (you --- probably are), the handler itself checks that no unsafe paths are being --- requested. In particular, no path segments may begin with a single period, --- so hidden files and parent directories are safe. --- --- For the second argument to this function, you can just use 'typeByExt'. -fileLookupDir :: FilePath -> [(String, ContentType)] -> Static -fileLookupDir dir = Static $ \fp -> do - let fp' = dir ++ '/' : fp - exists <- doesFileExist fp' - if exists - then return $ Just $ Left fp' - else return Nothing - --- | Lookup files in a specific directory, and embed them into the haskell source. --- --- A variation of fileLookupDir which allows subsites distributed via cabal to include --- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler --- for dispatching static content for a subsite. -mkEmbedFiles :: FilePath -> Q Exp -mkEmbedFiles d = do - fs <- qRunIO $ getFileList d - clauses <- mapM (mkClause . intercalate "/") fs - defC <- defaultClause - return $ static $ clauses ++ [defC] - where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f - f = mkName "f" - fun clauses = FunD f clauses - defaultClause = do - b <- [| return Nothing |] - return $ Clause [WildP] (NormalB b) [] - - mkClause path = do - content <- qRunIO $ readFile $ d ++ '/':path - let pat = LitP $ StringL path - foldAppE = foldl1 AppE - content' = return $ LitE $ StringL $ content - body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] - return $ Clause [pat] body [] - --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" - -getStaticRoute :: [String] - -> GHandler Static master (ContentType, Content) -getStaticRoute fp' = do - Static fl ctypes <- getYesodSub - when (any isUnsafe fp') notFound - let fp = intercalate "/" fp' - content <- liftIO $ fl fp - case content of - Nothing -> notFound - Just (Left fp'') -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes - sendFile ctype fp'' - Just (Right bs) -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes - return (ctype, bs) - where - isUnsafe [] = True - isUnsafe ('.':_) = True - isUnsafe _ = False - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- lift f - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL hash, ListE []]] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs deleted file mode 100644 index 20a1cc28..00000000 --- a/Yesod/Internal.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | 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 - ) where - -import Text.Hamlet (Hamlet, hamlet, Html) -import Data.Monoid (Monoid (..)) -import Data.List (nub) - -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 - -#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) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - 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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs deleted file mode 100644 index 48cc4236..00000000 --- a/Yesod/Request.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Request --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- 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 "transformers" 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 - --- | The reader monad specialized for 'Request'. -class Monad m => RequestReader m where - getRequest :: m Request -instance RequestReader ((->) Request) where - getRequest = id - --- | 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 the parseWaiRequest function in Yesod.Dispatch (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)] - -- | The POST parameters and submitted files. This is stored in an IO - -- thunk, which essentially means it will be computed once at most, but - -- only if requested. This allows avoidance of the potentially costly - -- parsing of POST bodies for pages which do not use them. - -- - -- Additionally, since the request body is not read until needed, you can - -- directly access the 'W.requestBody' record in 'reqWaiRequest' and - -- perform other forms of parsing. For example, when designing a web - -- service, you may want to accept JSON-encoded data. Just be aware that - -- if you do such parsing, the standard POST form parsing functions will - -- no longer work. - , reqRequestBody :: IO RequestBodyContents - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [String] - -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: 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 :: (MonadIO m, RequestReader m) - => ParamName - -> m [ParamValue] -lookupPostParams pn = do - rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - 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 :: (MonadIO m, RequestReader m) - => ParamName - -> m [FileInfo] -lookupFiles pn = do - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr - 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 deleted file mode 100644 index 8a4c4cb8..00000000 --- a/Yesod/Widget.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# 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 (..) - , liftHandler - -- * Creating - -- ** Head of page - , setTitle - , addHamletHead - , addHtmlHead - -- ** Body - , addHamlet - , addHtml - , addWidget - , addSubWidget - -- ** CSS - , addCassius - , addStylesheet - , addStylesheetRemote - , addStylesheetEither - -- ** Javascript - , addJulius - , addScript - , addScriptRemote - , addScriptEither - -- * Utilities - , extractBody - , newIdent - ) 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 (lift) -import Yesod.Internal - -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 GWidget s m a = GWidget { unGWidget :: GWInner s m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) -type GWInner sub master = - 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 ( - GHandler sub master - )))))))) -instance Monoid (GWidget sub master ()) where - mempty = return () - mappend x y = x >> y - -instance HamletValue (GWidget s m ()) where - newtype HamletMonad (GWidget s m ()) a = - GWidget' { runGWidget' :: GWidget s m a } - type HamletUrl (GWidget s m ()) = Route m - toHamletValue = runGWidget' - htmlToHamletMonad = GWidget' . addHtml - urlToHamletMonad url params = GWidget' $ - addHamlet $ \r -> preEscapedString (r url params) - fromHamletValue = GWidget' -instance Monad (HamletMonad (GWidget s m ())) where - return = GWidget' . return - x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y - --- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' --- monad. -liftHandler :: GHandler sub master a -> GWidget sub master a -liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift - -addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do master <- liftHandler getYesod - let sr = fromSubRoute sub master - i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- liftHandler $ 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 :: Html -> GWidget sub master () -setTitle = GWidget . lift . tell . Last . Just . Title - --- | Add a 'Hamlet' to the head tag. -addHamletHead :: Hamlet (Route master) -> GWidget sub master () -addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head - --- | Add a 'Html' to the head tag. -addHtmlHead :: Html -> GWidget sub master () -addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const - --- | Add a 'Hamlet' to the body tag. -addHamlet :: Hamlet (Route master) -> GWidget sub master () -addHamlet = GWidget . tell . Body - --- | Add a 'Html' to the body tag. -addHtml :: Html -> GWidget sub master () -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 :: GWidget s m () -> GWidget s m () -addWidget = id - --- | Get a unique identifier. -newIdent :: GWidget sub master String -newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do - i <- get - let i' = i + 1 - put i' - return $ "w" ++ show i' - --- | Add some raw CSS to the style tag. -addCassius :: Cassius (Route master) -> GWidget sub master () -addCassius = GWidget . lift . lift . lift . lift . tell . Just - --- | Link to the specified local stylesheet. -addStylesheet :: Route master -> GWidget sub master () -addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local - --- | Link to the specified remote stylesheet. -addStylesheetRemote :: String -> GWidget sub master () -addStylesheetRemote = - GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote - -addStylesheetEither :: Either (Route master) String -> GWidget sub master () -addStylesheetEither = either addStylesheet addStylesheetRemote - -addScriptEither :: Either (Route master) String -> GWidget sub master () -addScriptEither = either addScript addScriptRemote - --- | Link to the specified local script. -addScript :: Route master -> GWidget sub master () -addScript = GWidget . lift . lift . tell . toUnique . Script . Local - --- | Link to the specified remote script. -addScriptRemote :: String -> GWidget sub master () -addScriptRemote = - GWidget . lift . lift . tell . toUnique . Script . Remote - --- | Include raw Javascript in the page's script tag. -addJulius :: Julius (Route master) -> GWidget sub master () -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 :: GWidget s m () -> GWidget s m (Hamlet (Route m)) -extractBody (GWidget w) = - GWidget $ mapWriterT (fmap go) w - where - go ((), Body h) = (h, Body mempty) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs deleted file mode 100644 index ee094a15..00000000 --- a/Yesod/Yesod.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | The basic typeclass for a Yesod application. -module Yesod.Yesod - ( -- * Type classes - Yesod (..) - , YesodSite (..) - , YesodSubSite (..) - -- ** Breadcrumbs - , YesodBreadcrumbs (..) - , breadcrumbs - -- * Utitlities - , maybeAuthorized - , widgetToPageContent - , defaultLayoutJson - , jsonToRepJson - , redirectToPost - -- * Defaults - , defaultErrorHandler - -- * Data types - , AuthResult (..) - -- * Misc - , yesodVersion -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Handler hiding (testSuite) -import qualified Data.ByteString.UTF8 as BSU -#else -import Yesod.Content -import Yesod.Handler -#endif - -import qualified Paths_yesod -import Data.Version (showVersion) -import Yesod.Widget -import Yesod.Request -import Yesod.Hamlet -import qualified Network.Wai as W -import Yesod.Internal -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) -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Web.Routes -import qualified Data.JSON.Types as J - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class Eq (Route y) => YesodSite y where - getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) -type Method = String - --- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as the mkYesodSub creates instances appropriately. -class Eq (Route s) => YesodSubSite s y where - getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite _ = getSubSite - --- | Define settings for a Yesod applications. The only required setting is --- 'approot'; other than that, there are intelligent defaults. -class Eq (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. - encryptKey :: a -> IO CS.Key - encryptKey _ = getKey defaultKeyFile - - -- | Whether or not to use client sessions. - -- - -- FIXME: A better API would be to have 'encryptKey' return a Maybe, but - -- that would be a breaking change. Please include in Yesod 0.7. - enableClientSessions :: a -> Bool - enableClientSessions _ = True - - -- | 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| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %body - $maybe mmsg msg - %p.message $msg$ - ^pageBody.p^ -|] - - -- | Gets called at the beginning of each request. Useful for logging. - onRequest :: GHandler sub a () - onRequest = return () - - -- | 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 split a raw PATH_INFO value into path pieces. It - -- returns a 'Left' value when you should redirect to the given path, and a - -- 'Right' value on successful parse. - -- - -- By default, it splits paths on slashes, and ensures the following are true: - -- - -- * No double slashes - -- - -- * If the last path segment has a period, there is no trailing slash. - -- - -- * Otherwise, ensures there /is/ a trailing slash. - splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ s = - if corrected == s - then Right $ filter (not . null) - $ decodePathInfo - $ S8.unpack s - else Left corrected - where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s - - -- | Remove double slashes - rds :: String -> String - rds [] = [] - rds [x] = [x] - rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - - -- | Add a trailing slash if it is missing. Empty string is left alone. - ats :: String -> String - ats [] = [] - ats t = - if last t == '/' || dbs (reverse t) - then t - else t ++ "/" - - -- | Remove a trailing slash if the last piece has a period. - rts :: String -> String - rts [] = [] - rts t = - if last t == '/' && dbs (tail $ reverse t) - then init t - else t - - -- | Is there a period before a slash here? - dbs :: String -> Bool - dbs ('/':_) = False - dbs (_:'.':_) = True - dbs (_:x) = dbs x - dbs [] = False - - - -- | Join the pieces of a path together into an absolute URL. This should - -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> [(String, String)] -> String - joinPath _ ar pieces qs = - ar ++ '/' : encodePathInfo (fixSegs pieces) qs - where - fixSegs [] = [] - fixSegs [x] - | anyButLast (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash - fixSegs (x:xs) = x : fixSegs xs - anyButLast _ [] = False - anyButLast _ [_] = False - anyButLast p (x:xs) = p x || anyButLast p xs - - -- | 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 - -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 - --- | Provide both an HTML and JSON representation for a piece of data, using --- the default layout for the HTML output ('defaultLayout'). -defaultLayoutJson :: Yesod master - => GWidget sub master () - -> J.Value - -> GHandler sub master RepHtmlJson -defaultLayoutJson w json = do - RepHtml html' <- defaultLayout w - return $ RepHtmlJson html' $ toContent json - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: J.Value -> GHandler sub master RepJson -jsonToRepJson = return . RepJson . toContent - -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 ia msg - %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 (Css b) = Html b - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = Html 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" - $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s - return $ renderLoc x - - let head'' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ - $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ - $nothing - %script ^jelper.j^ -^head'^ -|] - return $ PageContent title head'' body - -#if TEST -testSuite :: Test -testSuite = 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 _ = "" - -propJoinSplitPath :: [String] -> Bool -propJoinSplitPath ss = - splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - == Right ss' - where - ss' = filter (not . null) ss - -caseJoinSplitPathDquote :: Assertion -caseJoinSplitPathDquote = do - splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."] - splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."] - joinPath TmpYesod "" ["z."] [] @?= "/z./" - x @?= Right ss - where - x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - ss' = filter (not . null) ss - ss = ["a."] - -caseUtf8SplitPath :: Assertion -caseUtf8SplitPath = do - Right ["שלום"] @=? - splitPath TmpYesod (BSU.fromString "/שלום/") - Right ["page", "Fooé"] @=? - splitPath TmpYesod (BSU.fromString "/page/Fooé/") - Right ["\156"] @=? - splitPath TmpYesod (BSU.fromString "/\156/") - Right ["ð"] @=? - splitPath TmpYesod (BSU.fromString "/%C3%B0/") - -caseUtf8JoinPath :: Assertion -caseUtf8JoinPath = do - "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] -#endif - --- | 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 :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -!!! -%html - %head - %title Redirecting... - %body!onload="document.getElementById('form').submit()" - %form#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 - -yesodVersion :: String -yesodVersion = showVersion Paths_yesod.version diff --git a/blog.hs b/blog.hs deleted file mode 100644 index 722e0515..00000000 --- a/blog.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -import Yesod -import Yesod.Helpers.Auth -import Yesod.Helpers.Crud -import Database.Persist.Sqlite -import Data.Time (Day) - -share2 mkPersist mkIsForm [$persist| -Entry - title String "label=Entry title" "tooltip=Make it something cool" - posted JqueryDay Desc - content NicHtml - deriving -|] -instance Item Entry where - itemTitle = entryTitle - -getAuth = const $ Auth - { authIsOpenIdEnabled = False - , authRpxnowApiKey = Nothing - , authEmailSettings = Nothing - -- | client id, secret and requested permissions - , authFacebook = Just (clientId, secret, ["email"]) - } - where - clientId = "134280699924829" - secret = "a7685e10c8977f5435e599aaf1d232eb" - -data Blog = Blog Connection -type EntryCrud = Crud Blog Entry -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -/auth AuthR Auth getAuth -|] -instance Yesod Blog where - approot _ = "http://localhost:3000" - defaultLayout p = do - mcreds <- maybeCreds - admin <- maybeAuthorized $ AdminR CrudListR - hamletToContent [$hamlet| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666} - %body - %p - %a!href=@RootR@ Homepage - $maybe admin a - \ | $ - %a!href=@a@ Admin - \ | $ - $maybe mcreds c - Welcome $ - $maybe credsDisplayName.c dn - $dn$ - $nothing - $credsIdent.c$ - \ $ - %a!href=@AuthR.Logout@ Logout - $nothing - %a!href=@AuthR.StartFacebookR@ Facebook Connect - ^pageBody.p^ - %p - Powered by Yesod Web Framework -|] - isAuthorized AdminR{} = do - mc <- maybeCreds - let x = (mc >>= credsEmail) == Just "michael@snoyman.com" - return $ if x then Nothing else Just "Permission denied" - isAuthorized _ = return Nothing -instance YesodAuth Blog where - defaultDest _ = RootR - defaultLoginRoute _ = RootR -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = do - Blog conn <- getYesod - runSqlite db conn - -getRootR = do - entries <- runDB $ select [] [EntryPostedDesc] - applyLayoutW $ do - setTitle $ string "Blog tutorial homepage" - addBody [$hamlet| -%h1 All Entries -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -|] - -getEntryR :: EntryId -> Handler Blog RepHtml -getEntryR eid = do - entry <- runDB (get eid) >>= maybe notFound return - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.unJqueryDay.entryPosted.entry$ -#content $unNicHtml.entryContent.entry$ -|] -main = withSqlite "blog.db3" $ \conn -> do - flip runSqlite conn $ initialize (undefined :: Entry) - toWaiApp (Blog conn) >>= basicHandler 3000 diff --git a/blog2.hs b/blog2.hs deleted file mode 100644 index 3a58325f..00000000 --- a/blog2.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -import Yesod -import Yesod.Helpers.Crud -import Yesod.Form.Jquery -import Yesod.Form.Nic -import Database.Persist.Sqlite -import Database.Persist.TH -import Data.Time (Day) - -share2 mkToForm mkPersist [$persist| -Entry - title String id=thetitle - day Day Desc toFormField=YesodJquery.jqueryDayField name=day - content Html' toFormField=YesodNic.nicHtmlField - deriving -|] - -instance Item Entry where - itemTitle = entryTitle - -data Blog = Blog { pool :: Pool Connection } - -type EntryCrud = Crud Blog Entry - -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -|] - -instance Yesod Blog where - approot _ = "http://localhost:3000" -instance YesodJquery Blog -instance YesodNic Blog - -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = fmap pool getYesod>>= runSqlite db - -getRootR = do - entries <- runDB $ selectList [] [EntryDayDesc] 0 0 - applyLayoutW $ do - setTitle $ string "Yesod Blog Tutorial Homepage" - addBody [$hamlet| -%h1 Archive -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -%p - %a!href=@AdminR.CrudListR@ Admin -|] - -getEntryR entryid = do - entry <- runDB $ get404 entryid - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.entryDay.entry$ -$entryContent.entry$ -|] - -withBlog f = withSqlite ":memory:" 8 $ \p -> do - flip runSqlite p $ do - initialize (undefined :: Entry) - f $ Blog p - -main = withBlog $ basicHandler 3000 diff --git a/freeform.hs b/freeform.hs deleted file mode 100644 index 3f8b263a..00000000 --- a/freeform.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} -import Yesod -import Control.Applicative - -data FreeForm = FreeForm -mkYesod "FreeForm" [$parseRoutes| -/ RootR GET -|] -instance Yesod FreeForm where approot _ = "" - -data Person = Person String Int String - deriving Show - -getRootR = do - ((merr, mperson, form), enctype) <- runFormMonadGet $ do - (name, namef) <- stringField "Name" Nothing - (age, agef) <- intField "Age" $ Just 25 - (color, colorf) <- stringField "Color" Nothing - let (merr, mperson) = - case Person <$> name <*> age <*> color of - FormSuccess p -> (Nothing, Just p) - FormFailure e -> (Just e, Nothing) - FormMissing -> (Nothing, Nothing) - let form = [$hamlet| -Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^. -|] - return (merr, mperson, form) - defaultLayout [$hamlet| -$maybe merr err - %ul!style=color:red - $forall err e - %li $e$ -$maybe mperson person - %p Last person: $show.person$ -%form!method=get!action=@RootR@!enctype=$enctype$ - %p ^form^ - %input!type=submit!value=Submit -|] - -main = basicHandler 3000 FreeForm diff --git a/haddock.sh b/haddock.sh deleted file mode 100755 index 337c58c7..00000000 --- a/haddock.sh +++ /dev/null @@ -1,2 +0,0 @@ -cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html' -scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/ diff --git a/helloworld.hs b/helloworld.hs deleted file mode 100644 index 2a3f8723..00000000 --- a/helloworld.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} -import Yesod -data HelloWorld = HelloWorld -mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] -instance Yesod HelloWorld where approot _ = "" -getHome = return $ RepPlain $ toContent "Hello World!" -main = basicHandler 3000 HelloWorld diff --git a/mail.hs b/mail.hs deleted file mode 100644 index 8e39e0e2..00000000 --- a/mail.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Yesod.Mail -import qualified Data.ByteString.Lazy.Char8 as L -import System.Environment - -main = do - [dest] <- getArgs - let p1 = Part "text/html" None Inline $ L.pack "

Hello World!!!

" - lbs <- L.readFile "mail.hs" - let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs - let mail = Mail - [("To", dest), ("Subject", "mail quine")] - "Plain stuff. Mime-clients should not show it." - [p1, p2] - renderSendMail mail diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 index e3fe7bc8..00000000 --- a/runtests.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Framework (defaultMain) - -import qualified Yesod.Content -import qualified Yesod.Json -import qualified Yesod.Dispatch -import qualified Yesod.Helpers.Static -import qualified Yesod.Yesod -import qualified Yesod.Handler - -main :: IO () -main = defaultMain - [ Yesod.Content.testSuite - , Yesod.Json.testSuite - , Yesod.Dispatch.testSuite - , Yesod.Helpers.Static.testSuite - , Yesod.Yesod.testSuite - , Yesod.Handler.testSuite - ] diff --git a/test/.ignored b/test/.ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/test/bar/baz b/test/bar/baz deleted file mode 100644 index e69de29b..00000000 diff --git a/test/foo b/test/foo deleted file mode 100644 index e69de29b..00000000 diff --git a/test/tmp/ignored b/test/tmp/ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/yesod.cabal b/yesod.cabal index 5aaaf0f4..37bc6cf4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -20,90 +20,28 @@ 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 - , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.12 - , template-haskell - , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.6 && < 0.7 - , blaze-builder >= 0.2.1 && < 0.3 - , transformers >= 0.2 && < 0.3 - , clientsession >= 0.4.0 && < 0.5 - , pureMD5 >= 1.1.0.0 && < 2.2 - , random >= 1.0.0.2 && < 1.1 - , cereal >= 0.2 && < 0.4 - , base64-bytestring >= 0.1 && < 0.2 - , old-locale >= 1.0.0.2 && < 1.1 - , neither >= 0.2 && < 0.3 - , network >= 2.2.1.5 && < 2.4 - , email-validate >= 0.2.5 && < 0.3 - , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.2.3 && < 0.3 - , data-default >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 - , containers >= 0.2 && < 0.5 + build-depends: base >= 4 && < 5 + , yesod-core >= 0.7 && < 0.8 , monad-peel >= 0.1 && < 0.2 - , enumerator >= 0.4 && < 0.5 - , cookie >= 0.0 && < 0.1 - , json-enumerator >= 0.0 && < 0.1 - , json-types >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.3 + , wai >= 0.3 && < 0.4 + , hamlet >= 0.7 && < 0.8 exposed-modules: Yesod - Yesod.Content - Yesod.Dispatch - Yesod.Hamlet - Yesod.Handler - Yesod.Request - Yesod.Widget - Yesod.Yesod - Yesod.Helpers.AtomFeed - Yesod.Helpers.Sitemap - Yesod.Helpers.Static - other-modules: Yesod.Internal - Paths_yesod ghc-options: -Wall executable yesod - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - build-depends: parsec >= 2.1 && < 4 + build-depends: parsec >= 2.1 && < 4 + , text >= 0.11 && < 0.12 + , bytestring >= 0.9 && < 0.10 + , time >= 1.1.4 && < 1.3 + , template-haskell + , directory >= 1.0 && < 1.2 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen extensions: TemplateHaskell -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.git