yesod 0.6.7 → 0.7.0
raw patch · 41 files changed
+243/−5084 lines, 41 filesdep +attoparsec-textdep +hjsmindep +mime-maildep −HUnitdep −QuickCheckdep −base64-bytestringdep ~basedep ~bytestringdep ~directorysetup-changed
Dependencies added: attoparsec-text, hjsmin, mime-mail, monad-peel, wai-handler-devel, warp, yesod-auth, yesod-core, yesod-form, yesod-json, yesod-persistent, yesod-static
Dependencies removed: HUnit, QuickCheck, base64-bytestring, blaze-builder, cereal, clientsession, containers, data-default, email-validate, failure, neither, network, old-locale, persistent, pureMD5, random, test-framework, test-framework-hunit, test-framework-quickcheck2, web-routes, web-routes-quasi, xss-sanitize
Dependency ranges changed: base, bytestring, directory, hamlet, template-haskell, text, wai, wai-extra
Files
- Setup.lhs +1/−5
- Yesod.hs +116/−20
- Yesod/Content.hs +0/−263
- Yesod/Dispatch.hs +0/−490
- Yesod/Form.hs +0/−341
- Yesod/Form/Class.hs +0/−61
- Yesod/Form/Core.hs +0/−369
- Yesod/Form/Fields.hs +0/−409
- Yesod/Form/Jquery.hs +0/−235
- Yesod/Form/Nic.hs +0/−61
- Yesod/Form/Profiles.hs +0/−235
- Yesod/Hamlet.hs +0/−59
- Yesod/Handler.hs +0/−571
- Yesod/Helpers/AtomFeed.hs +0/−96
- Yesod/Helpers/Crud.hs +0/−208
- Yesod/Helpers/Sitemap.hs +0/−79
- Yesod/Helpers/Static.hs +0/−252
- Yesod/Internal.hs +0/−103
- Yesod/Json.hs +0/−140
- Yesod/Request.hs +0/−161
- Yesod/Widget.hs +0/−200
- Yesod/Yesod.hs +0/−542
- runtests.hs +0/−18
- scaffold.hs +22/−5
- scaffold/Controller_hs.cg +5/−2
- scaffold/Model_hs.cg +1/−1
- scaffold/Root_hs.cg +1/−1
- scaffold/Settings_hs.cg +3/−3
- scaffold/cabal.cg +19/−21
- scaffold/default-layout_hamlet.cg +8/−8
- scaffold/devel-server_hs.cg +2/−17
- scaffold/fastcgi_hs.cg +0/−6
- scaffold/favicon_ico.cg binary
- scaffold/homepage_cassius.cg +1/−1
- scaffold/homepage_hamlet.cg +11/−11
- scaffold/homepage_julius.cg +1/−1
- scaffold/production_hs.cg +6/−0
- scaffold/simple-server_hs.cg +0/−6
- scaffold/sitearg_hs.cg +9/−11
- scaffold/test_hs.cg +11/−0
- yesod.cabal +26/−72
Setup.lhs view
@@ -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
Yesod.hs view
@@ -1,48 +1,81 @@+{-# LANGUAGE OverloadedStrings #-} {-# 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.Widget , module Yesod.Form- , module Yesod.Hamlet , module Yesod.Json- , module Yesod.Widget+ , module Yesod.Persist+ -- * Running your application+ , warp+ , warpDebug+ , develServer+ -- * Commonly referenced functions/datatypes , Application , lift , liftIO- , MonadInvertIO- , mempty+ , MonadPeelIO+ -- * 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.Json hiding (testSuite)-import Yesod.Dispatch hiding (testSuite)-import Yesod.Yesod hiding (testSuite)-import Yesod.Handler hiding (runHandler, testSuite)-#else import Yesod.Content-import Yesod.Json 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.Form import Yesod.Widget+import Yesod.Form+import Yesod.Json+import Yesod.Persist import Network.Wai (Application)-import Yesod.Hamlet+import Network.Wai.Middleware.Debug+#if !GHC7+import Network.Wai.Handler.DevelServer (runQuit)+#endif import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO)-import Data.Monoid (mempty)-import Control.Monad.Invert (MonadInvertIO)+import Control.Monad.IO.Peel (MonadPeelIO) +import Network.Wai.Handler.Warp (run)+import System.IO (stderr, hPutStrLn)++import qualified Data.Text.Lazy.IO as TIO+import qualified Data.Attoparsec.Text.Lazy as A+import Control.Applicative ((<|>))+import Data.Maybe (mapMaybe)+import Data.Char (isSpace)+ showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -51,3 +84,66 @@ case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing++-- | A convenience method to run an application using the Warp webserver on the+-- specified port. Automatically calls 'toWaiApp'.+warp :: (Yesod a, YesodDispatch a a) => Int -> a -> IO ()+warp port a = toWaiApp a >>= run port++-- | Same as 'warp', but also sends a message to stderr for each request, and+-- an \"application launched\" message as well. Can be useful for development.+warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO ()+warpDebug port a = do+ hPutStrLn stderr $ "Application launched, listening on port " ++ show port+ toWaiApp a >>= run port . debug++-- | Run a development server, where your code changes are automatically+-- reloaded.+develServer :: Int -- ^ port number+ -> String -- ^ module name holding the code+ -> String -- ^ name of function providing a with-application+ -> IO ()+#if GHC7+develServer = error "Unfortunately, the hint package has not yet been ported to GHC 7, and therefore wai-handler-devel has not either. Once this situation is addressed, a new version of Yesod will be released."+#else+develServer port modu func = do+ mapM_ putStrLn+ [ "Starting your server process. Code changes will be automatically"+ , "loaded as you save your files. Type \"quit\" to exit."+ , "You can view your app at http://localhost:" ++ show port ++ "/"+ , ""+ ]+ runQuit port modu func determineHamletDeps+#endif++data TempType = Hamlet | Cassius | Julius | Widget+ deriving Show++-- | Determine which Hamlet files a Haskell file depends upon.+determineHamletDeps :: FilePath -> IO [FilePath]+determineHamletDeps x = do+ y <- TIO.readFile x+ let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y+ case z of+ A.Fail{} -> return []+ A.Done _ r -> return $ mapMaybe go r+ where+ go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"+ go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"+ go _ = Nothing+ parser = do+ typ <- (A.string "$(hamletFile " >> return Hamlet)+ <|> (A.string "$(cassiusFile " >> return Cassius)+ <|> (A.string "$(juliusFile " >> return Julius)+ <|> (A.string "$(widgetFile " >> return Widget)+ <|> (A.string "$(Settings.hamletFile " >> return Hamlet)+ <|> (A.string "$(Settings.cassiusFile " >> return Cassius)+ <|> (A.string "$(Settings.juliusFile " >> return Julius)+ <|> (A.string "$(Settings.widgetFile " >> return Widget)+ A.skipWhile isSpace+ _ <- A.char '"'+ y <- A.many1 $ A.satisfy (/= '"')+ _ <- A.char '"'+ A.skipWhile isSpace+ _ <- A.char ')'+ return $ Just (typ, y)
− Yesod/Content.hs
@@ -1,263 +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- , formatCookieExpires-#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 qualified Network.Wai as W--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--type Content = W.ResponseBody---- | Zero-length enumerator.-emptyContent :: Content-emptyContent = W.ResponseLBS L.empty---- | 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 = W.ResponseLBS . L.fromChunks . return-instance ToContent L.ByteString where- toContent = W.ResponseLBS-instance ToContent T.Text where- toContent = toContent . Data.Text.Encoding.encodeUtf8-instance ToContent Text where- toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8-instance ToContent String where- toContent = toContent . T.pack---- | 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"---- | Format a 'UTCTime' for a cookie.-formatCookieExpires :: UTCTime -> String-formatCookieExpires = formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT"
− Yesod/Dispatch.hs
@@ -1,490 +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 (cleanPathFunc)-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 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 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--#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. You can use 'basicHandler' if you wish.-toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application-toWaiApp a =- return $ gzip- $ jsonp- $ cleanPathFunc (splitPath a) (B.pack $ approot a)- $ toWaiApp' a--toWaiApp' :: (Yesod y, YesodSite y)- => y- -> [String]- -> W.Request- -> IO W.Response-toWaiApp' y segments env = do- key' <- encryptKey y- 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' = 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'- (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap- let sessionVal = encodeSession key' exp' host- $ Map.toList- $ Map.insert nonceKey (reqNonce rr) sessionFinal- let hs' = AddCookie (clientSessionDuration y) sessionName- (bsToChars sessionVal)- : hs- hs'' = map (headerToPair getExpires) hs'- hs''' = ("Content-Type", charsToBs ct) : hs''- return $ W.Response s hs''' c--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 = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where- fix1 = map (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) =- let expires = getExpires minutes- in ("Set-Cookie", charsToBs- $ key ++ "=" ++ value ++"; path=/; expires="- ++ formatCookieExpires expires)-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
− Yesod/Form.hs
@@ -1,341 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}--- | Parse forms (and query strings).-module Yesod.Form- ( -- * Data types- GForm- , FormResult (..)- , Enctype (..)- , FormFieldSettings (..)- , Textarea (..)- , FieldInfo (..)- -- ** Utilities- , formFailures- -- * Type synonyms- , Form- , Formlet- , FormField- , FormletField- , FormInput- -- * Unwrapping functions- , generateForm- , runFormGet- , runFormMonadGet- , runFormPost- , runFormPostNoNonce- , runFormMonadPost- , runFormGet'- , runFormPost'- -- ** High-level form post unwrappers- , runFormTable- , runFormDivs- -- * Field/form helpers- , fieldsToTable- , fieldsToDivs- , fieldsToPlain- , checkForm- -- * Type classes- , module Yesod.Form.Class- -- * Template Haskell- , mkToForm- , module Yesod.Form.Fields- ) where--import Yesod.Form.Core-import Yesod.Form.Fields-import Yesod.Form.Class-import Yesod.Form.Profiles (Textarea (..))-import Yesod.Widget (GWidget)--import Text.Hamlet-import Yesod.Request-import Yesod.Handler-import Control.Applicative hiding (optional)-import Data.Maybe (fromMaybe, mapMaybe)-import "transformers" Control.Monad.IO.Class-import Control.Monad ((<=<))-import Language.Haskell.TH.Syntax-import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))-import Data.Char (toUpper, isUpper)-import Control.Arrow ((&&&))-import Data.List (group, sort)---- | Display only the actual input widget code, without any decoration.-fieldsToPlain :: FormField sub y a -> Form sub y a-fieldsToPlain = mapFormXml $ mapM_ fiInput---- | Display the label, tooltip, input code and errors in a single row of a--- table.-fieldsToTable :: FormField sub y a -> Form sub y a-fieldsToTable = mapFormXml $ mapM_ go- where- go fi =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%tr.$clazz.fi$- %td- %label!for=$fiIdent.fi$ $fiLabel.fi$- .tooltip $fiTooltip.fi$- %td- ^fiInput.fi^- $maybe fiErrors.fi err- %td.errors $err$-|]- clazz fi = if fiRequired fi then "required" else "optional"---- | Display the label, tooltip, input code and errors in a single div.-fieldsToDivs :: FormField sub y a -> Form sub y a-fieldsToDivs = mapFormXml $ mapM_ go- where- go fi =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-.$clazz.fi$- %label!for=$fiIdent.fi$ $fiLabel.fi$- .tooltip $fiTooltip.fi$- ^fiInput.fi^- $maybe fiErrors.fi err- %div.errors $err$-|]- clazz fi = if fiRequired fi then "required" else "optional"---- | Run a form against POST parameters, without CSRF protection.-runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)-runFormPostNoNonce f = do- rr <- getRequest- (pp, files) <- liftIO $ reqRequestBody rr- runFormGeneric pp files f---- | Run a form against POST parameters.------ This function includes CSRF protection by checking a nonce value. You must--- therefore embed this nonce in the form as a hidden field; that is the--- meaning of the fourth element in the tuple.-runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)-runFormPost f = do- rr <- getRequest- (pp, files) <- liftIO $ reqRequestBody rr- nonce <- fmap reqNonce getRequest- (res, xml, enctype) <- runFormGeneric pp files f- let res' =- case res of- FormSuccess x ->- if lookup nonceName pp == Just nonce- then FormSuccess x- else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."]- _ -> res- return (res', xml, enctype, hidden nonce)- where- hidden nonce =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- %input!type=hidden!name=$nonceName$!value=$nonce$-|]--nonceName :: String-nonceName = "_nonce"---- | Run a form against POST parameters. Please note that this does not provide--- CSRF protection.-runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)-runFormMonadPost f = do- rr <- getRequest- (pp, files) <- liftIO $ reqRequestBody rr- runFormGeneric pp files f---- | Run a form against POST parameters, disregarding the resulting HTML and--- returning an error response on invalid input. Note: this does /not/ perform--- CSRF protection.-runFormPost' :: GForm sub y xml a -> GHandler sub y a-runFormPost' f = do- rr <- getRequest- (pp, files) <- liftIO $ reqRequestBody rr- x <- runFormGeneric pp files f- helper x---- | Create a table-styled form.------ This function wraps around 'runFormPost' and 'fieldsToTable', taking care of--- some of the boiler-plate in creating forms. In particular, is automatically--- creates the form element, sets the method, action and enctype attributes,--- adds the CSRF-protection nonce hidden field and inserts a submit button.-runFormTable :: Route m -> String -> FormField s m a- -> GHandler s m (FormResult a, GWidget s m ())-runFormTable dest inputLabel form = do- (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form- let widget' =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%form!method=post!action=@dest@!enctype=$enctype$- %table- ^widget^- %tr- %td!colspan=2- $nonce$- %input!type=submit!value=$inputLabel$-|]- return (res, widget')---- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling.-runFormDivs :: Route m -> String -> FormField s m a- -> GHandler s m (FormResult a, GWidget s m ())-runFormDivs dest inputLabel form = do- (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form- let widget' =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%form!method=post!action=@dest@!enctype=$enctype$- ^widget^- %div- $nonce$- %input!type=submit!value=$inputLabel$-|]- return (res, widget')---- | Run a form against GET parameters, disregarding the resulting HTML and--- returning an error response on invalid input.-runFormGet' :: GForm sub y xml a -> GHandler sub y a-runFormGet' = helper <=< runFormGet--helper :: (FormResult a, b, c) -> GHandler sub y a-helper (FormSuccess a, _, _) = return a-helper (FormFailure e, _, _) = invalidArgs e-helper (FormMissing, _, _) = invalidArgs ["No input found"]---- | Generate a form, feeding it no data. The third element in the result tuple--- is a nonce hidden field.-generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)-generateForm f = do- (_, b, c) <- runFormGeneric [] [] f- nonce <- fmap reqNonce getRequest- return (b, c,-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- %input!type=hidden!name=$nonceName$!value=$nonce$-|])---- | Run a form against GET parameters.-runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)-runFormGet f = do- gs <- reqGetParams `fmap` getRequest- runFormGeneric gs [] f--runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)-runFormMonadGet f = do- gs <- reqGetParams `fmap` getRequest- runFormGeneric gs [] f---- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.-mkToForm :: PersistEntity v => v -> Q [Dec]-mkToForm =- fmap return . derive . entityDef- where- afterPeriod s =- case dropWhile (/= '.') s of- ('.':t) -> t- _ -> s- beforePeriod s =- case break (== '.') s of- (t, '.':_) -> Just t- _ -> Nothing- getSuperclass (_, _, z) = getTFF' z >>= beforePeriod- getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z- getTFF' [] = Nothing- getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x- getTFF' (_:x) = getTFF' x- getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z- getLabel' [] = Nothing- getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x- getLabel' (_:x) = getLabel' x- getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z- getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x- getTooltip' (_:x) = getTooltip' x- getTooltip' [] = Nothing- getId (_, _, z) = fromMaybe "" $ getId' z- getId' (('i':'d':'=':x):_) = Just x- getId' (_:x) = getId' x- getId' [] = Nothing- getName (_, _, z) = fromMaybe "" $ getName' z- getName' (('n':'a':'m':'e':'=':x):_) = Just x- getName' (_:x) = getName' x- getName' [] = Nothing- derive :: EntityDef -> Q Dec- derive t = do- let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t- ap <- [|(<*>)|]- just <- [|pure|]- nothing <- [|Nothing|]- let just' = just `AppE` ConE (mkName $ entityName t)- string' <- [|string|]- ftt <- [|fieldsToTable|]- ffs' <- [|FormFieldSettings|]- let stm "" = nothing- stm x = just `AppE` LitE (StringL x)- let go_ = go ap just' ffs' stm string' ftt- let c1 = Clause [ ConP (mkName "Nothing") []- ]- (NormalB $ go_ $ zip cols $ map (const nothing) cols)- []- xs <- mapM (const $ newName "x") cols- let xs' = map (AppE just . VarE) xs- let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)- $ map VarP xs]]- (NormalB $ go_ $ zip cols xs')- []- let y = mkName "y"- let ctx = map (\x -> ClassP (mkName x) [VarT y])- $ map head $ group $ sort- $ mapMaybe getSuperclass- $ entityColumns t- return $ InstanceD ctx ( ConT ''ToForm- `AppT` ConT (mkName $ entityName t)- `AppT` VarT y)- [FunD (mkName "toForm") [c1, c2]]- go ap just' ffs' stm string' ftt a =- let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a- in ftt `AppE` x- go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) =- let label' = LitE $ StringL label- tooltip' = string' `AppE` LitE (StringL tooltip)- ffs = ffs' `AppE`- label' `AppE`- tooltip' `AppE`- (stm theId) `AppE`- (stm name)- in VarE (mkName tff) `AppE` ffs `AppE` ex- ap' ap x y = InfixE (Just x) ap (Just y)--toLabel :: String -> String-toLabel "" = ""-toLabel (x:rest) = toUpper x : go rest- where- go "" = ""- go (c:cs)- | isUpper c = ' ' : c : go cs- | otherwise = c : go cs--formFailures :: FormResult a -> Maybe [String]-formFailures (FormFailure x) = Just x-formFailures _ = Nothing
− Yesod/Form/Class.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Yesod.Form.Class- ( ToForm (..)- , ToFormField (..)- ) where--import Text.Hamlet-import Yesod.Form.Fields-import Yesod.Form.Core-import Yesod.Form.Profiles (Textarea)-import Data.Int (Int64)-import Data.Time (Day, TimeOfDay)--class ToForm a y where- toForm :: Formlet sub y a-class ToFormField a y where- toFormField :: FormFieldSettings -> FormletField sub y a--instance ToFormField String y where- toFormField = stringField-instance ToFormField (Maybe String) y where- toFormField = maybeStringField--instance ToFormField Int y where- toFormField = intField-instance ToFormField (Maybe Int) y where- toFormField = maybeIntField-instance ToFormField Int64 y where- toFormField = intField-instance ToFormField (Maybe Int64) y where- toFormField = maybeIntField--instance ToFormField Double y where- toFormField = doubleField-instance ToFormField (Maybe Double) y where- toFormField = maybeDoubleField--instance ToFormField Day y where- toFormField = dayField-instance ToFormField (Maybe Day) y where- toFormField = maybeDayField--instance ToFormField TimeOfDay y where- toFormField = timeField-instance ToFormField (Maybe TimeOfDay) y where- toFormField = maybeTimeField--instance ToFormField Bool y where- toFormField = boolField--instance ToFormField Html y where- toFormField = htmlField-instance ToFormField (Maybe Html) y where- toFormField = maybeHtmlField--instance ToFormField Textarea y where- toFormField = textareaField-instance ToFormField (Maybe Textarea) y where- toFormField = maybeTextareaField
− Yesod/Form/Core.hs
@@ -1,369 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--- | Users of the forms library should not need to use this module in general.--- It is intended only for writing custom forms and form fields.-module Yesod.Form.Core- ( FormResult (..)- , GForm (..)- , newFormIdent- , deeperFormIdent- , shallowerFormIdent- , Env- , FileEnv- , Enctype (..)- , Ints (..)- , requiredFieldHelper- , optionalFieldHelper- , fieldsToInput- , mapFormXml- , checkForm- , checkField- , askParams- , askFiles- , liftForm- , IsForm (..)- , RunForm (..)- , GFormMonad- -- * Data types- , FieldInfo (..)- , FormFieldSettings (..)- , FieldProfile (..)- -- * Type synonyms- , Form- , Formlet- , FormField- , FormletField- , FormInput- ) where--import Control.Monad.Trans.State-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Class (lift)-import Yesod.Handler-import Yesod.Widget-import Data.Monoid (Monoid (..))-import Control.Applicative-import Yesod.Request-import Control.Monad (liftM)-import Text.Hamlet-import Data.String-import Control.Monad (join)---- | A form can produce three different results: there was no data available,--- the data was invalid, or there was a successful parse.------ The 'Applicative' instance will concatenate the failure messages in two--- 'FormResult's.-data FormResult a = FormMissing- | FormFailure [String]- | FormSuccess a- deriving Show-instance Functor FormResult where- fmap _ FormMissing = FormMissing- fmap _ (FormFailure errs) = FormFailure errs- fmap f (FormSuccess a) = FormSuccess $ f a-instance Applicative FormResult where- pure = FormSuccess- (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g- (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y- (FormFailure x) <*> _ = FormFailure x- _ <*> (FormFailure y) = FormFailure y- _ <*> _ = FormMissing-instance Monoid m => Monoid (FormResult m) where- mempty = pure mempty- mappend x y = mappend <$> x <*> y---- | The encoding type required by a form. The 'Show' instance produces values--- that can be inserted directly into HTML.-data Enctype = UrlEncoded | Multipart- deriving (Eq, Enum, Bounded)-instance ToHtml Enctype where- toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded"- toHtml Multipart = unsafeByteString "multipart/form-data"-instance Monoid Enctype where- mempty = UrlEncoded- mappend UrlEncoded UrlEncoded = UrlEncoded- mappend _ _ = Multipart--data Ints = IntCons Int Ints | IntSingle Int-instance Show Ints where- show (IntSingle i) = show i- show (IntCons i is) = show i ++ '-' : show is--incrInts :: Ints -> Ints-incrInts (IntSingle i) = IntSingle $ i + 1-incrInts (IntCons i is) = (i + 1) `IntCons` is---- | A generic form, allowing you to specifying the subsite datatype, master--- site datatype, a datatype for the form XML and the return type.-newtype GForm s m xml a = GForm- { deform :: FormInner s m (FormResult a, xml, Enctype)- }--type GFormMonad s m a = WriterT Enctype (FormInner s m) a--type FormInner s m =- StateT Ints (- ReaderT Env (- ReaderT FileEnv (- GHandler s m- )))--type Env = [(String, String)]-type FileEnv = [(String, FileInfo)]---- | Get a unique identifier.-newFormIdent :: Monad m => StateT Ints m String-newFormIdent = do- i <- get- let i' = incrInts i- put i'- return $ 'f' : show i'--deeperFormIdent :: Monad m => StateT Ints m ()-deeperFormIdent = do- i <- get- let i' = 1 `IntCons` incrInts i- put i'--shallowerFormIdent :: Monad m => StateT Ints m ()-shallowerFormIdent = do- IntCons _ i <- get- put i--instance Monoid xml => Functor (GForm sub url xml) where- fmap f (GForm g) =- GForm $ liftM (first3 $ fmap f) g- where- first3 f' (x, y, z) = (f' x, y, z)--instance Monoid xml => Applicative (GForm sub url xml) where- pure a = GForm $ return (pure a, mempty, mempty)- (GForm f) <*> (GForm g) = GForm $ do- (f1, f2, f3) <- f- (g1, g2, g3) <- g- return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)---- | Create a required field (ie, one that cannot be blank) from a--- 'FieldProfile'.-requiredFieldHelper- :: IsForm f- => FieldProfile (FormSub f) (FormMaster f) (FormType f)- -> FormFieldSettings- -> Maybe (FormType f)- -> f-requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do- env <- lift ask- let (FormFieldSettings label tooltip theId' name') = ffs- name <- maybe newFormIdent return name'- theId <- maybe newFormIdent return theId'- let (res, val) =- if null env- then (FormMissing, maybe "" render orig)- else case lookup name env of- Nothing -> (FormMissing, "")- Just "" -> (FormFailure ["Value is required"], "")- Just x ->- case parse x of- Left e -> (FormFailure [e], x)- Right y -> (FormSuccess y, x)- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = mkWidget theId name val True- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- , fiRequired = True- }- let res' = case res of- FormFailure [e] -> FormFailure [label ++ ": " ++ e]- _ -> res- return (res', fi, UrlEncoded)--class IsForm f where- type FormSub f- type FormMaster f- type FormType f- toForm :: FormInner- (FormSub f)- (FormMaster f)- (FormResult (FormType f),- FieldInfo (FormSub f) (FormMaster f),- Enctype) -> f-instance IsForm (FormField s m a) where- type FormSub (FormField s m a) = s- type FormMaster (FormField s m a) = m- type FormType (FormField s m a) = a- toForm x = GForm $ do- (a, b, c) <- x- return (a, [b], c)-instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where- type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s- type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m- type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a- toForm x = do- (res, fi, enctype) <- lift x- tell enctype- return (res, fi)--class RunForm f where- type RunFormSub f- type RunFormMaster f- type RunFormType f- runFormGeneric :: Env -> FileEnv -> f- -> GHandler (RunFormSub f)- (RunFormMaster f)- (RunFormType f)--instance RunForm (GForm s m xml a) where- type RunFormSub (GForm s m xml a) = s- type RunFormMaster (GForm s m xml a) = m- type RunFormType (GForm s m xml a) =- (FormResult a, xml, Enctype)- runFormGeneric env fe (GForm f) =- runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe--instance RunForm (GFormMonad s m a) where- type RunFormSub (GFormMonad s m a) = s- type RunFormMaster (GFormMonad s m a) = m- type RunFormType (GFormMonad s m a) = (a, Enctype)- runFormGeneric e fe f =- runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe---- | Create an optional field (ie, one that can be blank) from a--- 'FieldProfile'.-optionalFieldHelper- :: (IsForm f, Maybe b ~ FormType f)- => FieldProfile (FormSub f) (FormMaster f) b- -> FormFieldSettings- -> Maybe (Maybe b)- -> f-optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do- env <- lift ask- let (FormFieldSettings label tooltip theId' name') = ffs- let orig = join orig'- name <- maybe newFormIdent return name'- theId <- maybe newFormIdent return theId'- let (res, val) =- if null env- then (FormSuccess Nothing, maybe "" render orig)- else case lookup name env of- Nothing -> (FormSuccess Nothing, "")- Just "" -> (FormSuccess Nothing, "")- Just x ->- case parse x of- Left e -> (FormFailure [e], x)- Right y -> (FormSuccess $ Just y, x)- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = mkWidget theId name val False- , fiErrors = case res of- FormFailure x -> Just $ string $ unlines x- _ -> Nothing- , fiRequired = False- }- let res' = case res of- FormFailure [e] -> FormFailure [label ++ ": " ++ e]- _ -> res- return (res', fi, UrlEncoded)--fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]-fieldsToInput = map fiInput---- | Convert the XML in a 'GForm'.-mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a-mapFormXml f (GForm g) = GForm $ do- (res, xml, enc) <- g- return (res, f xml, enc)---- | Using this as the intermediate XML representation for fields allows us to--- write generic field functions and then different functions for producing--- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'.-data FieldInfo sub y = FieldInfo- { fiLabel :: Html- , fiTooltip :: Html- , fiIdent :: String- , fiInput :: GWidget sub y ()- , fiErrors :: Maybe Html- , fiRequired :: Bool- }--data FormFieldSettings = FormFieldSettings- { ffsLabel :: String- , ffsTooltip :: Html- , ffsId :: Maybe String- , ffsName :: Maybe String- }-instance IsString FormFieldSettings where- fromString s = FormFieldSettings s mempty Nothing Nothing---- | A generic definition of a form field that can be used for generating both--- required and optional fields. See 'requiredFieldHelper and--- 'optionalFieldHelper'.-data FieldProfile sub y a = FieldProfile- { fpParse :: String -> Either String a- , fpRender :: a -> String- -- | ID, name, value, required- , fpWidget :: String -> String -> String -> Bool -> GWidget sub y ()- }--type Form sub y = GForm sub y (GWidget sub y ())-type Formlet sub y a = Maybe a -> Form sub y a-type FormField sub y = GForm sub y [FieldInfo sub y]-type FormletField sub y a = Maybe a -> FormField sub y a-type FormInput sub y = GForm sub y [GWidget sub y ()]---- | Add a validation check to a form.------ Note that if there is a validation error, this message will /not/--- automatically appear on the form; for that, you need to use 'checkField'.-checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b-checkForm f (GForm form) = GForm $ do- (res, xml, enc) <- form- let res' = case res of- FormSuccess a -> f a- FormFailure e -> FormFailure e- FormMissing -> FormMissing- return (res', xml, enc)---- | Add a validation check to a 'FormField'.------ Unlike 'checkForm', the validation error will appear in the generated HTML--- of the form.-checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b-checkField f (GForm form) = GForm $ do- (res, xml, enc) <- form- let (res', merr) =- case res of- FormSuccess a ->- case f a of- Left e -> (FormFailure [e], Just e)- Right x -> (FormSuccess x, Nothing)- FormFailure e -> (FormFailure e, Nothing)- FormMissing -> (FormMissing, Nothing)- let xml' =- case merr of- Nothing -> xml- Just err -> flip map xml $ \fi -> fi- { fiErrors = Just $- case fiErrors fi of- Nothing -> string err- Just x -> x- }- return (res', xml', enc)--askParams :: Monad m => StateT Ints (ReaderT Env m) Env-askParams = lift ask--askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv-askFiles = lift $ lift ask--liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a-liftForm = lift . lift . lift
− Yesod/Form/Fields.hs
@@ -1,409 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-module Yesod.Form.Fields- ( -- * Fields- -- ** Required- stringField- , passwordField- , textareaField- , hiddenField- , intField- , doubleField- , dayField- , timeField- , htmlField- , selectField- , boolField- , emailField- , searchField- , urlField- , fileField- -- ** Optional- , maybeStringField- , maybePasswordField- , maybeTextareaField- , maybeHiddenField- , maybeIntField- , maybeDoubleField- , maybeDayField- , maybeTimeField- , maybeHtmlField- , maybeSelectField- , maybeEmailField- , maybeSearchField- , maybeUrlField- , maybeFileField- -- * Inputs- -- ** Required- , stringInput- , intInput- , boolInput- , dayInput- , emailInput- , urlInput- -- ** Optional- , maybeStringInput- , maybeDayInput- , maybeIntInput- ) where--import Yesod.Form.Core-import Yesod.Form.Profiles-import Yesod.Request (FileInfo)-import Yesod.Widget (GWidget)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ask)-import Data.Time (Day, TimeOfDay)-import Text.Hamlet-import Data.Monoid-import Control.Monad (join)-import Data.Maybe (fromMaybe)--stringField :: (IsForm f, FormType f ~ String)- => FormFieldSettings -> Maybe String -> f-stringField = requiredFieldHelper stringFieldProfile--maybeStringField :: (IsForm f, FormType f ~ Maybe String)- => FormFieldSettings -> Maybe (Maybe String) -> f-maybeStringField = optionalFieldHelper stringFieldProfile--passwordField :: (IsForm f, FormType f ~ String)- => FormFieldSettings -> Maybe String -> f-passwordField = requiredFieldHelper passwordFieldProfile--maybePasswordField :: (IsForm f, FormType f ~ Maybe String)- => FormFieldSettings -> Maybe (Maybe String) -> f-maybePasswordField = optionalFieldHelper passwordFieldProfile--intInput :: Integral i => String -> FormInput sub master i-intInput n =- mapFormXml fieldsToInput $- requiredFieldHelper intFieldProfile (nameSettings n) Nothing--maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i)-maybeIntInput n =- mapFormXml fieldsToInput $- optionalFieldHelper intFieldProfile (nameSettings n) Nothing--intField :: (Integral (FormType f), IsForm f)- => FormFieldSettings -> Maybe (FormType f) -> f-intField = requiredFieldHelper intFieldProfile--maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)- => FormFieldSettings -> Maybe (FormType f) -> f-maybeIntField = optionalFieldHelper intFieldProfile--doubleField :: (IsForm f, FormType f ~ Double)- => FormFieldSettings -> Maybe Double -> f-doubleField = requiredFieldHelper doubleFieldProfile--maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)- => FormFieldSettings -> Maybe (Maybe Double) -> f-maybeDoubleField = optionalFieldHelper doubleFieldProfile--dayField :: (IsForm f, FormType f ~ Day)- => FormFieldSettings -> Maybe Day -> f-dayField = requiredFieldHelper dayFieldProfile--maybeDayField :: (IsForm f, FormType f ~ Maybe Day)- => FormFieldSettings -> Maybe (Maybe Day) -> f-maybeDayField = optionalFieldHelper dayFieldProfile--timeField :: (IsForm f, FormType f ~ TimeOfDay)- => FormFieldSettings -> Maybe TimeOfDay -> f-timeField = requiredFieldHelper timeFieldProfile--maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)- => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f-maybeTimeField = optionalFieldHelper timeFieldProfile--boolField :: (IsForm f, FormType f ~ Bool)- => FormFieldSettings -> Maybe Bool -> f-boolField ffs orig = toForm $ do- env <- askParams- let label = ffsLabel ffs- tooltip = ffsTooltip ffs- name <- maybe newFormIdent return $ ffsName ffs- theId <- maybe newFormIdent return $ ffsId ffs- let (res, val) =- if null env- then (FormMissing, fromMaybe False orig)- else case lookup name env of- Nothing -> (FormSuccess False, False)- Just "" -> (FormSuccess False, False)- Just "false" -> (FormSuccess False, False)- Just _ -> (FormSuccess True, True)- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%input#$theId$!type=checkbox!name=$name$!:val:checked-|]- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- , fiRequired = True- }- return (res, fi, UrlEncoded)--htmlField :: (IsForm f, FormType f ~ Html)- => FormFieldSettings -> Maybe Html -> f-htmlField = requiredFieldHelper htmlFieldProfile--maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)- => FormFieldSettings -> Maybe (Maybe Html) -> f-maybeHtmlField = optionalFieldHelper htmlFieldProfile--selectField :: (Eq x, IsForm f, FormType f ~ x)- => [(x, String)]- -> FormFieldSettings- -> Maybe x- -> f-selectField pairs ffs initial = toForm $ do- env <- askParams- let label = ffsLabel ffs- tooltip = ffsTooltip ffs- theId <- maybe newFormIdent return $ ffsId ffs- name <- maybe newFormIdent return $ ffsName ffs- let pairs' = zip [1 :: Int ..] pairs- let res = case lookup name env of- Nothing -> FormMissing- Just "none" -> FormFailure ["Field is required"]- Just x ->- case reads x of- (x', _):_ ->- case lookup x' pairs' of- Nothing -> FormFailure ["Invalid entry"]- Just (y, _) -> FormSuccess y- [] -> FormFailure ["Invalid entry"]- let isSelected x =- case res of- FormSuccess y -> x == y- _ -> Just x == initial- let input =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%select#$theId$!name=$name$- %option!value=none- $forall pairs' pair- %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$-|]- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = input- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- , fiRequired = True- }- return (res, fi, UrlEncoded)--maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)- => [(x, String)]- -> FormFieldSettings- -> Maybe (FormType f)- -> f-maybeSelectField pairs ffs initial' = toForm $ do- env <- askParams- let initial = join initial'- label = ffsLabel ffs- tooltip = ffsTooltip ffs- theId <- maybe newFormIdent return $ ffsId ffs- name <- maybe newFormIdent return $ ffsName ffs- let pairs' = zip [1 :: Int ..] pairs- let res = case lookup name env of- Nothing -> FormMissing- Just "none" -> FormSuccess Nothing- Just x ->- case reads x of- (x', _):_ ->- case lookup x' pairs' of- Nothing -> FormFailure ["Invalid entry"]- Just (y, _) -> FormSuccess $ Just y- [] -> FormFailure ["Invalid entry"]- let isSelected x =- case res of- FormSuccess y -> Just x == y- _ -> Just x == initial- let input =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%select#$theId$!name=$name$- %option!value=none- $forall pairs' pair- %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$-|]- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = input- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- , fiRequired = False- }- return (res, fi, UrlEncoded)--stringInput :: String -> FormInput sub master String-stringInput n =- mapFormXml fieldsToInput $- requiredFieldHelper stringFieldProfile (nameSettings n) Nothing--maybeStringInput :: String -> FormInput sub master (Maybe String)-maybeStringInput n =- mapFormXml fieldsToInput $- optionalFieldHelper stringFieldProfile (nameSettings n) Nothing--boolInput :: String -> FormInput sub master Bool-boolInput n = GForm $ do- env <- askParams- let res = case lookup n env of- Nothing -> FormSuccess False- Just "" -> FormSuccess False- Just "false" -> FormSuccess False- Just _ -> FormSuccess True- let xml =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- %input#$n$!type=checkbox!name=$n$-|]- return (res, [xml], UrlEncoded)--dayInput :: String -> FormInput sub master Day-dayInput n =- mapFormXml fieldsToInput $- requiredFieldHelper dayFieldProfile (nameSettings n) Nothing--maybeDayInput :: String -> FormInput sub master (Maybe Day)-maybeDayInput n =- mapFormXml fieldsToInput $- optionalFieldHelper dayFieldProfile (nameSettings n) Nothing--nameSettings :: String -> FormFieldSettings-nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)--urlField :: (IsForm f, FormType f ~ String)- => FormFieldSettings -> Maybe String -> f-urlField = requiredFieldHelper urlFieldProfile--maybeUrlField :: (IsForm f, FormType f ~ Maybe String)- => FormFieldSettings -> Maybe (Maybe String) -> f-maybeUrlField = optionalFieldHelper urlFieldProfile--urlInput :: String -> FormInput sub master String-urlInput n =- mapFormXml fieldsToInput $- requiredFieldHelper urlFieldProfile (nameSettings n) Nothing--emailField :: (IsForm f, FormType f ~ String)- => FormFieldSettings -> Maybe String -> f-emailField = requiredFieldHelper emailFieldProfile--maybeEmailField :: (IsForm f, FormType f ~ Maybe String)- => FormFieldSettings -> Maybe (Maybe String) -> f-maybeEmailField = optionalFieldHelper emailFieldProfile--emailInput :: String -> FormInput sub master String-emailInput n =- mapFormXml fieldsToInput $- requiredFieldHelper emailFieldProfile (nameSettings n) Nothing--searchField :: (IsForm f, FormType f ~ String)- => AutoFocus -> FormFieldSettings -> Maybe String -> f-searchField = requiredFieldHelper . searchFieldProfile--maybeSearchField :: (IsForm f, FormType f ~ Maybe String)- => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f-maybeSearchField = optionalFieldHelper . searchFieldProfile--textareaField :: (IsForm f, FormType f ~ Textarea)- => FormFieldSettings -> Maybe Textarea -> f-textareaField = requiredFieldHelper textareaFieldProfile--maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)-maybeTextareaField = optionalFieldHelper textareaFieldProfile--hiddenField :: (IsForm f, FormType f ~ String)- => FormFieldSettings -> Maybe String -> f-hiddenField = requiredFieldHelper hiddenFieldProfile--maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)- => FormFieldSettings -> Maybe (Maybe String) -> f-maybeHiddenField = optionalFieldHelper hiddenFieldProfile--fileField :: (IsForm f, FormType f ~ FileInfo)- => FormFieldSettings -> f-fileField ffs = toForm $ do- env <- lift ask- fenv <- lift $ lift ask- let (FormFieldSettings label tooltip theId' name') = ffs- name <- maybe newFormIdent return name'- theId <- maybe newFormIdent return theId'- let res =- if null env && null fenv- then FormMissing- else case lookup name fenv of- Nothing -> FormFailure ["File is required"]- Just x -> FormSuccess x- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = fileWidget theId name True- , fiErrors = case res of- FormFailure [x] -> Just $ string x- _ -> Nothing- , fiRequired = True- }- let res' = case res of- FormFailure [e] -> FormFailure [label ++ ": " ++ e]- _ -> res- return (res', fi, Multipart)--maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)- => FormFieldSettings -> f-maybeFileField ffs = toForm $ do- fenv <- lift $ lift ask- let (FormFieldSettings label tooltip theId' name') = ffs- name <- maybe newFormIdent return name'- theId <- maybe newFormIdent return theId'- let res = FormSuccess $ lookup name fenv- let fi = FieldInfo- { fiLabel = string label- , fiTooltip = tooltip- , fiIdent = theId- , fiInput = fileWidget theId name False- , fiErrors = Nothing- , fiRequired = True- }- return (res, fi, Multipart)--fileWidget :: String -> String -> Bool -> GWidget s m ()-fileWidget theId name isReq =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%input#$theId$!type=file!name=$name$!:isReq:required-|]
− Yesod/Form/Jquery.hs
@@ -1,235 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}--- | Some fields spiced up with jQuery UI.-module Yesod.Form.Jquery- ( YesodJquery (..)- , jqueryDayField- , maybeJqueryDayField- , jqueryDayTimeField- , jqueryDayTimeFieldProfile- , jqueryAutocompleteField- , maybeJqueryAutocompleteField- , jqueryDayFieldProfile- , googleHostedJqueryUiCss- , JqueryDaySettings (..)- , Default (..)- ) where--import Yesod.Handler-import Yesod.Form.Core-import Yesod.Form.Profiles-import Yesod.Widget-import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,- timeToTimeOfDay)-import Yesod.Hamlet-import Data.Char (isSpace)-import Data.Default--#if GHC7-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#endif---- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme.-googleHostedJqueryUiCss :: String -> String-googleHostedJqueryUiCss theme = concat- [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"- , theme- , "/jquery-ui.css"- ]--class YesodJquery a where- -- | The jQuery 1.4 Javascript file.- urlJqueryJs :: a -> Either (Route a) String- urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"-- -- | The jQuery UI 1.8 Javascript file.- urlJqueryUiJs :: a -> Either (Route a) String- urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"-- -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.- urlJqueryUiCss :: a -> Either (Route a) String- urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"-- -- | jQuery UI time picker add-on.- urlJqueryUiDateTimePicker :: a -> Either (Route a) String- urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"--jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f))- => JqueryDaySettings- -> FormFieldSettings- -> Maybe (FormType f)- -> f-jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile--maybeJqueryDayField- :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f))- => JqueryDaySettings- -> FormFieldSettings- -> Maybe (FormType f)- -> f-maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile--jqueryDayFieldProfile :: YesodJquery y- => JqueryDaySettings -> FieldProfile sub y Day-jqueryDayFieldProfile jds = FieldProfile- { fpParse = maybe- (Left "Invalid day, must be in YYYY-MM-DD format")- Right- . readMay- , fpRender = show- , fpWidget = \theId name val isReq -> do- addHtml [HAMLET|-%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$-|]- addScript' urlJqueryJs- addScript' urlJqueryUiJs- addStylesheet' urlJqueryUiCss- addJulius [JULIUS|-$(function(){$("#%theId%").datepicker({- dateFormat:'yy-mm-dd',- changeMonth:%jsBool.jdsChangeMonth.jds%,- changeYear:%jsBool.jdsChangeYear.jds%,- numberOfMonths:%mos.jdsNumberOfMonths.jds%,- yearRange:"%jdsYearRange.jds%"-})});-|]- }- where- jsBool True = "true"- jsBool False = "false"- mos (Left i) = show i- mos (Right (x, y)) = concat- [ "["- , show x- , ","- , show y- , "]"- ]--ifRight :: Either a b -> (b -> c) -> Either a c-ifRight e f = case e of- Left l -> Left l- Right r -> Right $ f r--showLeadingZero :: (Show a) => a -> String-showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t--jqueryDayTimeField- :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f))- => FormFieldSettings- -> Maybe (FormType f)- -> f-jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile---- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)-jqueryDayTimeUTCTime :: UTCTime -> String-jqueryDayTimeUTCTime (UTCTime day utcTime) =- let timeOfDay = timeToTimeOfDay utcTime- in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay- where- showTimeOfDay (TimeOfDay hour minute _) =- let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")- in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm--jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime-jqueryDayTimeFieldProfile = FieldProfile- { fpParse = parseUTCTime- , fpRender = jqueryDayTimeUTCTime- , fpWidget = \theId name val isReq -> do- addHtml [HAMLET|-%input#$theId$!name=$name$!:isReq:required!value=$val$-|]- addScript' urlJqueryJs- addScript' urlJqueryUiJs- addScript' urlJqueryUiDateTimePicker- addStylesheet' urlJqueryUiCss- addJulius [JULIUS|-$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});-|]- }--parseUTCTime :: String -> Either String UTCTime-parseUTCTime s =- let (dateS, timeS) = break isSpace (dropWhile isSpace s)- dateE = parseDate dateS- in case dateE of- Left l -> Left l- Right date ->- ifRight (parseTime timeS)- (UTCTime date . timeOfDayToTime)--jqueryAutocompleteField- :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f))- => Route (FormMaster f)- -> FormFieldSettings- -> Maybe (FormType f)- -> f-jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile--maybeJqueryAutocompleteField- :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f))- => Route (FormMaster f)- -> FormFieldSettings- -> Maybe (FormType f)- -> f-maybeJqueryAutocompleteField src =- optionalFieldHelper $ jqueryAutocompleteFieldProfile src--jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String-jqueryAutocompleteFieldProfile src = FieldProfile- { fpParse = Right- , fpRender = id- , fpWidget = \theId name val isReq -> do- addHtml [HAMLET|-%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$-|]- addScript' urlJqueryJs- addScript' urlJqueryUiJs- addStylesheet' urlJqueryUiCss- addJulius [JULIUS|-$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})});-|]- }--addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()-addScript' f = do- y <- liftHandler getYesod- addScriptEither $ f y--addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()-addStylesheet' f = do- y <- liftHandler getYesod- addStylesheetEither $ f y--readMay :: Read a => String -> Maybe a-readMay s = case reads s of- (x, _):_ -> Just x- [] -> Nothing---- | Replaces all instances of a value in a list by another value.--- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace-replace :: Eq a => a -> a -> [a] -> [a]-replace x y = map (\z -> if z == x then y else z)--data JqueryDaySettings = JqueryDaySettings- { jdsChangeMonth :: Bool- , jdsChangeYear :: Bool- , jdsYearRange :: String- , jdsNumberOfMonths :: Either Int (Int, Int)- }--instance Default JqueryDaySettings where- def = JqueryDaySettings- { jdsChangeMonth = False- , jdsChangeYear = False- , jdsYearRange = "c-10:c+10"- , jdsNumberOfMonths = Left 1- }
− Yesod/Form/Nic.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}--- | Provide the user with a rich text editor.-module Yesod.Form.Nic- ( YesodNic (..)- , nicHtmlField- , maybeNicHtmlField- ) where--import Yesod.Handler-import Yesod.Form.Core-import Yesod.Hamlet-import Yesod.Widget-import Text.HTML.SanitizeXSS (sanitizeBalance)--import Yesod.Internal (lbsToChars)--class YesodNic a where- -- | NIC Editor Javascript file.- urlNicEdit :: a -> Either (Route a) String- urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"--nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f))- => FormFieldSettings -> Maybe Html -> f-nicHtmlField = requiredFieldHelper nicHtmlFieldProfile--maybeNicHtmlField- :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f))- => FormFieldSettings -> Maybe (FormType f) -> f-maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile--nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html-nicHtmlFieldProfile = FieldProfile- { fpParse = Right . preEscapedString . sanitizeBalance- , fpRender = lbsToChars . renderHtml- , fpWidget = \theId name val _isReq -> do- addHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- %textarea.html#$theId$!name=$name$ $val$-|]- addScript' urlNicEdit- addJulius-#if GHC7- [julius|-#else- [$julius|-#endif-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});-|]- }--addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()-addScript' f = do- y <- liftHandler getYesod- addScriptEither $ f y
− Yesod/Form/Profiles.hs
@@ -1,235 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-module Yesod.Form.Profiles- ( stringFieldProfile- , passwordFieldProfile- , textareaFieldProfile- , hiddenFieldProfile- , intFieldProfile- , dayFieldProfile- , timeFieldProfile- , htmlFieldProfile- , emailFieldProfile- , searchFieldProfile- , AutoFocus- , urlFieldProfile- , doubleFieldProfile- , parseDate- , parseTime- , Textarea (..)- ) where--import Yesod.Form.Core-import Yesod.Widget-import Text.Hamlet-import Text.Cassius-import Data.Time (Day, TimeOfDay(..))-import qualified Text.Email.Validate as Email-import Network.URI (parseURI)-import Database.Persist (PersistField)-import Text.HTML.SanitizeXSS (sanitizeBalance)-import Control.Monad (when)--import qualified Blaze.ByteString.Builder.Html.Utf8 as B-import Blaze.ByteString.Builder (writeByteString)-import Blaze.ByteString.Builder.Internal.Write (fromWriteList)--import Yesod.Internal (lbsToChars)--#if GHC7-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#endif--intFieldProfile :: Integral i => FieldProfile sub y i-intFieldProfile = FieldProfile- { fpParse = maybe (Left "Invalid integer") Right . readMayI- , fpRender = showI- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$-|]- }- where- showI x = show (fromIntegral x :: Integer)- readMayI s = case reads s of- (x, _):_ -> Just $ fromInteger x- [] -> Nothing--doubleFieldProfile :: FieldProfile sub y Double-doubleFieldProfile = FieldProfile- { fpParse = maybe (Left "Invalid number") Right . readMay- , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$-|]- }--dayFieldProfile :: FieldProfile sub y Day-dayFieldProfile = FieldProfile- { fpParse = parseDate- , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$-|]- }--timeFieldProfile :: FieldProfile sub y TimeOfDay-timeFieldProfile = FieldProfile- { fpParse = parseTime- , fpRender = show- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!:isReq:required!value=$val$-|]- }--htmlFieldProfile :: FieldProfile sub y Html-htmlFieldProfile = FieldProfile- { fpParse = Right . preEscapedString . sanitizeBalance- , fpRender = lbsToChars . renderHtml- , fpWidget = \theId name val _isReq -> addHamlet- [HAMLET|-%textarea.html#$theId$!name=$name$ $val$-|]- }---- | A newtype wrapper around a 'String' that converts newlines to HTML--- br-tags.-newtype Textarea = Textarea { unTextarea :: String }- deriving (Show, Read, Eq, PersistField)-instance ToHtml Textarea where- toHtml =- Html . fromWriteList writeHtmlEscapedChar . unTextarea- where- -- Taken from blaze-builder and modified with newline handling.- writeHtmlEscapedChar '\n' = writeByteString "<br>"- writeHtmlEscapedChar c = B.writeHtmlEscapedChar c--textareaFieldProfile :: FieldProfile sub y Textarea-textareaFieldProfile = FieldProfile- { fpParse = Right . Textarea- , fpRender = unTextarea- , fpWidget = \theId name val _isReq -> addHamlet- [HAMLET|-%textarea#$theId$!name=$name$ $val$-|]- }--hiddenFieldProfile :: FieldProfile sub y String-hiddenFieldProfile = FieldProfile- { fpParse = Right- , fpRender = id- , fpWidget = \theId name val _isReq -> addHamlet- [HAMLET|-%input!type=hidden#$theId$!name=$name$!value=$val$-|]- }--stringFieldProfile :: FieldProfile sub y String-stringFieldProfile = FieldProfile- { fpParse = Right- , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$-|]- }--passwordFieldProfile :: FieldProfile s m String-passwordFieldProfile = FieldProfile- { fpParse = Right- , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=password!:isReq:required!value=$val$-|]- }--readMay :: Read a => String -> Maybe a-readMay s = case reads s of- (x, _):_ -> Just x- [] -> Nothing--parseDate :: String -> Either String Day-parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right- . readMay . replace '/' '-'---- | Replaces all instances of a value in a list by another value.--- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace-replace :: Eq a => a -> a -> [a] -> [a]-replace x y = map (\z -> if z == x then y else z)--parseTime :: String -> Either String TimeOfDay-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =- parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =- let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12- in parseTimeHelper (h1', h2', m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =- parseTimeHelper (h1, h2, m1, m2, s1, s2)-parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"--parseTimeHelper :: (Char, Char, Char, Char, Char, Char)- -> Either [Char] TimeOfDay-parseTimeHelper (h1, h2, m1, m2, s1, s2)- | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h- | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m- | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s- | otherwise = Right $ TimeOfDay h m s- where- h = read [h1, h2]- m = read [m1, m2]- s = fromInteger $ read [s1, s2]--emailFieldProfile :: FieldProfile s y String-emailFieldProfile = FieldProfile- { fpParse = \s -> if Email.isValid s- then Right s- else Left "Invalid e-mail address"- , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$-|]- }--type AutoFocus = Bool-searchFieldProfile :: AutoFocus -> FieldProfile s y String-searchFieldProfile autoFocus = FieldProfile- { fpParse = Right- , fpRender = id- , fpWidget = \theId name val isReq -> do- addHtml [HAMLET|-%input#$theId$!name=$name$!type=search!:isReq:required!:autoFocus:autofocus!value=$val$-|]- when autoFocus $ do- addHtml $ [HAMLET| <script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('$theId$').focus();}</script> |]- addCassius [CASSIUS|- #$theId$- -webkit-appearance: textfield- |]- }--urlFieldProfile :: FieldProfile s y String-urlFieldProfile = FieldProfile- { fpParse = \s -> case parseURI s of- Nothing -> Left "Invalid URL"- Just _ -> Right s- , fpRender = id- , fpWidget = \theId name val isReq -> addHamlet- [HAMLET|-%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$-|]- }
− Yesod/Hamlet.hs
@@ -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
− Yesod/Handler.hs
@@ -1,571 +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- -- * 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 (..)-#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.Invert (MonadInvertIO (..))-import Control.Monad (liftM)-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)--type GHInner s m =- ReaderT (HandlerData s m) (- MEitherT HandlerContents (- WriterT (Endo [Header]) (- StateT SessionMap ( -- session- IO- ))))--type SessionMap = Map.Map String String--instance MonadInvertIO (GHandler s m) where- newtype InvertedIO (GHandler s m) a =- InvGHandlerIO- { runInvGHandlerIO :: InvertedIO (GHInner s m) a- }- type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ()))- invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler- revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f--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 (W.Status, [Header], ContentType, Content, SessionMap)- }--data HandlerContents =- HCContent W.Status ChooseRep- | HCError ErrorResponse- | HCSendFile ContentType FilePath- | HCRedirect RedirectType String- | HCCreated String--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- (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession- let hs' = headers hs- return (getStatus e, hs', ct, c, sess)- let sendFile' ct fp =- return (W.status200, headers [], ct, W.ResponseFile fp, finalSession)- case contents of- HCContent status a -> do- (ct, c) <- chooseRep a cts- return (status, headers [], ct, c, finalSession)- HCError e -> handleError e- HCRedirect rt loc -> do- let hs = Header "Location" loc : headers []- return (getRedirectStatus rt, hs, typePlain, emptyContent,- finalSession)- HCSendFile ct fp -> E.catch- (sendFile' ct fp)- (handleError . toErrorHandler)- HCCreated loc -> do- let hs = Header "Location" loc : headers []- return (W.Status 201 (S8.pack "Created"), hs, typePlain,- emptyContent,- finalSession)--safeEh :: ErrorResponse -> YesodApp-safeEh er = YesodApp $ \_ _ _ session -> do- liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er- return (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---- | 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
− Yesod/Helpers/AtomFeed.hs
@@ -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$-|]
− Yesod/Helpers/Crud.hs
@@ -1,208 +0,0 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Yesod.Helpers.Crud- ( Item (..)- , Crud (..)- , CrudRoute (..)- , defaultCrud- ) where--import Yesod.Yesod-import Yesod.Widget-import Yesod.Dispatch-import Yesod.Content-import Yesod.Handler-import Text.Hamlet-import Yesod.Form-import Language.Haskell.TH.Syntax---- | An entity which can be displayed by the Crud subsite.-class Item a where- -- | The title of an entity, to be displayed in the list of all entities.- itemTitle :: a -> String---- | Defines all of the CRUD operations (Create, Read, Update, Delete)--- necessary to implement this subsite. When using the "Yesod.Form" module and--- 'ToForm' typeclass, you can probably just use 'defaultCrud'.-data Crud master item = Crud- { crudSelect :: GHandler (Crud master item) master [(Key item, item)]- , crudReplace :: Key item -> item -> GHandler (Crud master item) master ()- , crudInsert :: item -> GHandler (Crud master item) master (Key item)- , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)- , crudDelete :: Key item -> GHandler (Crud master item) master ()- }--mkYesodSub "Crud master item"- [ ClassP ''Yesod [VarT $ mkName "master"]- , ClassP ''Item [VarT $ mkName "item"]- , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]- , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]- ]-#if GHC7- [parseRoutes|-#else- [$parseRoutes|-#endif-/ CrudListR GET-/add CrudAddR GET POST-/edit/#String CrudEditR GET POST-/delete/#String CrudDeleteR GET POST-|]--getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))- => GHandler (Crud master item) master RepHtml-getCrudListR = do- items <- getYesodSub >>= crudSelect- toMaster <- getRouteToMaster- defaultLayout $ do- setTitle "Items"- addWidget-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%h1 Items-%ul- $forall items item- %li- %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@- $itemTitle.snd.item$-%p- %a!href=@toMaster.CrudAddR@ Add new item-|]--getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),- ToForm item master)- => GHandler (Crud master item) master RepHtml-getCrudAddR = crudHelper- "Add new"- (Nothing :: Maybe (Key item, item))- False--postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),- ToForm item master)- => GHandler (Crud master item) master RepHtml-postCrudAddR = crudHelper- "Add new"- (Nothing :: Maybe (Key item, item))- True--getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),- ToForm item master)- => String -> GHandler (Crud master item) master RepHtml-getCrudEditR s = do- itemId <- maybe notFound return $ itemReadId s- crud <- getYesodSub- item <- crudGet crud itemId >>= maybe notFound return- crudHelper- "Edit item"- (Just (itemId, item))- False--postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),- ToForm item master)- => String -> GHandler (Crud master item) master RepHtml-postCrudEditR s = do- itemId <- maybe notFound return $ itemReadId s- crud <- getYesodSub- item <- crudGet crud itemId >>= maybe notFound return- crudHelper- "Edit item"- (Just (itemId, item))- True--getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))- => String -> GHandler (Crud master item) master RepHtml-getCrudDeleteR s = do- itemId <- maybe notFound return $ itemReadId s- crud <- getYesodSub- item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists- toMaster <- getRouteToMaster- defaultLayout $ do- setTitle "Confirm delete"- addWidget-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%form!method=post!action=@toMaster.CrudDeleteR.s@- %h1 Really delete?- %p Do you really want to delete $itemTitle.item$?- %p- %input!type=submit!value=Yes- \ $- %a!href=@toMaster.CrudListR@ No-|]--postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))- => String -> GHandler (Crud master item) master RepHtml-postCrudDeleteR s = do- itemId <- maybe notFound return $ itemReadId s- crud <- getYesodSub- toMaster <- getRouteToMaster- crudDelete crud itemId- redirect RedirectTemporary $ toMaster CrudListR--itemReadId :: SinglePiece x => String -> Maybe x-itemReadId = either (const Nothing) Just . fromSinglePiece--crudHelper- :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)- => String -> Maybe (Key a, a) -> Bool- -> GHandler (Crud master a) master RepHtml-crudHelper title me isPost = do- crud <- getYesodSub- (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me- toMaster <- getRouteToMaster- case (isPost, errs) of- (True, FormSuccess a) -> do- eid <- case me of- Just (eid, _) -> do- crudReplace crud eid a- return eid- Nothing -> crudInsert crud a- redirect RedirectTemporary $ toMaster $ CrudEditR- $ toSinglePiece eid- _ -> return ()- defaultLayout $ do- setTitle $ string title- addWidget-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-%p- %a!href=@toMaster.CrudListR@ Return to list-%h1 $title$-%form!method=post!enctype=$enctype$- %table- ^form^- %tr- %td!colspan=2- $hidden$- %input!type=submit- $maybe me e- \ $- %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete-|]---- | A default 'Crud' value which relies about persistent and "Yesod.Form".-defaultCrud- :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),- YesodPersist a)- => a -> Crud a i-defaultCrud = const Crud- { crudSelect = runDB $ selectList [] [] 0 0- , crudReplace = \a -> runDB . replace a- , crudInsert = runDB . insert- , crudGet = runDB . get- , crudDelete = runDB . delete- }
− Yesod/Helpers/Sitemap.hs
@@ -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)
− Yesod/Helpers/Static.hs
@@ -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
− Yesod/Internal.hs
@@ -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
− Yesod/Json.hs
@@ -1,140 +0,0 @@--- | Efficient generation of JSON documents.-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Json- ( -- * Monad- Json- , jsonToContent- , jsonToRepJson- -- * Generate Json output- , jsonScalar- , jsonList- , jsonMap- , jsonRaw-#if TEST- , testSuite-#endif- )- where--import qualified Data.ByteString.Char8 as S-import Data.Char (isControl)-import Yesod.Handler (GHandler)-import Numeric (showHex)-import Data.Monoid (Monoid (..))-import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Char.Utf8 (writeChar)-import Blaze.ByteString.Builder.Internal.Write (fromWriteList)--#if TEST-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)-import Data.ByteString.Lazy.Char8 (unpack)-import Yesod.Content hiding (testSuite)-#else-import Yesod.Content-#endif---- | A monad for generating Json output. It wraps the Builder monoid from the--- blaze-builder package.------ This is an opaque type to avoid any possible insertion of non-JSON content.--- Due to the limited nature of the JSON format, you can create any valid JSON--- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'.-newtype Json = Json { unJson :: Builder }- deriving Monoid---- | Extract the final result from the given 'Json' value.------ See also: applyLayoutJson in "Yesod.Yesod".-jsonToContent :: Json -> GHandler sub master Content-jsonToContent = return . toContent . toLazyByteString . unJson---- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'.-jsonToRepJson :: Json -> GHandler sub master RepJson-jsonToRepJson = fmap RepJson . jsonToContent---- | Outputs a single scalar. This function essentially:------ * Performs JSON encoding.------ * Wraps the resulting string in quotes.-jsonScalar :: String -> Json-jsonScalar s = Json $ mconcat- [ fromByteString "\""- , fromWriteList writeJsonChar s- , fromByteString "\""- ]- where- writeJsonChar '\b' = writeByteString "\\b"- writeJsonChar '\f' = writeByteString "\\f"- writeJsonChar '\n' = writeByteString "\\n"- writeJsonChar '\r' = writeByteString "\\r"- writeJsonChar '\t' = writeByteString "\\t"- writeJsonChar '"' = writeByteString "\\\""- writeJsonChar '\\' = writeByteString "\\\\"- writeJsonChar c- | not $ isControl c = writeChar c- | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs- | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs- | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs- where hexxs = showHex (fromEnum c) ""- writeJsonChar c = writeChar c- writeString = writeByteString . S.pack---- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"].-jsonList :: [Json] -> Json-jsonList [] = Json $ fromByteString "[]"-jsonList (x:xs) = mconcat- [ Json $ fromByteString "["- , x- , mconcat $ map go xs- , Json $ fromByteString "]"- ]- where- go = mappend (Json $ fromByteString ",")---- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}.-jsonMap :: [(String, Json)] -> Json-jsonMap [] = Json $ fromByteString "{}"-jsonMap (x:xs) = mconcat- [ Json $ fromByteString "{"- , go x- , mconcat $ map go' xs- , Json $ fromByteString "}"- ]- where- go' y = mappend (Json $ fromByteString ",") $ go y- go (k, v) = mconcat- [ jsonScalar k- , Json $ fromByteString ":"- , v- ]---- | Outputs raw JSON data without performing any escaping. Use with caution:--- this is the only function in this module that allows you to create broken--- JSON documents.-jsonRaw :: S.ByteString -> Json-jsonRaw = Json . fromByteString--#if TEST--testSuite :: Test-testSuite = testGroup "Yesod.Json"- [ testCase "simple output" caseSimpleOutput- ]--caseSimpleOutput :: Assertion-caseSimpleOutput = do- let j = do- jsonMap- [ ("foo" , jsonList- [ jsonScalar "bar"- , jsonScalar "baz"- ])- ]- "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j)--#endif
− Yesod/Request.hs
@@ -1,161 +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.- , 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
− Yesod/Widget.hs
@@ -1,200 +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, HandlerData, 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.Invert (MonadInvertIO (..))-import Control.Monad (liftM)-import qualified Data.Map as Map---- | 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)-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 MonadInvertIO (GWidget s m) where- newtype InvertedIO (GWidget s m) a =- InvGWidgetIO- { runInvGWidgetIO :: InvertedIO (GWInner s m) a- }- type InvertedArg (GWidget s m) =- (Int, (HandlerData s m, (Map.Map String String, ())))- invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget- revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f--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)
− Yesod/Yesod.hs
@@ -1,542 +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 (..)- -- ** Persistence- , YesodPersist (..)- , module Database.Persist- , get404- -- ** Breadcrumbs- , YesodBreadcrumbs (..)- , breadcrumbs- -- * Utitlities- , maybeAuthorized- , widgetToPageContent- , defaultLayoutJson- , redirectToPost- -- * Defaults- , defaultErrorHandler- -- * Data types- , AuthResult (..)-#if TEST- , testSuite-#endif- ) where--#if TEST-import Yesod.Content hiding (testSuite)-import Yesod.Json hiding (testSuite)-import Yesod.Handler hiding (testSuite)-import qualified Data.ByteString.UTF8 as BSU-#else-import Yesod.Content-import Yesod.Json-import Yesod.Handler-#endif--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 Database.Persist-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Failure (Failure)-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--#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-- -- | 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 ()- -> Json- -> GHandler sub master RepHtmlJson-defaultLayoutJson w json = do- RepHtml html' <- defaultLayout w- json' <- jsonToContent json- return $ RepHtmlJson html' json'--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-|]--class YesodPersist y where- type YesodDB y :: (* -> *) -> * -> *- runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a----- Get the given entity by ID, or return a 404 not found if it doesn't exist.-get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m),- Failure ErrorResponse m, MonadTrans t)- => Key val -> t m val-get404 key = do- mres <- get key- case mres of- Nothing -> lift notFound- Just res -> return res---- | 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
− runtests.hs
@@ -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- ]
scaffold.hs view
@@ -18,6 +18,15 @@ qq = "$" #endif +prompt :: (String -> Bool) -> IO String+prompt f = do+ s <- getLine+ if f s+ then return s+ else do+ putStrLn "That was not a valid entry, please try again: "+ prompt f+ main :: IO () main = do putStr $(codegen "welcome")@@ -26,7 +35,14 @@ putStr $(codegen "project-name") hFlush stdout- project <- getLine+ let validPN c+ | 'A' <= c && c <= 'Z' = True+ | 'a' <= c && c <= 'z' = True+ | '0' <= c && c <= '9' = True+ validPN '-' = True+ validPN '_' = True+ validPN _ = False+ project <- prompt $ all validPN putStr $(codegen "dir-name") hFlush stdout@@ -35,11 +51,12 @@ putStr $(codegen "site-arg") hFlush stdout- sitearg <- getLine+ let isUpperAZ c = 'A' <= c && c <= 'Z'+ sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) putStr $(codegen "database") hFlush stdout- backendS <- getLine+ backendS <- prompt $ flip elem ["s", "p"] let pconn1 = $(codegen "pconn1") let pconn2 = $(codegen "pconn2") let (lower, upper, connstr1, connstr2) =@@ -63,8 +80,8 @@ mkDir "cassius" mkDir "julius" - writeFile' "simple-server.hs" $(codegen "simple-server_hs")- writeFile' "fastcgi.hs" $(codegen "fastcgi_hs")+ writeFile' "test.hs" $(codegen "test_hs")+ writeFile' "production.hs" $(codegen "production_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE")
scaffold/Controller_hs.cg view
@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~@@ -9,6 +11,7 @@ import Yesod.Helpers.Static import Yesod.Helpers.Auth import Database.Persist.GenericSql+import Data.ByteString (ByteString) -- Import all relevant handler modules here. import Handler.Root@@ -24,7 +27,7 @@ getFaviconR = sendFile "image/x-icon" "favicon.ico" getRobotsR :: Handler RepPlain-getRobotsR = return $ RepPlain $ toContent "User-agent: *"+getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- This function allocates resources (such as a database connection pool), -- performs initialization and creates a WAI application. This is also the@@ -36,5 +39,5 @@ let h = ~sitearg~ s p toWaiApp h >>= f where- s = fileLookupDir Settings.staticdir typeByExt+ s = static Settings.staticdir
scaffold/Model_hs.cg view
@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell #-} module Model where import Yesod
scaffold/Root_hs.cg view
@@ -14,7 +14,7 @@ getRootR = do mu <- maybeAuth defaultLayout $ do- h2id <- newIdent+ h2id <- lift newIdent setTitle "~project~ homepage" addWidget $(widgetFile "homepage")
scaffold/Settings_hs.cg view
@@ -24,7 +24,7 @@ import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~-import Yesod (MonadInvertIO, addWidget, addCassius, addJulius)+import Yesod (MonadPeelIO, addWidget, addCassius, addJulius) import Data.Monoid (mempty) import System.Directory (doesFileExist) @@ -139,9 +139,9 @@ -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself.-withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a+withConnectionPool :: MonadPeelIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a+runConnectionPool :: MonadPeelIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool
scaffold/cabal.cg view
@@ -16,43 +16,41 @@ Description: Build the production executable. Default: False -executable simple-server+executable ~project~-test if flag(production) Buildable: False- main-is: simple-server.hs+ main-is: test.hs build-depends: base >= 4 && < 5- , yesod >= 0.6 && < 0.7- , yesod-auth >= 0.2 && < 0.3- , mime-mail >= 0.0 && < 0.1+ , yesod >= 0.7 && < 0.8+ , yesod-auth+ , yesod-static+ , mime-mail , wai-extra , directory , bytestring , text- , persistent >= 0.3.1.1+ , persistent , persistent-~lower~ , template-haskell , hamlet , web-routes- , hjsmin >= 0.0.4 && < 0.1- ghc-options: -Wall- extensions: TemplateHaskell, QuasiQuotes, TypeFamilies--executable devel-server- if flag(production)- Buildable: False- else- build-depends: wai-handler-devel >= 0.1.0 && < 0.2- main-is: devel-server.hs- ghc-options: -Wall -O2+ , hjsmin+ , transformers+ , warp+ ghc-options: -Wall -threaded -executable fastcgi+executable ~project~-production if flag(production) Buildable: True- build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 else Buildable: False cpp-options: -DPRODUCTION- main-is: fastcgi.hs+ main-is: production.hs ghc-options: -Wall -threaded- extensions: TemplateHaskell, QuasiQuotes, TypeFamilies++executable ~project~-devel+ if flag(production)+ Buildable: False+ main-is: devel-server.hs+ ghc-options: -Wall -O2 -threaded
scaffold/default-layout_hamlet.cg view
@@ -1,10 +1,10 @@ !!!-%html- %head- %title $pageTitle.pc$- ^pageHead.pc^- %body- $maybe mmsg msg- #message $msg$- ^pageBody.pc^+<html+ <head+ <title>#{pageTitle pc}+ ^{pageHead pc}+ <body+ $maybe msg <- mmsg+ <div #message>#{msg}+ ^{pageBody pc}
scaffold/devel-server_hs.cg view
@@ -1,20 +1,5 @@-import Network.Wai.Handler.DevelServer (run)-import Control.Concurrent (forkIO)+import Yesod (develServer) main :: IO ()-main = do- mapM_ putStrLn- [ "Starting your server process. Code changes will be automatically"- , "loaded as you save your files. Type \"quit\" to exit."- , "You can view your app at http://localhost:3000/"- , ""- ]- _ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"]- go- where- go = do- x <- getLine- case x of- 'q':_ -> putStrLn "Quitting, goodbye!"- _ -> go+main = develServer 3000 "Controller" "with~sitearg~"
− scaffold/fastcgi_hs.cg
@@ -1,6 +0,0 @@-import Controller-import Network.Wai.Handler.FastCGI (run)--main :: IO ()-main = with~sitearg~ run-
scaffold/favicon_ico.cg view
binary file changed (1150 → 1150 bytes)
scaffold/homepage_cassius.cg view
@@ -1,5 +1,5 @@ h1 text-align: center-h2#$h2id$+h2##{h2id} color: #990
scaffold/homepage_hamlet.cg view
@@ -1,13 +1,13 @@-%h1 Hello-%h2#$h2id$ You do not have Javascript enabled.-$maybe mu u- %p- You are logged in as $userIdent.snd.u$. $- %a!href=@AuthR.LogoutR@ Logout- \.+<h1>Hello+<h2 ##{h2id}>You do not have Javascript enabled.+$maybe u <- mu+ <p+ You are logged in as #{userIdent $ snd u}. #+ <a href=@{AuthR LogoutR}>Logout+ . $nothing- %p- You are not logged in. $- %a!href=@AuthR.LoginR@ Login now- \.+ <p+ You are not logged in. #+ <a href=@{AuthR LoginR}>Login now+ .
scaffold/homepage_julius.cg view
@@ -1,4 +1,4 @@ window.onload = function(){- document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";+ document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>"; }
+ scaffold/production_hs.cg view
@@ -0,0 +1,6 @@+import Controller (with~sitearg~)+import Network.Wai.Handler.Warp (run)++main :: IO ()+main = with~sitearg~ $ run 3000+
− scaffold/simple-server_hs.cg
@@ -1,6 +0,0 @@-import Controller-import Network.Wai.Handler.SimpleServer (run)--main :: IO ()-main = putStrLn "Loaded" >> with~sitearg~ (run 3000)-
scaffold/sitearg_hs.cg view
@@ -22,7 +22,6 @@ import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L-import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model@@ -94,11 +93,7 @@ -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) =- Just $ uncurry (joinPath a Settings.staticroot) $ format s- where- format = formatPathSegments ss- ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))- ss = getSubSite+ Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required.@@ -126,7 +121,8 @@ -- How to run database actions. instance YesodPersist ~sitearg~ where type YesodDB ~sitearg~ = SqlPersist- runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db+ runDB db = liftIOHandler+ $ fmap connPool getYesod >>= Settings.runConnectionPool db instance YesodAuth ~sitearg~ where type AuthId ~sitearg~ = UserId@@ -179,17 +175,19 @@ , "" , "Thank you" ]+ , partHeaders = [] } htmlPart = Part { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing , partContent = renderHtml [~qq~hamlet|-%p Please confirm your email address by clicking on the link below.-%p- %a!href=$verurl$ $verurl$-%p Thank you+<p>Please confirm your email address by clicking on the link below.+<p>+ <a href=#{verurl} #{verurl}+<p>Thank you |]+ , partHeaders = [] } getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key]
+ scaffold/test_hs.cg view
@@ -0,0 +1,11 @@+import Controller (with~sitearg~)+import System.IO (hPutStrLn, stderr)+import Network.Wai.Middleware.Debug (debug)+import Network.Wai.Handler.Warp (run)++main :: IO ()+main = do+ let port = 3000+ hPutStrLn stderr $ "Application launched, listening on port " ++ show port+ with~sitearg~ $ run port . debug+
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.6.7+version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,97 +16,51 @@ homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg -flag test- description: Build the executable to run unit tests- default: False- flag ghc7 library if flag(ghc7)- build-depends: base >= 4.3 && < 5+ 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.2.0 && < 0.3- , wai-extra >= 0.2.4 && < 0.3- , bytestring >= 0.9.1.4 && < 0.10- , directory >= 1 && < 1.2- , text >= 0.5 && < 0.12- , template-haskell >= 2.4 && < 2.6- , web-routes-quasi >= 0.6.2 && < 0.7- , hamlet >= 0.5.1 && < 0.7- , blaze-builder >= 0.2.1 && < 0.3+ build-depends: base >= 4 && < 4.3+ , wai-handler-devel >= 0.2 && < 0.3+ build-depends: yesod-core >= 0.7 && < 0.8+ , yesod-auth >= 0.3 && < 0.4+ , yesod-json >= 0.0 && < 0.1+ , yesod-persistent >= 0.0 && < 0.1+ , yesod-static >= 0.0 && < 0.1+ , yesod-form >= 0.0 && < 0.1+ , monad-peel >= 0.1 && < 0.2 , 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- , persistent >= 0.3.0 && < 0.4- , neither >= 0.1.0 && < 0.2- , 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+ , wai >= 0.3 && < 0.4+ , wai-extra >= 0.3 && < 0.4+ , hamlet >= 0.7 && < 0.8+ , warp >= 0.3 && < 0.4+ , mime-mail >= 0.1 && < 0.2+ , hjsmin >= 0.0.12 && < 0.1+ , attoparsec-text >= 0.8 && < 0.9 exposed-modules: Yesod- Yesod.Content- Yesod.Dispatch- Yesod.Form- Yesod.Form.Core- Yesod.Form.Jquery- Yesod.Form.Nic- Yesod.Hamlet- Yesod.Handler- Yesod.Json- Yesod.Request- Yesod.Widget- Yesod.Yesod- Yesod.Helpers.AtomFeed- Yesod.Helpers.Crud- Yesod.Helpers.Sitemap- Yesod.Helpers.Static- other-modules: Yesod.Form.Class- Yesod.Internal- Yesod.Form.Fields- Yesod.Form.Profiles ghc-options: -Wall executable yesod if flag(ghc7)- build-depends: base >= 4.3 && < 5+ build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else- build-depends: base >= 4 && < 4.3- build-depends: parsec >= 2.1 && < 4+ build-depends: base >= 4 && < 4.3+ 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