haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-core split

Browse Source
This commit is contained in:
Michael Snoyman 2010-12-26 10:59:12 +02:00
parent e2ace86bb9
commit c88bbfa33e
26 changed files with 40 additions and 3319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
ChangeLog.md
View File

@ -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.

6
Setup.lhs
View File

@ -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

42
Yesod.hs
View File

@ -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

267
Yesod/Content.hs
View File

@ -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"

539
Yesod/Dispatch.hs
View File

@ -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

59
Yesod/Hamlet.hs
View File

@ -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

588
Yesod/Handler.hs
View File

@ -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 <michael@snoyman.com>
-- 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

96
Yesod/Helpers/AtomFeed.hs
View File

@ -1,96 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
---------------------------------------------------------
--
-- Module : Yesod.Helpers.AtomFeed
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- Generating atom news feeds.
--
---------------------------------------------------------
-- | Generation of Atom newsfeeds. See
-- <http://en.wikipedia.org/wiki/Atom_(standard)>.
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
<?xml version="1.0" encoding="utf-8"?>
%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$
|]

79
Yesod/Helpers/Sitemap.hs
View File

@ -1,79 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
---------------------------------------------------------
--
-- Module : Yesod.Helpers.Sitemap
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- Generating Google sitemap files.
--
---------------------------------------------------------
-- | Generates XML sitemap files.
--
-- See <http://www.sitemaps.org/>.
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)

252
Yesod/Helpers/Static.hs
View File

@ -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 <michael@snoyman.com>
-- 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

103
Yesod/Internal.hs
View File

@ -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

168
Yesod/Request.hs
View File

@ -1,168 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE CPP #-}
---------------------------------------------------------
--
-- Module : Yesod.Request
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- | Provides a parsed version of the raw 'W.Request' data.
--
---------------------------------------------------------
module Yesod.Request
(
-- * Request datatype
RequestBodyContents
, Request (..)
, RequestReader (..)
, FileInfo (..)
-- * Convenience functions
, waiRequest
, languages
-- * Lookup parameters
, lookupGetParam
, lookupPostParam
, lookupCookie
, lookupFile
-- ** Multi-lookup
, lookupGetParams
, lookupPostParams
, lookupCookies
, lookupFiles
-- * Parameter type synonyms
, ParamName
, ParamValue
, ParamError
) where
import qualified Network.Wai as W
import qualified Data.ByteString.Lazy as BL
import "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

189
Yesod/Widget.hs
View File

@ -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)

537
Yesod/Yesod.hs
View File

@ -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

108
blog.hs
View File

@ -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

71
blog2.hs
View File

@ -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

40
freeform.hs
View File

@ -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

2
haddock.sh
View File

@ -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/

7
helloworld.hs
View File

@ -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

14
mail.hs
View File

@ -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 "<h1>Hello World!!!</h1>"
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

18
runtests.hs
View File

@ -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
]

0
test/.ignored
View File

0
test/bar/baz
View File

0
test/foo
View File

0
test/tmp/ignored
View File

84
yesod.cabal
View File

@ -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