diff -Nru haskell-yesod-0.6.7/Build.hs haskell-yesod-0.9.3.4/Build.hs --- haskell-yesod-0.6.7/Build.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/Build.hs 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +module Build + ( getDeps + , touchDeps + , touch + , recompDeps + , findHaskellFiles + ) where + +-- FIXME there's a bug when getFileStatus applies to a file +-- temporary deleted (e.g., Vim saving a file) + +import Control.Applicative ((<|>), many) +import Control.Exception (SomeException, try) +import Control.Monad (when, filterM, forM, forM_) + +import qualified Data.Attoparsec.Text.Lazy as A +import Data.Char (isSpace) +import Data.Monoid (mappend) +import Data.List (isSuffixOf) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text.Lazy.IO as TIO + +import qualified System.Posix.Types +import System.Directory +import System.FilePath (replaceExtension, ()) +import System.PosixCompat.Files (getFileStatus, setFileTimes, + accessTime, modificationTime) + +touch :: IO () +touch = touchDeps id updateFileTime =<< getDeps + +recompDeps :: IO () +recompDeps = touchDeps hiFile removeHi =<< getDeps + +type Deps = Map.Map FilePath (Set.Set FilePath) + +getDeps :: IO Deps +getDeps = do + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + return $ fixDeps $ zip hss deps' + +touchDeps :: (FilePath -> FilePath) -> + (FilePath -> FilePath -> IO ()) -> + Deps -> IO () +touchDeps f action deps = (mapM_ go . Map.toList) deps + where + go (x, ys) = + forM_ (Set.toList ys) $ \y -> do + n <- x `isNewerThan` f y + when n $ do + putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) + action x y + +-- | remove the .hi files for a .hs file, thereby forcing a recompile +removeHi :: FilePath -> FilePath -> IO () +removeHi _ hs = mapM_ removeFile' hiFiles + where + removeFile' file = try' (removeFile file) >> return () + hiFiles = map (\e -> "dist/build" replaceExtension hs e) + ["hi", "p_hi"] + +-- | change file mtime of .hs file to that of the dependency +updateFileTime :: FilePath -> FilePath -> IO () +updateFileTime x hs = do + (_ , modx) <- getFileStatus' x + (access, _ ) <- getFileStatus' hs + _ <- try' (setFileTimes hs access modx) + return () + +hiFile :: FilePath -> FilePath +hiFile hs = "dist/build" replaceExtension hs "hi" + +try' :: IO x -> IO (Either SomeException x) +try' = try + +isNewerThan :: FilePath -> FilePath -> IO Bool +isNewerThan f1 f2 = do + (_, mod1) <- getFileStatus' f1 + (_, mod2) <- getFileStatus' f2 + return (mod1 > mod2) + +getFileStatus' :: FilePath -> + IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) +getFileStatus' fp = do + efs <- try' $ getFileStatus fp + case efs of + Left _ -> return (0, 0) + Right fs -> return (accessTime fs, modificationTime fs) + +fixDeps :: [(FilePath, [FilePath])] -> Deps +fixDeps = + Map.unionsWith mappend . map go + where + go :: (FilePath, [FilePath]) -> Deps + go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys + +findHaskellFiles :: FilePath -> IO [FilePath] +findHaskellFiles path = do + contents <- getDirectoryContents path + fmap concat $ mapM go contents + where + go ('.':_) = return [] + go ('c':"abal-dev") = return [] + go ('d':"ist") = return [] + go x = do + let y = path x + d <- doesDirectoryExist y + if d + then findHaskellFiles y + else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x + then return [y] + else return [] + +data TempType = Hamlet | Verbatim | Messages FilePath | StaticFiles FilePath + deriving Show + +determineHamletDeps :: FilePath -> IO [FilePath] +determineHamletDeps x = do + y <- TIO.readFile x -- FIXME catch IO exceptions + let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y + case z of + A.Fail{} -> return [] + A.Done _ r -> mapM go r >>= filterM doesFileExist . concat + where + go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"] + go (Just (Verbatim, f)) = return [f] + go (Just (Messages f, _)) = return [f] + go (Just (StaticFiles fp, _)) = getFolderContents fp + go Nothing = return [] + parser = do + ty <- (A.string "$(hamletFile " >> return Hamlet) + <|> (A.string "$(ihamletFile " >> return Hamlet) + <|> (A.string "$(whamletFile " >> return Hamlet) + <|> (A.string "$(html " >> return Hamlet) + <|> (A.string "$(widgetFile " >> return Hamlet) + <|> (A.string "$(Settings.hamletFile " >> return Hamlet) + <|> (A.string "$(Settings.widgetFile " >> return Hamlet) + <|> (A.string "$(persistFile " >> return Verbatim) + <|> (A.string "$(parseRoutesFile " >> return Verbatim) + <|> (do + _ <- A.string "\nmkMessage \"" + A.skipWhile (/= '"') + _ <- A.string "\" \"" + x' <- A.many1 $ A.satisfy (/= '"') + _ <- A.string "\" \"" + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.string "\"" + return $ Messages $ concat [x', "/", y, ".msg"]) + <|> (do + _ <- A.string "\nstaticFiles \"" + x' <- A.many1 $ A.satisfy (/= '"') + return $ StaticFiles x') + case ty of + Messages{} -> return $ Just (ty, "") + StaticFiles{} -> return $ Just (ty, "") + _ -> do + A.skipWhile isSpace + _ <- A.char '"' + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.char '"' + A.skipWhile isSpace + _ <- A.char ')' + return $ Just (ty, y) + +getFolderContents :: FilePath -> IO [FilePath] +getFolderContents fp = do + cs <- getDirectoryContents fp + let notHidden ('.':_) = False + notHidden ('t':"mp") = False + notHidden _ = True + fmap concat $ forM (filter notHidden cs) $ \c -> do + let f = fp ++ '/' : c + isFile <- doesFileExist f + if isFile then return [f] else getFolderContents f diff -Nru haskell-yesod-0.6.7/CodeGen.hs haskell-yesod-0.9.3.4/CodeGen.hs --- haskell-yesod-0.6.7/CodeGen.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/CodeGen.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | A code generation template haskell. Everything is taken as literal text, --- with ~var~ variable interpolation. -module CodeGen (codegen) where - -import Language.Haskell.TH.Syntax -import Text.ParserCombinators.Parsec -import qualified Data.ByteString.Lazy as L -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -data Token = VarToken String | LitToken String | EmptyToken - -codegen :: FilePath -> Q Exp -codegen fp = do - s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg" - let s = init $ LT.unpack $ LT.decodeUtf8 s' - case parse (many parseToken) s s of - Left e -> error $ show e - Right tokens' -> do - let tokens'' = map toExp tokens' - concat' <- [|concat|] - return $ concat' `AppE` ListE tokens'' - -toExp :: Token -> Exp -toExp (LitToken s) = LitE $ StringL s -toExp (VarToken s) = VarE $ mkName s -toExp EmptyToken = LitE $ StringL "" - -parseToken :: Parser Token -parseToken = - parseVar <|> parseLit - where - parseVar = do - _ <- char '~' - s <- many alphaNum - _ <- char '~' - return $ if null s then EmptyToken else VarToken s - parseLit = do - s <- many1 $ noneOf "~" - return $ LitToken s diff -Nru haskell-yesod-0.6.7/debian/changelog haskell-yesod-0.9.3.4/debian/changelog --- haskell-yesod-0.6.7/debian/changelog 2011-11-12 10:58:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/debian/changelog 2011-12-09 04:01:32.000000000 +0000 @@ -1,14 +1,35 @@ -haskell-yesod (0.6.7-1build2) precise; urgency=low +haskell-yesod (0.9.3.4-1) unstable; urgency=low - * Rebuild for new GHC ABIs. + * New upstream version. - -- Colin Watson Sat, 12 Nov 2011 10:57:58 +0000 + -- Clint Adams Thu, 08 Dec 2011 20:23:43 -0500 -haskell-yesod (0.6.7-1build1) oneiric; urgency=low +haskell-yesod (0.9.3-1) unstable; urgency=low - * No change rebuild against new GHC ABIs + * New upstream version. + - Drop threaded-flag.diff (merged upstream). - -- Iain Lane Fri, 17 Jun 2011 13:45:08 +0100 + -- Clint Adams Sat, 08 Oct 2011 11:29:20 -0400 + +haskell-yesod (0.9.2.2-3) unstable; urgency=low + + * Only build threaded where threaded runtime is available. + + -- Clint Adams Thu, 29 Sep 2011 22:50:28 -0400 + +haskell-yesod (0.9.2.2-2) unstable; urgency=low + + * Move under the DHG. + * Add libraries used in building a Yesod project to Recommends + and Suggests of yesod binary package. + + -- Clint Adams Sat, 24 Sep 2011 12:13:19 -0400 + +haskell-yesod (0.9.2.2-1) unstable; urgency=low + + * New upstream version. + + -- Clint Adams Sun, 18 Sep 2011 18:10:36 -0400 haskell-yesod (0.6.7-1) unstable; urgency=low diff -Nru haskell-yesod-0.6.7/debian/control haskell-yesod-0.9.3.4/debian/control --- haskell-yesod-0.6.7/debian/control 2011-06-07 03:21:29.000000000 +0000 +++ haskell-yesod-0.9.3.4/debian/control 2011-12-09 01:28:12.000000000 +0000 @@ -1,86 +1,135 @@ Source: haskell-yesod Section: haskell Priority: extra -Maintainer: Clint Adams +Maintainer: Debian Haskell Group +Uploaders: Clint Adams Build-Depends: debhelper (>= 7) , cdbs , haskell-devscripts (>= 0.8) , ghc , ghc-prof - , libghc-base64-bytestring-dev - , libghc-base64-bytestring-prof - , libghc-blaze-builder-dev + , libghc-attoparsec-dev (>> 0.10) + , libghc-attoparsec-prof + , libghc-blaze-builder-dev (>> 0.2.1.4) + , libghc-blaze-builder-dev (<< 0.4) , libghc-blaze-builder-prof - , libghc-cereal-dev - , libghc-cereal-prof - , libghc-clientsession-dev - , libghc-clientsession-prof - , libghc-data-default-dev - , libghc-data-default-prof - , libghc-email-validate-dev - , libghc-email-validate-prof - , libghc-failure-dev - , libghc-failure-prof - , libghc-hamlet-dev + , libghc-blaze-html-dev (>> 0.4.1.3) + , libghc-blaze-html-dev (<< 0.5) + , libghc-blaze-html-prof + , libghc-hamlet-dev (>> 0.10) + , libghc-hamlet-dev (<< 0.11) , libghc-hamlet-prof - , libghc-neither-dev - , libghc-neither-prof - , libghc-network-dev - , libghc-network-prof + , libghc-http-types-dev (>> 0.6.1) + , libghc-http-types-dev (<< 0.7) + , libghc-http-types-prof + , libghc-monad-control-dev (>> 0.2) + , libghc-monad-control-dev (<< 0.4) + , libghc-monad-control-prof , libghc-parsec3-dev , libghc-parsec3-prof - , libghc-persistent-dev - , libghc-persistent-prof - , libghc-puremd5-dev - , libghc-puremd5-prof - , libghc-text-dev + , libghc-shakespeare-css-dev (>> 0.10) + , libghc-shakespeare-css-dev (<< 0.11) + , libghc-shakespeare-css-prof + , libghc-shakespeare-js-dev (>> 0.10) + , libghc-shakespeare-js-dev (<< 0.11) + , libghc-shakespeare-js-prof + , libghc-shakespeare-text-dev (>> 0.10) + , libghc-shakespeare-text-dev (<< 0.11) + , libghc-shakespeare-text-prof + , libghc-text-dev (>> 0.11) + , libghc-text-dev (<< 0.12) , libghc-text-prof - , libghc-transformers-dev + , libghc-transformers-dev (>> 0.2.2) + , libghc-transformers-dev (<< 0.3) , libghc-transformers-prof - , libghc-wai-dev + , libghc-unix-compat-dev (>> 0.2) + , libghc-unix-compat-dev (<< 0.4) + , libghc-unix-compat-prof + , libghc-wai-dev (>> 0.4) + , libghc-wai-dev (<< 0.5) , libghc-wai-prof - , libghc-wai-extra-dev + , libghc-wai-extra-dev (>> 0.4.1) + , libghc-wai-extra-dev (<< 0.5) , libghc-wai-extra-prof - , libghc-web-routes-dev - , libghc-web-routes-prof - , libghc-web-routes-quasi-dev - , libghc-web-routes-quasi-prof - , libghc-xss-sanitize-dev - , libghc-xss-sanitize-prof + , libghc-warp-dev (>> 0.4) + , libghc-warp-dev (<< 0.5) + , libghc-warp-prof + , libghc-yesod-auth-dev (>> 0.7) + , libghc-yesod-auth-dev (<< 0.8) + , libghc-yesod-auth-prof + , libghc-yesod-core-dev (>> 0.9.3.4) + , libghc-yesod-core-dev (<< 0.10) + , libghc-yesod-core-prof + , libghc-yesod-form-dev (>> 0.3) + , libghc-yesod-form-dev (<< 0.4) + , libghc-yesod-form-prof + , libghc-yesod-json-dev (>> 0.2.2) + , libghc-yesod-json-dev (<< 0.3) + , libghc-yesod-json-prof + , libghc-yesod-persistent-dev (>> 0.2) + , libghc-yesod-persistent-dev (<< 0.3) + , libghc-yesod-persistent-prof Build-Depends-Indep: ghc-doc - , libghc-base64-bytestring-doc + , libghc-attoparsec-doc , libghc-blaze-builder-doc - , libghc-cereal-doc - , libghc-clientsession-doc - , libghc-data-default-doc - , libghc-email-validate-doc - , libghc-failure-doc + , libghc-blaze-html-doc , libghc-hamlet-doc - , libghc-neither-doc - , libghc-network-doc - , libghc-parsec-doc - , libghc-persistent-doc - , libghc-puremd5-doc + , libghc-http-types-doc + , libghc-monad-control-doc + , libghc-parsec3-doc + , libghc-shakespeare-css-doc + , libghc-shakespeare-js-doc + , libghc-shakespeare-text-doc , libghc-text-doc , libghc-transformers-doc + , libghc-unix-compat-doc , libghc-wai-doc , libghc-wai-extra-doc - , libghc-web-routes-doc - , libghc-web-routes-quasi-doc - , libghc-xss-sanitize-doc + , libghc-warp-doc + , libghc-yesod-auth-doc + , libghc-yesod-core-doc + , libghc-yesod-form-doc + , libghc-yesod-json-doc + , libghc-yesod-persistent-doc Standards-Version: 3.9.2 Homepage: http://hackage.haskell.org/package/yesod -Vcs-Git: git://git.debian.org/collab-maint/haskell-yesod.git -Vcs-Browser: http://anonscm.debian.org/gitweb/?p=collab-maint/haskell-yesod.git;a=summary +Vcs-Browser: http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-yesod +Vcs-Darcs: http://darcs.debian.org/pkg-haskell/haskell-yesod Package: yesod Architecture: any -Depends: ${haskell:Depends} - , ${shlibs:Depends} +Depends: ${shlibs:Depends} , ${misc:Depends} -Recommends: ${haskell:Recommends} -Suggests: ${haskell:Suggests} -Provides: ${haskell:Provides} +Recommends: ghc + , libghc-yesod-dev + , libghc-yesod-core-dev + , libghc-yesod-auth-dev + , libghc-yesod-static-dev + , libghc-blaze-html-dev + , libghc-yesod-form-dev + , libghc-mime-mail-dev + , libghc-clientsession-dev + , libghc-wai-extra-dev + , libghc-text-dev + , libghc-persistent-dev + , libghc-persistent-template-dev + , ghc-ghci + , libghc-hamlet-dev + , libghc-shakespeare-css-dev + , libghc-shakespeare-js-dev + , libghc-shakespeare-text-dev + , libghc-hjsmin-dev + , libghc-transformers-dev + , libghc-data-object-dev + , libghc-data-object-yaml-dev + , libghc-warp-dev + , libghc-blaze-builder-dev + , libghc-cmdargs-dev +Suggests: libghc-persistent-sqlite-dev + , libghc-persistent-postgresql-dev + , libghc-persistent-mongodb-dev + , libghc-mongodb-dev + , libghc-bson-dev Description: framework for type-safe, RESTful web applications This package provides a library for the Haskell programming language. See http://www.haskell.org/ for more information on Haskell. diff -Nru haskell-yesod-0.6.7/debian/rules haskell-yesod-0.9.3.4/debian/rules --- haskell-yesod-0.6.7/debian/rules 2011-06-06 22:55:09.000000000 +0000 +++ haskell-yesod-0.9.3.4/debian/rules 2011-12-09 01:23:21.000000000 +0000 @@ -3,5 +3,8 @@ include /usr/share/cdbs/1/rules/debhelper.mk include /usr/share/cdbs/1/class/hlibrary.mk +# If no threaded RTS is found, disable it +DEB_SETUP_GHC_CONFIGURE_ARGS := $(shell test -e /usr/lib/ghc-$(GHC_VERSION)/libHSrts_thr.a || echo --flags=-threaded) + install/yesod:: debian/tmp-inst-ghc cp -av debian/tmp-inst-ghc/usr/bin/* debian/yesod/usr/bin diff -Nru haskell-yesod-0.6.7/Devel.hs haskell-yesod-0.9.3.4/Devel.hs --- haskell-yesod-0.6.7/Devel.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/Devel.hs 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Devel + ( devel + ) where + + +import qualified Distribution.Simple.Utils as D +import qualified Distribution.Verbosity as D +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription.Parse as D +import qualified Distribution.PackageDescription as D + +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Exception as Ex +import Control.Monad (forever) + +import qualified Data.List as L +import qualified Data.Map as Map +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import System.Directory (createDirectoryIfMissing, removeFile, + getDirectoryContents) +import System.Exit (exitFailure, exitSuccess) +import System.Posix.Types (EpochTime) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import System.Process (runCommand, terminateProcess, + waitForProcess, rawSystem) + +import Text.Shakespeare.Text (st) + +import Build (recompDeps, getDeps,findHaskellFiles) + +#if __GLASGOW_HASKELL__ >= 700 +#define ST st +#else +#define ST $st +#endif + +lockFile :: FilePath +lockFile = "dist/devel-terminate" + +writeLock :: IO () +writeLock = do + createDirectoryIfMissing True "dist" + writeFile lockFile "" + +removeLock :: IO () +removeLock = try_ (removeFile lockFile) + +devel :: Bool -> IO () +devel isDevel = do + writeLock + + putStrLn "Yesod devel server. Press ENTER to quit" + _ <- forkIO $ do + cabal <- D.findPackageDesc "." + gpd <- D.readPackageDescription D.normal cabal + let pid = (D.package . D.packageDescription) gpd + + checkCabalFile gpd + + _ <- if isDevel + then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel", "--disable-library-profiling"] + else rawSystem "cabal" ["configure", "-fdevel", "--disable-library-profiling"] + + T.writeFile "dist/devel.hs" (develFile pid) + + mainLoop isDevel + + _ <- getLine + writeLock + exitSuccess + + + +mainLoop :: Bool -> IO () +mainLoop isDevel = forever $ do + putStrLn "Rebuilding application..." + + recompDeps + + list <- getFileList + _ <- if isDevel + then rawSystem "cabal-dev" ["build"] + else rawSystem "cabal" ["build"] + + removeLock + putStrLn "Starting development server..." + pkg <- pkgConfigs isDevel + ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"] + watchTid <- forkIO . try_ $ do + watchForChanges list + putStrLn "Stopping development server..." + writeLock + threadDelay 1000000 + putStrLn "Terminating development server..." + terminateProcess ph + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec + Ex.throwTo watchTid (userError "process finished") + watchForChanges list + +try_ :: forall a. IO a -> IO () +try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () + +pkgConfigs :: Bool -> IO String +pkgConfigs isDev + | isDev = do + devContents <- getDirectoryContents "cabal-dev" + let confs = filter isConfig devContents + return . unwords $ inplacePkg : + map ("-package-confcabal-dev/"++) confs + | otherwise = return inplacePkg + where + inplacePkg = "-package-confdist/package.conf.inplace" + isConfig dir = "packages-" `L.isPrefixOf` dir && + ".conf" `L.isSuffixOf` dir + +type FileList = Map.Map FilePath EpochTime + +getFileList :: IO FileList +getFileList = do + files <- findHaskellFiles "." + deps <- getDeps + let files' = files ++ map fst (Map.toList deps) + fmap Map.fromList $ flip mapM files' $ \f -> do + fs <- getFileStatus f + return (f, modificationTime fs) + +watchForChanges :: FileList -> IO () +watchForChanges list = do + newList <- getFileList + if list /= newList + then return () + else threadDelay 1000000 >> watchForChanges list + +showPkgName :: D.PackageId -> String +showPkgName = (\(D.PackageName n) -> n) . D.pkgName + +develFile :: D.PackageId -> T.Text +develFile pid = [ST| +{-# LANGUAGE PackageImports #-} +import "#{showPkgName pid}" Application (withDevelAppPort) +import Data.Dynamic (fromDynamic) +import Network.Wai.Handler.Warp (run) +import Data.Maybe (fromJust) +import Control.Concurrent (forkIO) +import System.Directory (doesFileExist, removeFile) +import System.Exit (exitSuccess) +import Control.Concurrent (threadDelay) + +main :: IO () +main = do + putStrLn "Starting devel application" + wdap <- (return . fromJust . fromDynamic) withDevelAppPort + forkIO . wdap $ \(port, app) -> run port app + loop + +loop :: IO () +loop = do + threadDelay 100000 + e <- doesFileExist "dist/devel-terminate" + if e then terminateDevel else loop + +terminateDevel :: IO () +terminateDevel = exitSuccess +|] + +checkCabalFile :: D.GenericPackageDescription -> IO () +checkCabalFile gpd = case D.condLibrary gpd of + Nothing -> do + putStrLn "Error: incorrect cabal file, no library" + exitFailure + Just ct -> + case lookupDevelLib ct of + Nothing -> do + putStrLn "Error: no library configuration for -fdevel" + exitFailure + Just dLib -> + case (D.hsSourceDirs . D.libBuildInfo) dLib of + [] -> return () + ["."] -> return () + _ -> + putStrLn $ "WARNING: yesod devel may not work correctly with " ++ + "custom hs-source-dirs" + +lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a +lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . + filter isDevelLib . D.condTreeComponents $ ct + where + isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True + isDevelLib _ = False + + diff -Nru haskell-yesod-0.6.7/input/database.cg haskell-yesod-0.9.3.4/input/database.cg --- haskell-yesod-0.6.7/input/database.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/database.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,9 @@ +Yesod uses Persistent for its (you guessed it) persistence layer. +This tool will build in either SQLite or PostgreSQL or MongoDB support for you. +We recommend starting with SQLite: it has no dependencies. + +We have another option: a tiny project with minimal dependencies. +Mostly this means no database and no authentication. + +So, what'll it be? +s for sqlite, p for postgresql, m for mongodb, or t for tiny: diff -Nru haskell-yesod-0.6.7/input/dir-name.cg haskell-yesod-0.9.3.4/input/dir-name.cg --- haskell-yesod-0.6.7/input/dir-name.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/dir-name.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,5 @@ +Now where would you like me to place your generated files? I'm smart enough +to create the directories, don't worry about that. If you leave this answer +blank, we'll place the files in ~project~. + +Directory name: diff -Nru haskell-yesod-0.6.7/input/done.cg haskell-yesod-0.9.3.4/input/done.cg --- haskell-yesod-0.6.7/input/done.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/done.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,32 @@ + +--------------------------------------- + + ___ + {-) |\ + [m,].-"-. / + [][__][__] \(/\__/\)/ + [__][__][__][__]~~~~ | | + [][__][__][__][__][] / | + [__][__][__][__][__]| /| | + [][__][__][__][__][]| || | ~~~~ + ejm [__][__][__][__][__]__,__, \__/ + + +--------------------------------------- + +The foundation for your site has been laid. + + +There are a lot of resources to help you use Yesod. +Start with the book: http://www.yesodweb.com/book +Take part in the community: http://yesodweb.com/page/community + + +Start your project: + + cd ~project~ && cabal install && yesod devel + +or if you use cabal-dev: + + cd ~project~ && cabal-dev install && yesod --dev devel + diff -Nru haskell-yesod-0.6.7/input/project-name.cg haskell-yesod-0.9.3.4/input/project-name.cg --- haskell-yesod-0.6.7/input/project-name.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/project-name.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,4 @@ +Welcome ~name~. +What do you want to call your project? We'll use this for the cabal name. + +Project name: diff -Nru haskell-yesod-0.6.7/input/site-arg.cg haskell-yesod-0.9.3.4/input/site-arg.cg --- haskell-yesod-0.6.7/input/site-arg.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/site-arg.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,5 @@ +Great, we'll be creating ~project~ today, and placing it in ~dir~. +What's going to be the name of your foundation datatype? This name must +start with a capital letter. + +Foundation: diff -Nru haskell-yesod-0.6.7/input/welcome.cg haskell-yesod-0.9.3.4/input/welcome.cg --- haskell-yesod-0.6.7/input/welcome.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/input/welcome.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,6 @@ +Welcome to the Yesod scaffolder. +I'm going to be creating a skeleton Yesod project for you. + +What is your name? We're going to put this in the cabal and LICENSE files. + +Your name: diff -Nru haskell-yesod-0.6.7/main.hs haskell-yesod-0.9.3.4/main.hs --- haskell-yesod-0.6.7/main.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/main.hs 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +import Scaffolding.Scaffolder +import System.Environment (getArgs) +import System.Exit (exitWith) +import System.Process (rawSystem) + +#ifndef WINDOWS +import Build (touch) +#endif +import Devel (devel) + +windowsWarning :: String +#ifdef WINDOWS +windowsWarning = "\n (does not work on Windows)" +#else +windowsWarning = "" +#endif + +main :: IO () +main = do + args' <- getArgs + let (isDev, args) = + case args' of + "--dev":rest -> (True, rest) + _ -> (False, args') + let cmd = if isDev then "cabal-dev" else "cabal" +#ifndef WINDOWS + let build rest = rawSystem cmd $ "build":rest +#endif + case args of + ["init"] -> scaffold +#ifndef WINDOWS + "build":rest -> touch >> build rest >>= exitWith + ["touch"] -> touch +#endif + ["devel"] -> devel isDev + ["version"] -> putStrLn "0.9.3" + "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith + _ -> do + putStrLn "Usage: yesod " + putStrLn "Available commands:" + putStrLn " init Scaffold a new site" + putStrLn " configure Configure a project for building" + putStrLn $ " build Build project (performs TH dependency analysis)" + ++ windowsWarning + putStrLn $ " touch Touch any files with altered TH dependencies but do not build" + ++ windowsWarning + putStrLn " devel Run project with the devel server" + putStrLn " use --dev devel to build with cabal-dev" + putStrLn " version Print the version of Yesod" + diff -Nru haskell-yesod-0.6.7/runtests.hs haskell-yesod-0.9.3.4/runtests.hs --- haskell-yesod-0.6.7/runtests.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/runtests.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -import Test.Framework (defaultMain) - -import qualified Yesod.Content -import qualified Yesod.Json -import qualified Yesod.Dispatch -import qualified Yesod.Helpers.Static -import qualified Yesod.Yesod -import qualified Yesod.Handler - -main :: IO () -main = defaultMain - [ Yesod.Content.testSuite - , Yesod.Json.testSuite - , Yesod.Dispatch.testSuite - , Yesod.Helpers.Static.testSuite - , Yesod.Yesod.testSuite - , Yesod.Handler.testSuite - ] diff -Nru haskell-yesod-0.6.7/scaffold/Application.hs.cg haskell-yesod-0.9.3.4/scaffold/Application.hs.cg --- haskell-yesod-0.6.7/scaffold/Application.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Application.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( with~sitearg~ + , withDevelAppPort + ) where + +import Import +import Settings +import Yesod.Static +import Yesod.Auth +import Yesod.Default.Config +import Yesod.Default.Main +import Yesod.Default.Handlers +import Yesod.Logger (Logger) +import Data.Dynamic (Dynamic, toDyn) +import qualified Database.Persist.Base~importMigration~ + +-- Import all relevant handler modules here. +import Handler.Root + +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in Foundation.hs. Please see +-- the comments there for more details. +mkYesodDispatch "~sitearg~" resources~sitearg~ + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +with~sitearg~ :: AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO () +with~sitearg~ conf logger f = do +#ifdef PRODUCTION + s <- static Settings.staticDir +#else + s <- staticDevel Settings.staticDir +#endif + dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf) + $ either error return . Database.Persist.Base.loadConfig + Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do~runMigration~ + let h = ~sitearg~ conf logger s p + defaultRunner f h + +-- for yesod devel +withDevelAppPort :: Dynamic +withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~ diff -Nru haskell-yesod-0.6.7/scaffold/cabal.cg haskell-yesod-0.9.3.4/scaffold/cabal.cg --- haskell-yesod-0.6.7/scaffold/cabal.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/cabal.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -name: ~project~ -version: 0.0.0 -license: BSD3 -license-file: LICENSE -author: ~name~ -maintainer: ~name~ -synopsis: The greatest Yesod web application ever. -description: I'm sure you can say something clever here if you try. -category: Web -stability: Experimental -cabal-version: >= 1.6 -build-type: Simple -homepage: http://~project~.yesodweb.com/ - -Flag production - Description: Build the production executable. - Default: False - -executable simple-server - if flag(production) - Buildable: False - main-is: simple-server.hs - build-depends: base >= 4 && < 5 - , yesod >= 0.6 && < 0.7 - , yesod-auth >= 0.2 && < 0.3 - , mime-mail >= 0.0 && < 0.1 - , wai-extra - , directory - , bytestring - , text - , persistent >= 0.3.1.1 - , 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 - -executable fastcgi - 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 - ghc-options: -Wall -threaded - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies - Binary files /tmp/0rfTElMJ3X/haskell-yesod-0.6.7/scaffold/config/favicon.ico.cg and /tmp/3VKPUd52Lp/haskell-yesod-0.9.3.4/scaffold/config/favicon.ico.cg differ diff -Nru haskell-yesod-0.6.7/scaffold/config/models.cg haskell-yesod-0.9.3.4/scaffold/config/models.cg --- haskell-yesod-0.6.7/scaffold/config/models.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/models.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,11 @@ +User + ident Text + password Text Maybe + UniqueUser ident +Email + email Text + user UserId Maybe + verkey Text Maybe + UniqueEmail email + + -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff -Nru haskell-yesod-0.6.7/scaffold/config/mongoDB.yml.cg haskell-yesod-0.9.3.4/scaffold/config/mongoDB.yml.cg --- haskell-yesod-0.6.7/scaffold/config/mongoDB.yml.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/mongoDB.yml.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,24 @@ +Default: &defaults + user: ~project~ + password: ~project~ + host: localhost + port: 27017 + database: ~project~ + poolsize: 10 + +Development: + <<: *defaults + +Testing: + database: ~project~_test + <<: *defaults + +Staging: + database: ~project~_staging + poolsize: 100 + <<: *defaults + +Production: + database: ~project~_production + poolsize: 100 + <<: *defaults diff -Nru haskell-yesod-0.6.7/scaffold/config/postgresql.yml.cg haskell-yesod-0.9.3.4/scaffold/config/postgresql.yml.cg --- haskell-yesod-0.6.7/scaffold/config/postgresql.yml.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/postgresql.yml.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,24 @@ +Default: &defaults + user: ~project~ + password: ~project~ + host: localhost + port: 5432 + database: ~project~ + poolsize: 10 + +Development: + <<: *defaults + +Testing: + database: ~project~_test + <<: *defaults + +Staging: + database: ~project~_staging + poolsize: 100 + <<: *defaults + +Production: + database: ~project~_production + poolsize: 100 + <<: *defaults diff -Nru haskell-yesod-0.6.7/scaffold/config/robots.txt.cg haskell-yesod-0.9.3.4/scaffold/config/robots.txt.cg --- haskell-yesod-0.6.7/scaffold/config/robots.txt.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/robots.txt.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1 @@ +User-agent: * diff -Nru haskell-yesod-0.6.7/scaffold/config/routes.cg haskell-yesod-0.9.3.4/scaffold/config/routes.cg --- haskell-yesod-0.6.7/scaffold/config/routes.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/routes.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,7 @@ +/static StaticR Static getStatic +/auth AuthR Auth getAuth + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET diff -Nru haskell-yesod-0.6.7/scaffold/config/settings.yml.cg haskell-yesod-0.9.3.4/scaffold/config/settings.yml.cg --- haskell-yesod-0.6.7/scaffold/config/settings.yml.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/settings.yml.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,16 @@ +Default: &defaults + host: "localhost" + port: 3000 + +Development: + <<: *defaults + +Testing: + <<: *defaults + +Staging: + <<: *defaults + +Production: + approot: "http://www.example.com" + <<: *defaults diff -Nru haskell-yesod-0.6.7/scaffold/config/sqlite.yml.cg haskell-yesod-0.9.3.4/scaffold/config/sqlite.yml.cg --- haskell-yesod-0.6.7/scaffold/config/sqlite.yml.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/config/sqlite.yml.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,20 @@ +Default: &defaults + database: ~project~.sqlite3 + poolsize: 10 + +Development: + <<: *defaults + +Testing: + database: ~project~_test.sqlite3 + <<: *defaults + +Staging: + database: ~project~_staging.sqlite3 + poolsize: 100 + <<: *defaults + +Production: + database: ~project~_production.sqlite3 + poolsize: 100 + <<: *defaults diff -Nru haskell-yesod-0.6.7/scaffold/Controller_hs.cg haskell-yesod-0.9.3.4/scaffold/Controller_hs.cg --- haskell-yesod-0.6.7/scaffold/Controller_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Controller_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Controller - ( with~sitearg~ - ) where - -import ~sitearg~ -import Settings -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import Database.Persist.GenericSql - --- Import all relevant handler modules here. -import Handler.Root - --- This line actually creates our YesodSite instance. It is the second half --- of the call to mkYesodData which occurs in ~sitearg~.hs. Please see --- the comments there for more details. -mkYesodDispatch "~sitearg~" resources~sitearg~ - --- Some default handlers that ship with the Yesod site template. You will --- very rarely need to modify this. -getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" "favicon.ico" - -getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent "User-agent: *" - --- This function allocates resources (such as a database connection pool), --- performs initialization and creates a WAI application. This is also the --- place to put your migrate statements to have automatic database --- migrations handled by Yesod. -with~sitearg~ :: (Application -> IO a) -> IO a -with~sitearg~ f = Settings.withConnectionPool $ \p -> do - runConnectionPool (runMigration migrateAll) p - let h = ~sitearg~ s p - toWaiApp h >>= f - where - s = fileLookupDir Settings.staticdir typeByExt - diff -Nru haskell-yesod-0.6.7/scaffold/database.cg haskell-yesod-0.9.3.4/scaffold/database.cg --- haskell-yesod-0.6.7/scaffold/database.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/database.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -Yesod uses Persistent for its (you guessed it) persistence layer. -This tool will build in either SQLite or PostgreSQL support for you. If you -want to use a different backend, you'll have to make changes manually. -If you're not sure, stick with SQLite: it has no dependencies. - -So, what'll it be? s for sqlite, p for postgresql: diff -Nru haskell-yesod-0.6.7/scaffold/default-layout_cassius.cg haskell-yesod-0.9.3.4/scaffold/default-layout_cassius.cg --- haskell-yesod-0.6.7/scaffold/default-layout_cassius.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/default-layout_cassius.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -body - font-family: sans-serif - diff -Nru haskell-yesod-0.6.7/scaffold/default-layout_hamlet.cg haskell-yesod-0.9.3.4/scaffold/default-layout_hamlet.cg --- haskell-yesod-0.6.7/scaffold/default-layout_hamlet.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/default-layout_hamlet.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -!!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ - diff -Nru haskell-yesod-0.6.7/scaffold/deploy/Procfile.cg haskell-yesod-0.9.3.4/scaffold/deploy/Procfile.cg --- haskell-yesod-0.6.7/scaffold/deploy/Procfile.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/deploy/Procfile.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,66 @@ +# Free deployment to Heroku. +# +# !! Warning: You must use a 64 bit machine to compile !! +# +# This could mean using a virtual machine. Give your VM as much memory as you can to speed up linking. +# +# Basic Yesod setup: +# +# * Move this file out of the deploy directory and into your root directory +# +# mv deploy/Procfile ./ +# +# * Create an empty package.json +# echo '{ "name": "~project~", "version": "0.0.1", "dependencies": {} }' >> package.json +# +# Postgresql Yesod setup: +# +# * add code to read DATABASE_URL environment variable. +# +# import System.Environment +# main = do +# durl <- getEnv "DATABASE_URL" +# # parse env variable +# # pass settings to withConnectionPool instead of directly using loadConnStr +# +# * add a dependency on the "heroku" package in your cabal file +# +# * add code in Settings.hs to turn that url into connection parameters. The below works for Postgresql. +# +# #ifdef PRODUCTION +# import qualified Web.Heroku +# #endif +# +# dbConnParams :: AppEnvironment -> IO [(Text, Text)] +# #ifdef PRODUCTION +# dbConnParams _ = Web.Heroku.dbConnParams +# #else +# dbConnParams env = do +# ... +# +# +# Heroku setup: +# Find the Heroku guide. Roughly: +# +# * sign up for a heroku account and register your ssh key +# * create a new application on the *cedar* stack +# +# * make your Yesod project the git repository for that application +# * create a deploy branch +# +# git checkout -b deploy +# +# Repeat these steps to deploy: +# * add your web executable binary (referenced below) to the git repository +# +# git checkout deploy +# git add ./dist/build/~project~/~project~ +# git commit -m deploy +# +# * push to Heroku +# +# git push heroku deploy:master + + +# Heroku configuration that runs your app +web: ./dist/build/~project~/~project~ -p $PORT diff -Nru haskell-yesod-0.6.7/scaffold/devel-server_hs.cg haskell-yesod-0.9.3.4/scaffold/devel-server_hs.cg --- haskell-yesod-0.6.7/scaffold/devel-server_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/devel-server_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -import Network.Wai.Handler.DevelServer (run) -import Control.Concurrent (forkIO) - -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 - diff -Nru haskell-yesod-0.6.7/scaffold/dir-name.cg haskell-yesod-0.9.3.4/scaffold/dir-name.cg --- haskell-yesod-0.6.7/scaffold/dir-name.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/dir-name.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -Now where would you like me to place your generated files? I'm smart enough -to create the directories, don't worry about that. If you leave this answer -blank, we'll place the files in ~project~. - -Directory name: diff -Nru haskell-yesod-0.6.7/scaffold/fastcgi_hs.cg haskell-yesod-0.9.3.4/scaffold/fastcgi_hs.cg --- haskell-yesod-0.6.7/scaffold/fastcgi_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/fastcgi_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.FastCGI (run) - -main :: IO () -main = with~sitearg~ run - Binary files /tmp/0rfTElMJ3X/haskell-yesod-0.6.7/scaffold/favicon_ico.cg and /tmp/3VKPUd52Lp/haskell-yesod-0.9.3.4/scaffold/favicon_ico.cg differ diff -Nru haskell-yesod-0.6.7/scaffold/Foundation.hs.cg haskell-yesod-0.9.3.4/scaffold/Foundation.hs.cg --- haskell-yesod-0.6.7/scaffold/Foundation.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Foundation.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,157 @@ +module Foundation + ( ~sitearg~ (..) + , ~sitearg~Route (..) + , ~sitearg~Message (..) + , resources~sitearg~ + , Handler + , Widget + , Form + , maybeAuth + , requireAuth + , module Yesod + , module Settings + , module Model + , StaticRoute (..) + , AuthRoute (..) + ) where + +import Prelude +import Yesod hiding (Form) +import Yesod.Static (Static, base64md5, StaticRoute(..)) +import Settings.StaticFiles +import Yesod.Auth +import Yesod.Auth.OpenId +import Yesod.Default.Config +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Logger (Logger, logLazyText) +import qualified Settings +import qualified Data.ByteString.Lazy as L +import qualified Database.Persist.Base +import Database.Persist.~importGenericDB~ +import Settings (widgetFile) +import Model +import Text.Jasmine (minifym) +import Web.ClientSession (getKey) +import Text.Hamlet (hamletFile) +#if PRODUCTION +import Network.Mail.Mime (sendmail) +#else +import qualified Data.Text.Lazy.Encoding +#endif + +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data ~sitearg~ = ~sitearg~ + { settings :: AppConfig DefaultEnv + , getLogger :: Logger + , getStatic :: Static -- ^ Settings for static file serving. + , connPool :: Database.Persist.Base.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. + } + +-- Set up i18n messages. See the message folder. +mkMessage "~sitearg~" "messages" "en" + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://www.yesodweb.com/book/handler +-- +-- This function does three things: +-- +-- * Creates the route datatype ~sitearg~Route. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route ~sitearg~ = ~sitearg~Route +-- * Creates the value resources~sitearg~ which contains information on the +-- resources declared below. This is used in Handler.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- ~sitearg~. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the ~sitearg~Route datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") + +type Form x = Html -> MForm ~sitearg~ ~sitearg~ (FormResult x, Widget) + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod ~sitearg~ where + approot = appRoot . settings + + -- Place the session key file in the config folder + encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + + defaultLayout widget = do + mmsg <- getMessage + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + pc <- widgetToPageContent $ do + $(widgetFile "normalize") + $(widgetFile "default-layout") + hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticRoot setting in Settings.hs + urlRenderOverride y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s + urlRenderOverride _ _ = Nothing + + -- The page to be redirected to when authentication is required. + authRoute _ = Just $ AuthR LoginR + + messageLogger y loc level msg = + formatLogMessage loc level msg >>= logLazyText (getLogger y) + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + + -- Enable Javascript async loading + yepnopeJs _ = Just $ Right $ StaticR js_modernizr_js + +-- How to run database actions. +instance YesodPersist ~sitearg~ where + type YesodPersistBackend ~sitearg~ = ~dbMonad~ + runDB f = liftIOHandler + $ fmap connPool getYesod >>= Database.Persist.Base.runPool (undefined :: Settings.PersistConfig) f + +instance YesodAuth ~sitearg~ where + type AuthId ~sitearg~ = UserId + + -- Where to send a user after successful login + loginDest _ = RootR + -- Where to send a user after logout + logoutDest _ = RootR + + getAuthId creds = runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (uid, _) -> return $ Just uid + Nothing -> do + fmap Just $ insert $ User (credsIdent creds) Nothing + + -- You can add other plugins like BrowserID, email or OAuth here + authPlugins = [authOpenId] + +-- Sends off your mail. Requires sendmail in production! +deliver :: ~sitearg~ -> L.ByteString -> IO () +#ifdef PRODUCTION +deliver _ = sendmail +#else +deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8 +#endif + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage ~sitearg~ FormMessage where + renderMessage _ _ = defaultFormMessage diff -Nru haskell-yesod-0.6.7/scaffold/.ghci.cg haskell-yesod-0.9.3.4/scaffold/.ghci.cg --- haskell-yesod-0.6.7/scaffold/.ghci.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/.ghci.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,2 @@ +:set -i.:config:dist/build/autogen + diff -Nru haskell-yesod-0.6.7/scaffold/Handler/Root.hs.cg haskell-yesod-0.9.3.4/scaffold/Handler/Root.hs.cg --- haskell-yesod-0.6.7/scaffold/Handler/Root.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Handler/Root.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,17 @@ +module Handler.Root where + +import Import + +-- This is a handler function for the GET request method on the RootR +-- resource pattern. All of your resource patterns are defined in +-- config/routes +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. +getRootR :: Handler RepHtml +getRootR = do + defaultLayout $ do + h2id <- lift newIdent + setTitle "~project~ homepage" + $(widgetFile "homepage") diff -Nru haskell-yesod-0.6.7/scaffold/homepage_cassius.cg haskell-yesod-0.9.3.4/scaffold/homepage_cassius.cg --- haskell-yesod-0.6.7/scaffold/homepage_cassius.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/homepage_cassius.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -h1 - text-align: center -h2#$h2id$ - color: #990 - diff -Nru haskell-yesod-0.6.7/scaffold/homepage_hamlet.cg haskell-yesod-0.9.3.4/scaffold/homepage_hamlet.cg --- haskell-yesod-0.6.7/scaffold/homepage_hamlet.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/homepage_hamlet.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -%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 - \. -$nothing - %p - You are not logged in. $ - %a!href=@AuthR.LoginR@ Login now - \. - diff -Nru haskell-yesod-0.6.7/scaffold/homepage_julius.cg haskell-yesod-0.9.3.4/scaffold/homepage_julius.cg --- haskell-yesod-0.6.7/scaffold/homepage_julius.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/homepage_julius.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -window.onload = function(){ - document.getElementById("%h2id%").innerHTML = "Added from JavaScript."; -} - diff -Nru haskell-yesod-0.6.7/scaffold/Import.hs.cg haskell-yesod-0.9.3.4/scaffold/Import.hs.cg --- haskell-yesod-0.6.7/scaffold/Import.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Import.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,18 @@ +module Import + ( module Prelude + , module Foundation + , (<>) + , Text + , module Data.Monoid + , module Control.Applicative + ) where + +import Prelude hiding (writeFile, readFile) +import Foundation +import Data.Monoid (Monoid (mappend, mempty, mconcat)) +import Control.Applicative ((<$>), (<*>), pure) +import Data.Text (Text) + +infixr 5 <> +(<>) :: Monoid m => m -> m -> m +(<>) = mappend diff -Nru haskell-yesod-0.6.7/scaffold/main.hs.cg haskell-yesod-0.9.3.4/scaffold/main.hs.cg --- haskell-yesod-0.6.7/scaffold/main.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/main.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,7 @@ +import Yesod.Default.Config (fromArgs) +import Yesod.Default.Main (defaultMain) +import Application (with~sitearg~) +import Prelude (IO) + +main :: IO () +main = defaultMain fromArgs with~sitearg~ diff -Nru haskell-yesod-0.6.7/scaffold/messages/en.msg.cg haskell-yesod-0.9.3.4/scaffold/messages/en.msg.cg --- haskell-yesod-0.6.7/scaffold/messages/en.msg.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/messages/en.msg.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1 @@ +Hello: Hello diff -Nru haskell-yesod-0.6.7/scaffold/Model_hs.cg haskell-yesod-0.9.3.4/scaffold/Model_hs.cg --- haskell-yesod-0.6.7/scaffold/Model_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Model_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} -module Model where - -import Yesod -import Database.Persist.TH (share2) -import Database.Persist.GenericSql (mkMigrate) - --- You can define all of your database entities here. You can find more --- information on persistent and how to declare entities at: --- http://docs.yesodweb.com/book/persistent/ -share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| -User - ident String - password String Maybe Update - UniqueUser ident -Email - email String - user UserId Maybe Update - verkey String Maybe Update - UniqueEmail email -|] - diff -Nru haskell-yesod-0.6.7/scaffold/Model.hs.cg haskell-yesod-0.9.3.4/scaffold/Model.hs.cg --- haskell-yesod-0.6.7/scaffold/Model.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Model.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,13 @@ +module Model where + +import Prelude +import Yesod +import Data.Text (Text) +~modelImports~ + +-- You can define all of your database entities in the entities file. +-- You can find more information on persistent and how to declare entities +-- at: +-- http://www.yesodweb.com/book/persistent/ +share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"] $(persistFile "config/models") + diff -Nru haskell-yesod-0.6.7/scaffold/mongoDBConnPool.cg haskell-yesod-0.9.3.4/scaffold/mongoDBConnPool.cg --- haskell-yesod-0.6.7/scaffold/mongoDBConnPool.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/mongoDBConnPool.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,8 @@ +runConnectionPool :: MonadControlIO m => Action m a -> ConnectionPool -> m a +runConnectionPool = runMongoDBConn (ConfirmWrites [u"j" =: True]) + +withConnectionPool :: (MonadControlIO m, Applicative m) => AppConfig DefaultEnv -> (ConnectionPool -> m b) -> m b +withConnectionPool conf f = do + dbConf <- liftIO $ loadMongo (appEnv conf) + withMongoDBPool (u $ mgDatabase dbConf) (mgHost dbConf) (mgPoolSize dbConf) f + diff -Nru haskell-yesod-0.6.7/scaffold/pconn1.cg haskell-yesod-0.9.3.4/scaffold/pconn1.cg --- haskell-yesod-0.6.7/scaffold/pconn1.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/pconn1.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug diff -Nru haskell-yesod-0.6.7/scaffold/pconn2.cg haskell-yesod-0.9.3.4/scaffold/pconn2.cg --- haskell-yesod-0.6.7/scaffold/pconn2.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/pconn2.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production diff -Nru haskell-yesod-0.6.7/scaffold/postgresqlConnPool.cg haskell-yesod-0.9.3.4/scaffold/postgresqlConnPool.cg --- haskell-yesod-0.6.7/scaffold/postgresqlConnPool.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/postgresqlConnPool.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,13 @@ +runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +withConnectionPool :: MonadControlIO m => AppConfig DefaultEnv -> (ConnectionPool -> m a) -> m a +withConnectionPool conf f = do + dbConf <- liftIO $ load~upper~ (appEnv conf) + with~upper~Pool (pgConnStr dbConf) (pgPoolSize dbConf) f + +-- Example of making a dynamic configuration static +-- use /return $(mkConnStr Production)/ instead of loadConnStr +-- mkConnStr :: AppEnvironment -> Q Exp +-- mkConnStr env = qRunIO (loadConnStr env) >>= return . LitE . StringL + diff -Nru haskell-yesod-0.6.7/scaffold/project.cabal.cg haskell-yesod-0.9.3.4/scaffold/project.cabal.cg --- haskell-yesod-0.6.7/scaffold/project.cabal.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/project.cabal.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,94 @@ +name: ~project~ +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: ~name~ +maintainer: ~name~ +synopsis: The greatest Yesod web application ever. +description: I'm sure you can say something clever here if you try. +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://~project~.yesodweb.com/ + +Flag production + Description: Build the production executable. + Default: False + +Flag devel + Description: Build for use with "yesod devel" + Default: False + +library + if flag(devel) + Buildable: True + else + Buildable: False + + exposed-modules: Application + other-modules: Foundation + Import + Model + Settings + Settings.StaticFiles + Handler.Root + + ghc-options: -Wall -threaded -O0 + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + GADTs + GeneralizedNewtypeDeriving + FlexibleContexts + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded -O0 + + main-is: main.hs + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + GADTs + GeneralizedNewtypeDeriving + FlexibleContexts + + build-depends: base >= 4 && < 5 + , yesod >= 0.9.3.4 && < 0.10 + , yesod-core >= 0.9.3 && < 0.10 + , yesod-auth >= 0.7.3 && < 0.8 + , yesod-static >= 0.3.1 && < 0.4 + , yesod-default >= 0.4 && < 0.5 + , yesod-form >= 0.3.4 && < 0.4 + , mime-mail >= 0.3.0.3 && < 0.4 + , clientsession >= 0.7.3 && < 0.8 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , persistent >= 0.6.2 && < 0.7 + , persistent-~backendLower~ >= 0.6 && < 0.7 + , template-haskell + , hamlet >= 0.10 && < 0.11 + , shakespeare-css >= 0.10 && < 0.11 + , shakespeare-js >= 0.10 && < 0.11 + , shakespeare-text >= 0.10 && < 0.11 + , hjsmin >= 0.0.14 && < 0.1 + , monad-control ~monadControlVersion~ diff -Nru haskell-yesod-0.6.7/scaffold/project-name.cg haskell-yesod-0.9.3.4/scaffold/project-name.cg --- haskell-yesod-0.6.7/scaffold/project-name.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/project-name.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -Welcome ~name~. -What do you want to call your project? We'll use this for the cabal name. - -Project name: diff -Nru haskell-yesod-0.6.7/scaffold/Root_hs.cg haskell-yesod-0.9.3.4/scaffold/Root_hs.cg --- haskell-yesod-0.6.7/scaffold/Root_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Root_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} -module Handler.Root where - -import ~sitearg~ - --- This is a handler function for the GET request method on the RootR --- resource pattern. All of your resource patterns are defined in --- ~sitearg~.hs; look for the line beginning with mkYesodData. --- --- The majority of the code you will write in Yesod lives in these handler --- functions. You can spread them across multiple files if you are so --- inclined, or create a single monolithic file. -getRootR :: Handler RepHtml -getRootR = do - mu <- maybeAuth - defaultLayout $ do - h2id <- newIdent - setTitle "~project~ homepage" - addWidget $(widgetFile "homepage") - diff -Nru haskell-yesod-0.6.7/scaffold/Settings/StaticFiles.hs.cg haskell-yesod-0.9.3.4/scaffold/Settings/StaticFiles.hs.cg --- haskell-yesod-0.6.7/scaffold/Settings/StaticFiles.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Settings/StaticFiles.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,10 @@ +module Settings.StaticFiles where + +import Yesod.Static (staticFiles, StaticRoute (StaticRoute)) + +-- | This generates easy references to files in the static directory at compile time. +-- The upside to this is that you have compile-time verification that referenced files +-- exist. However, any files added to your static directory during run-time can't be +-- accessed this way. You'll have to use their FilePath or URL to access them. +$(staticFiles "static") + diff -Nru haskell-yesod-0.6.7/scaffold/Settings_hs.cg haskell-yesod-0.9.3.4/scaffold/Settings_hs.cg --- haskell-yesod-0.6.7/scaffold/Settings_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Settings_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} --- | Settings are centralized, as much as possible, into this file. This --- includes database connection settings, static file locations, etc. --- In addition, you can configure a number of different aspects of Yesod --- by overriding methods in the Yesod typeclass. That instance is --- declared in the ~sitearg~.hs file. -module Settings - ( hamletFile - , cassiusFile - , juliusFile - , widgetFile - , connStr - , ConnectionPool - , withConnectionPool - , runConnectionPool - , approot - , staticroot - , staticdir - ) where - -import qualified Text.Hamlet as H -import qualified Text.Cassius as H -import qualified Text.Julius as H -import Language.Haskell.TH.Syntax -import Database.Persist.~upper~ -import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) -import Data.Monoid (mempty) -import System.Directory (doesFileExist) - --- | The base URL for your application. This will usually be different for --- development and production. Yesod automatically constructs URLs for you, --- so this value must be accurate to create valid links. -approot :: String -#ifdef PRODUCTION --- You probably want to change this. If your domain name was "yesod.com", --- you would probably want it to be: --- > approot = "http://www.yesod.com" --- Please note that there is no trailing slash. -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif - --- | The location of static files on your system. This is a file system --- path. The default value works properly with your scaffolded site. -staticdir :: FilePath -staticdir = "static" - --- | The base URL for your static files. As you can see by the default --- value, this can simply be "static" appended to your application root. --- A powerful optimization can be serving static files from a separate --- domain name. This allows you to use a web server optimized for static --- files, more easily set expires and cache values, and avoid possibly --- costly transference of cookies on static files. For more information, --- please see: --- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain --- --- If you change the resource pattern for StaticR in ~sitearg~.hs, you will --- have to make a corresponding change here. --- --- To see how this value is used, see urlRenderOverride in ~sitearg~.hs -staticroot :: String -staticroot = approot ++ "/static" - --- | The database connection string. The meaning of this string is backend- --- specific. -connStr :: String -#ifdef PRODUCTION -connStr = "~connstr2~" -#else -connStr = "~connstr1~" -#endif - --- | Your application will keep a connection pool and take connections from --- there as necessary instead of continually creating new connections. This --- value gives the maximum number of connections to be open at a given time. --- If your application requests a connection when all connections are in --- use, that request will fail. Try to choose a number that will work well --- with the system resources available to you while providing enough --- connections for your expected load. --- --- Also, connections are returned to the pool as quickly as possible by --- Yesod to avoid resource exhaustion. A connection is only considered in --- use while within a call to runDB. -connectionCount :: Int -connectionCount = 10 - --- The rest of this file contains settings which rarely need changing by a --- user. - --- The following three functions are used for calling HTML, CSS and --- Javascript templates from your Haskell code. During development, --- the "Debug" versions of these functions are used so that changes to --- the templates are immediately reflected in an already running --- application. When making a production compile, the non-debug version --- is used for increased performance. --- --- You can see an example of how to call these functions in Handler/Root.hs --- --- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer --- used; to get the same auto-loading effect, it is recommended that you --- use the devel server. - -toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath -toHamletFile x = "hamlet/" ++ x ++ ".hamlet" -toCassiusFile x = "cassius/" ++ x ++ ".cassius" -toJuliusFile x = "julius/" ++ x ++ ".julius" - -hamletFile :: FilePath -> Q Exp -hamletFile = H.hamletFile . toHamletFile - -cassiusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -cassiusFile = H.cassiusFile . toCassiusFile -#else -cassiusFile = H.cassiusFileDebug . toCassiusFile -#endif - -juliusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -juliusFile = H.juliusFile . toJuliusFile -#else -juliusFile = H.juliusFileDebug . toJuliusFile -#endif - -widgetFile :: FilePath -> Q Exp -widgetFile x = do - let h = unlessExists toHamletFile hamletFile - let c = unlessExists toCassiusFile cassiusFile - let j = unlessExists toJuliusFile juliusFile - [|addWidget $h >> addCassius $c >> addJulius $j|] - where - unlessExists tofn f = do - e <- qRunIO $ doesFileExist $ tofn x - if e then f x else [|mempty|] - --- The next two functions are for allocating a connection pool and running --- 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 = with~upper~Pool connStr connectionCount - -runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a -runConnectionPool = runSqlPool - diff -Nru haskell-yesod-0.6.7/scaffold/Settings.hs.cg haskell-yesod-0.9.3.4/scaffold/Settings.hs.cg --- haskell-yesod-0.6.7/scaffold/Settings.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/Settings.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,56 @@ +-- | Settings are centralized, as much as possible, into this file. This +-- includes database connection settings, static file locations, etc. +-- In addition, you can configure a number of different aspects of Yesod +-- by overriding methods in the Yesod typeclass. That instance is +-- declared in the Foundation.hs file. +module Settings + ( widgetFile + , PersistConfig + , staticRoot + , staticDir + ) where + +import Prelude (FilePath, String) +import Text.Shakespeare.Text (st) +import Language.Haskell.TH.Syntax +import Database.Persist.~importPersist~ (~configPersist~) +import Yesod.Default.Config +import qualified Yesod.Default.Util +import Data.Text (Text) + +-- | Which Persistent backend this site is using. +type PersistConfig = ~configPersist~ + +-- Static setting below. Changing these requires a recompile + +-- | The location of static files on your system. This is a file system +-- path. The default value works properly with your scaffolded site. +staticDir :: FilePath +staticDir = "static" + +-- | The base URL for your static files. As you can see by the default +-- value, this can simply be "static" appended to your application root. +-- A powerful optimization can be serving static files from a separate +-- domain name. This allows you to use a web server optimized for static +-- files, more easily set expires and cache values, and avoid possibly +-- costly transference of cookies on static files. For more information, +-- please see: +-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain +-- +-- If you change the resource pattern for StaticR in Foundation.hs, you will +-- have to make a corresponding change here. +-- +-- To see how this value is used, see urlRenderOverride in Foundation.hs +staticRoot :: AppConfig DefaultEnv -> Text +staticRoot conf = [~qq~st|#{appRoot conf}/static|] + + +-- The rest of this file contains settings which rarely need changing by a +-- user. + +widgetFile :: String -> Q Exp +#if PRODUCTION +widgetFile = Yesod.Default.Util.widgetFileProduction +#else +widgetFile = Yesod.Default.Util.widgetFileDebug +#endif diff -Nru haskell-yesod-0.6.7/scaffold/simple-server_hs.cg haskell-yesod-0.9.3.4/scaffold/simple-server_hs.cg --- haskell-yesod-0.6.7/scaffold/simple-server_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/simple-server_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.SimpleServer (run) - -main :: IO () -main = putStrLn "Loaded" >> with~sitearg~ (run 3000) - diff -Nru haskell-yesod-0.6.7/scaffold/site-arg.cg haskell-yesod-0.9.3.4/scaffold/site-arg.cg --- haskell-yesod-0.6.7/scaffold/site-arg.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/site-arg.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -Great, we'll be creating ~project~ today, and placing it in ~dir~. -What's going to be the name of your foundation datatype? This name must -start with a capital letter. - -Foundation: diff -Nru haskell-yesod-0.6.7/scaffold/sitearg_hs.cg haskell-yesod-0.9.3.4/scaffold/sitearg_hs.cg --- haskell-yesod-0.6.7/scaffold/sitearg_hs.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/sitearg_hs.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,221 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} -module ~sitearg~ - ( ~sitearg~ (..) - , ~sitearg~Route (..) - , resources~sitearg~ - , Handler - , Widget - , maybeAuth - , requireAuth - , module Yesod - , module Settings - , module Model - , StaticRoute (..) - , AuthRoute (..) - ) where - -import Yesod -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import Yesod.Helpers.Auth.OpenId -import Yesod.Helpers.Auth.Email -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 -import Data.Maybe (isJust) -import Control.Monad (join, unless) -import Network.Mail.Mime -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding -import Text.Jasmine (minifym) - --- | The site argument for your application. This can be a good place to --- keep settings and values requiring initialization before your application --- starts running, such as database connections. Every handler will have --- access to the data present here. -data ~sitearg~ = ~sitearg~ - { getStatic :: Static -- ^ Settings for static file serving. - , connPool :: Settings.ConnectionPool -- ^ Database connection pool. - } - --- | A useful synonym; most of the handler functions in your application --- will need to be of this type. -type Handler = GHandler ~sitearg~ ~sitearg~ - --- | A useful synonym; most of the widgets functions in your application --- will need to be of this type. -type Widget = GWidget ~sitearg~ ~sitearg~ - --- This is where we define all of the routes in our application. For a full --- explanation of the syntax, please see: --- http://docs.yesodweb.com/book/web-routes-quasi/ --- --- This function does three things: --- --- * Creates the route datatype ~sitearg~Route. Every valid URL in your --- application can be represented as a value of this type. --- * Creates the associated type: --- type instance Route ~sitearg~ = ~sitearg~Route --- * Creates the value resources~sitearg~ which contains information on the --- resources declared below. This is used in Controller.hs by the call to --- mkYesodDispatch --- --- What this function does *not* do is create a YesodSite instance for --- ~sitearg~. Creating that instance requires all of the handler functions --- for our application to be in scope. However, the handler functions --- usually require access to the ~sitearg~Route datatype. Therefore, we --- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" [~qq~parseRoutes| -/static StaticR Static getStatic -/auth AuthR Auth getAuth - -/favicon.ico FaviconR GET -/robots.txt RobotsR GET - -/ RootR GET -|] - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod ~sitearg~ where - approot _ = Settings.approot - - defaultLayout widget = do - mmsg <- getMessage - pc <- widgetToPageContent $ do - widget - addCassius $(Settings.cassiusFile "default-layout") - hamletToRepHtml $(Settings.hamletFile "default-layout") - - -- 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 - urlRenderOverride _ _ = Nothing - - -- The page to be redirected to when authentication is required. - authRoute _ = Just $ AuthR LoginR - - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : ext' - let content' = - if ext' == "js" - then case minifym content of - Left _ -> content - Right y -> y - else content - let statictmp = Settings.staticdir ++ "/tmp/" - liftIO $ createDirectoryIfMissing True statictmp - let fn' = statictmp ++ fn - exists <- liftIO $ doesFileExist fn' - unless exists $ liftIO $ L.writeFile fn' content' - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - --- How to run database actions. -instance YesodPersist ~sitearg~ where - type YesodDB ~sitearg~ = SqlPersist - runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db - -instance YesodAuth ~sitearg~ where - type AuthId ~sitearg~ = UserId - - -- Where to send a user after successful login - loginDest _ = RootR - -- Where to send a user after logout - logoutDest _ = RootR - - getAuthId creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (uid, _) -> return $ Just uid - Nothing -> do - fmap Just $ insert $ User (credsIdent creds) Nothing - - showAuthId _ = showIntegral - readAuthId _ = readIntegral - - authPlugins = [ authOpenId - , authEmail - ] - -instance YesodAuthEmail ~sitearg~ where - type AuthEmailId ~sitearg~ = EmailId - - showAuthEmailId _ = showIntegral - readAuthEmailId _ = readIntegral - - addUnverified email verkey = - runDB $ insert $ Email email Nothing $ Just verkey - sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail - { mailHeaders = - [ ("From", "noreply") - , ("To", email) - , ("Subject", "Verify your email address") - ] - , mailParts = [[textPart, htmlPart]] - } - where - textPart = Part - { partType = "text/plain; charset=utf-8" - , partEncoding = None - , partFilename = Nothing - , partContent = Data.Text.Lazy.Encoding.encodeUtf8 - $ Data.Text.Lazy.pack $ unlines - [ "Please confirm your email address by clicking on the link below." - , "" - , verurl - , "" - , "Thank you" - ] - } - 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 -|] - } - getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get - setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] - verifyAccount eid = runDB $ do - me <- get eid - case me of - Nothing -> return Nothing - Just e -> do - let email = emailEmail e - case emailUser e of - Just uid -> return $ Just uid - Nothing -> do - uid <- insert $ User email Nothing - update eid [EmailUser $ Just uid, EmailVerkey Nothing] - return $ Just uid - getPassword = runDB . fmap (join . fmap userPassword) . get - setPassword uid pass = runDB $ update uid [UserPassword $ Just pass] - getEmailCreds email = runDB $ do - me <- getBy $ UniqueEmail email - case me of - Nothing -> return Nothing - Just (eid, e) -> return $ Just EmailCreds - { emailCredsId = eid - , emailCredsAuthId = emailUser e - , emailCredsStatus = isJust $ emailUser e - , emailCredsVerkey = emailVerkey e - } - getEmail = runDB . fmap (fmap emailEmail) . get - diff -Nru haskell-yesod-0.6.7/scaffold/sqliteConnPool.cg haskell-yesod-0.9.3.4/scaffold/sqliteConnPool.cg --- haskell-yesod-0.6.7/scaffold/sqliteConnPool.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/sqliteConnPool.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,13 @@ +runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +withConnectionPool :: MonadControlIO m => AppConfig DefaultEnv -> (ConnectionPool -> m a) -> m a +withConnectionPool conf f = do + dbConf <- liftIO $ load~upper~ (appEnv conf) + with~upper~Pool (sqlDatabase dbConf) (sqlPoolSize dbConf) f + +-- Example of making a dynamic configuration static +-- use /return $(mkConnStr Production)/ instead of loadConnStr +-- mkConnStr :: AppEnvironment -> Q Exp +-- mkConnStr env = qRunIO (loadConnStr env) >>= return . LitE . StringL + diff -Nru haskell-yesod-0.6.7/scaffold/static/js/modernizr.js.cg haskell-yesod-0.9.3.4/scaffold/static/js/modernizr.js.cg --- haskell-yesod-0.6.7/scaffold/static/js/modernizr.js.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/static/js/modernizr.js.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,4 @@ +/* Modernizr 2.0.6 (Custom Build) | MIT & BSD + * Build: http://www.modernizr.com/download/#-fontface-backgroundsize-borderimage-borderradius-boxshadow-flexbox-hsla-multiplebgs-opacity-rgba-textshadow-cssanimations-csscolumns-generatedcontent-cssgradients-cssreflections-csstransforms-csstransforms3d-csstransitions-applicationcache-canvas-canvastext-draganddrop-hashchange-history-audio-video-indexeddb-input-inputtypes-localstorage-postmessage-sessionstorage-websockets-websqldatabase-webworkers-geolocation-inlinesvg-smil-svg-svgclippaths-touch-webgl-iepp-cssclasses-teststyles-testprop-testallprops-hasevent-prefixes-domprefixes-load + */ +;window.Modernizr=function(a,b,c){function H(){e.input=function(a){for(var b=0,c=a.length;b",a,""].join(""),k.id=i,k.innerHTML+=f,g.appendChild(k),h=c(k,a),k.parentNode.removeChild(k);return!!h},w=function(){function d(d,e){e=e||b.createElement(a[d]||"div"),d="on"+d;var f=d in e;f||(e.setAttribute||(e=b.createElement("div")),e.setAttribute&&e.removeAttribute&&(e.setAttribute(d,""),f=C(e[d],"function"),C(e[d],c)||(e[d]=c),e.removeAttribute(d))),e=null;return f}var a={select:"input",change:"input",submit:"form",reset:"form",error:"img",load:"img",abort:"img"};return d}(),x,y={}.hasOwnProperty,z;!C(y,c)&&!C(y.call,c)?z=function(a,b){return y.call(a,b)}:z=function(a,b){return b in a&&C(a.constructor.prototype[b],c)};var G=function(c,d){var f=c.join(""),g=d.length;v(f,function(c,d){var f=b.styleSheets[b.styleSheets.length-1],h=f.cssRules&&f.cssRules[0]?f.cssRules[0].cssText:f.cssText||"",i=c.childNodes,j={};while(g--)j[i[g].id]=i[g];e.touch="ontouchstart"in a||j.touch.offsetTop===9,e.csstransforms3d=j.csstransforms3d.offsetLeft===9,e.generatedcontent=j.generatedcontent.offsetHeight>=1,e.fontface=/src/i.test(h)&&h.indexOf(d.split(" ")[0])===0},g,d)}(['@font-face {font-family:"font";src:url("https://")}',["@media (",o.join("touch-enabled),("),i,")","{#touch{top:9px;position:absolute}}"].join(""),["@media (",o.join("transform-3d),("),i,")","{#csstransforms3d{left:9px;position:absolute}}"].join(""),['#generatedcontent:after{content:"',m,'";visibility:hidden}'].join("")],["fontface","touch","csstransforms3d","generatedcontent"]);r.flexbox=function(){function c(a,b,c,d){a.style.cssText=o.join(b+":"+c+";")+(d||"")}function a(a,b,c,d){b+=":",a.style.cssText=(b+o.join(c+";"+b)).slice(0,-b.length)+(d||"")}var d=b.createElement("div"),e=b.createElement("div");a(d,"display","box","width:42px;padding:0;"),c(e,"box-flex","1","width:10px;"),d.appendChild(e),g.appendChild(d);var f=e.offsetWidth===42;d.removeChild(e),g.removeChild(d);return f},r.canvas=function(){var a=b.createElement("canvas");return!!a.getContext&&!!a.getContext("2d")},r.canvastext=function(){return!!e.canvas&&!!C(b.createElement("canvas").getContext("2d").fillText,"function")},r.webgl=function(){return!!a.WebGLRenderingContext},r.touch=function(){return e.touch},r.geolocation=function(){return!!navigator.geolocation},r.postmessage=function(){return!!a.postMessage},r.websqldatabase=function(){var b=!!a.openDatabase;return b},r.indexedDB=function(){for(var b=-1,c=p.length;++b7)},r.history=function(){return!!a.history&&!!history.pushState},r.draganddrop=function(){return w("dragstart")&&w("drop")},r.websockets=function(){for(var b=-1,c=p.length;++b";return(a.firstChild&&a.firstChild.namespaceURI)==q.svg},r.smil=function(){return!!b.createElementNS&&/SVG/.test(n.call(b.createElementNS(q.svg,"animate")))},r.svgclippaths=function(){return!!b.createElementNS&&/SVG/.test(n.call(b.createElementNS(q.svg,"clipPath")))};for(var I in r)z(r,I)&&(x=I.toLowerCase(),e[x]=r[I](),u.push((e[x]?"":"no-")+x));e.input||H(),A(""),j=l=null,a.attachEvent&&function(){var a=b.createElement("div");a.innerHTML="";return a.childNodes.length!==1}()&&function(a,b){function s(a){var b=-1;while(++b +\ +\ +\ +\ + + + + + #{pageTitle pc} + <meta name="description" content=""> + <meta name="author" content=""> + + <meta name="viewport" content="width=device-width,initial-scale=1"> + + ^{pageHead pc} + + \<!--[if lt IE 9]> + \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> + \<![endif]--> + + <script> + document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); + <body> + <div id="container"> + <header> + <div id="main" role="main"> + ^{pageBody pc} + <footer> + + \<!-- Change UA-XXXXX-X to be your site's ID --> + <script> + window._gaq = [['_setAccount','UAXXXXXXXX1'],['_trackPageview'],['_trackPageLoadTime']]; + YepNope.load({ + \ load: ('https:' == location.protocol ? '//ssl' : '//www') + '.google-analytics.com/ga.js' + }); + \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started --> + \<!--[if lt IE 7 ]> + <script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js"> + <script> + window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})}) + \<![endif]--> diff -Nru haskell-yesod-0.6.7/scaffold/templates/default-layout.hamlet.cg haskell-yesod-0.9.3.4/scaffold/templates/default-layout.hamlet.cg --- haskell-yesod-0.6.7/scaffold/templates/default-layout.hamlet.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/default-layout.hamlet.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,4 @@ +$maybe msg <- mmsg + <div #message>#{msg} +^{widget} + diff -Nru haskell-yesod-0.6.7/scaffold/templates/default-layout.lucius.cg haskell-yesod-0.9.3.4/scaffold/templates/default-layout.lucius.cg --- haskell-yesod-0.6.7/scaffold/templates/default-layout.lucius.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/default-layout.lucius.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,4 @@ +body { + font-family: sans-serif; +} + diff -Nru haskell-yesod-0.6.7/scaffold/templates/default-layout-wrapper.hamlet.cg haskell-yesod-0.9.3.4/scaffold/templates/default-layout-wrapper.hamlet.cg --- haskell-yesod-0.6.7/scaffold/templates/default-layout-wrapper.hamlet.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/default-layout-wrapper.hamlet.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,8 @@ +!!! +<html> + <head + <title>#{pageTitle pc} + ^{pageHead pc} + <body + ^{pageBody pc} + diff -Nru haskell-yesod-0.6.7/scaffold/templates/homepage.hamlet.cg haskell-yesod-0.9.3.4/scaffold/templates/homepage.hamlet.cg --- haskell-yesod-0.6.7/scaffold/templates/homepage.hamlet.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/homepage.hamlet.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,2 @@ +<h1>_{MsgHello} +<h2 ##{h2id}>You do not have Javascript enabled. diff -Nru haskell-yesod-0.6.7/scaffold/templates/homepage.julius.cg haskell-yesod-0.9.3.4/scaffold/templates/homepage.julius.cg --- haskell-yesod-0.6.7/scaffold/templates/homepage.julius.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/homepage.julius.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,2 @@ +document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>"; + diff -Nru haskell-yesod-0.6.7/scaffold/templates/homepage.lucius.cg haskell-yesod-0.9.3.4/scaffold/templates/homepage.lucius.cg --- haskell-yesod-0.6.7/scaffold/templates/homepage.lucius.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/homepage.lucius.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,7 @@ +h1 { + text-align: center +} +h2##{h2id} { + color: #990 +} + diff -Nru haskell-yesod-0.6.7/scaffold/templates/normalize.lucius.cg haskell-yesod-0.9.3.4/scaffold/templates/normalize.lucius.cg --- haskell-yesod-0.6.7/scaffold/templates/normalize.lucius.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/templates/normalize.lucius.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,439 @@ +/*! normalize.css 2011-08-12T17:28 UTC · http://github.com/necolas/normalize.css */ + +/* ============================================================================= + HTML5 display definitions + ========================================================================== */ + +/* + * Corrects block display not defined in IE6/7/8/9 & FF3 + */ + +article, +aside, +details, +figcaption, +figure, +footer, +header, +hgroup, +nav, +section { + display: block; +} + +/* + * Corrects inline-block display not defined in IE6/7/8/9 & FF3 + */ + +audio, +canvas, +video { + display: inline-block; + *display: inline; + *zoom: 1; +} + +/* + * Prevents modern browsers from displaying 'audio' without controls + */ + +audio:not([controls]) { + display: none; +} + +/* + * Addresses styling for 'hidden' attribute not present in IE7/8/9, FF3, S4 + * Known issue: no IE6 support + */ + +[hidden] { + display: none; +} + + +/* ============================================================================= + Base + ========================================================================== */ + +/* + * 1. Corrects text resizing oddly in IE6/7 when body font-size is set using em units + * http://clagnut.com/blog/348/#c790 + * 2. Keeps page centred in all browsers regardless of content height + * 3. Prevents iOS text size adjust after orientation change, without disabling user zoom + * www.456bereastreet.com/archive/201012/controlling_text_size_in_safari_for_ios_without_disabling_user_zoom/ + */ + +html { + font-size: 100%; /* 1 */ + overflow-y: scroll; /* 2 */ + -webkit-text-size-adjust: 100%; /* 3 */ + -ms-text-size-adjust: 100%; /* 3 */ +} + +/* + * Addresses margins handled incorrectly in IE6/7 + */ + +body { + margin: 0; +} + +/* + * Addresses font-family inconsistency between 'textarea' and other form elements. + */ + +body, +button, +input, +select, +textarea { + font-family: sans-serif; +} + + +/* ============================================================================= + Links + ========================================================================== */ + +a { + color: #00e; +} + +a:visited { + color: #551a8b; +} + +/* + * Addresses outline displayed oddly in Chrome + */ + +a:focus { + outline: thin dotted; +} + +/* + * Improves readability when focused and also mouse hovered in all browsers + * people.opera.com/patrickl/experiments/keyboard/test + */ + +a:hover, +a:active { + outline: 0; +} + + +/* ============================================================================= + Typography + ========================================================================== */ + +/* + * Addresses styling not present in IE7/8/9, S5, Chrome + */ + +abbr[title] { + border-bottom: 1px dotted; +} + +/* + * Addresses style set to 'bolder' in FF3/4, S4/5, Chrome +*/ + +b, +strong { + font-weight: bold; +} + +blockquote { + margin: 1em 40px; +} + +/* + * Addresses styling not present in S5, Chrome + */ + +dfn { + font-style: italic; +} + +/* + * Addresses styling not present in IE6/7/8/9 + */ + +mark { + background: #ff0; + color: #000; +} + +/* + * Corrects font family set oddly in IE6, S4/5, Chrome + * en.wikipedia.org/wiki/User:Davidgothberg/Test59 + */ + +pre, +code, +kbd, +samp { + font-family: monospace, serif; + _font-family: 'courier new', monospace; + font-size: 1em; +} + +/* + * Improves readability of pre-formatted text in all browsers + */ + +pre { + white-space: pre; + white-space: pre-wrap; + word-wrap: break-word; +} + +/* + * 1. Addresses CSS quotes not supported in IE6/7 + * 2. Addresses quote property not supported in S4 + */ + +/* 1 */ + +q { + quotes: none; +} + +/* 2 */ + +q:before, +q:after { + content: ''; + content: none; +} + +small { + font-size: 75%; +} + +/* + * Prevents sub and sup affecting line-height in all browsers + * gist.github.com/413930 + */ + +sub, +sup { + font-size: 75%; + line-height: 0; + position: relative; + vertical-align: baseline; +} + +sup { + top: -0.5em; +} + +sub { + bottom: -0.25em; +} + + +/* ============================================================================= + Lists + ========================================================================== */ + +ul, +ol { + margin: 1em 0; + padding: 0 0 0 40px; +} + +dd { + margin: 0 0 0 40px; +} + +nav ul, +nav ol { + list-style: none; + list-style-image: none; +} + + +/* ============================================================================= + Embedded content + ========================================================================== */ + +/* + * 1. Removes border when inside 'a' element in IE6/7/8/9 + * 2. Improves image quality when scaled in IE7 + * code.flickr.com/blog/2008/11/12/on-ui-quality-the-little-things-client-side-image-resizing/ + */ + +img { + border: 0; /* 1 */ + -ms-interpolation-mode: bicubic; /* 2 */ +} + +/* + * Corrects overflow displayed oddly in IE9 + */ + +svg:not(:root) { + overflow: hidden; +} + + +/* ============================================================================= + Figures + ========================================================================== */ + +/* + * Addresses margin not present in IE6/7/8/9, S5, O11 + */ + +figure { + margin: 0; +} + + +/* ============================================================================= + Forms + ========================================================================== */ + +/* + * Corrects margin displayed oddly in IE6/7 + */ + +form { + margin: 0; +} + +/* + * Define consistent margin and padding + */ + +fieldset { + margin: 0 2px; + padding: 0.35em 0.625em 0.75em; +} + +/* + * 1. Corrects color not being inherited in IE6/7/8/9 + * 2. Corrects alignment displayed oddly in IE6/7 + */ + +legend { + border: 0; /* 1 */ + *margin-left: -7px; /* 2 */ +} + +/* + * 1. Corrects font size not being inherited in all browsers + * 2. Addresses margins set differently in IE6/7, F3/4, S5, Chrome + * 3. Improves appearance and consistency in all browsers + */ + +button, +input, +select, +textarea { + font-size: 100%; /* 1 */ + margin: 0; /* 2 */ + vertical-align: baseline; /* 3 */ + *vertical-align: middle; /* 3 */ +} + +/* + * 1. Addresses FF3/4 setting line-height using !important in the UA stylesheet + * 2. Corrects inner spacing displayed oddly in IE6/7 + */ + +button, +input { + line-height: normal; /* 1 */ + *overflow: visible; /* 2 */ +} + +/* + * Corrects overlap and whitespace issue for buttons and inputs in IE6/7 + * Known issue: reintroduces inner spacing + */ + +table button, +table input { + *overflow: auto; +} + +/* + * 1. Improves usability and consistency of cursor style between image-type 'input' and others + * 2. Corrects inability to style clickable 'input' types in iOS + */ + +button, +html input[type="button"], +input[type="reset"], +input[type="submit"] { + cursor: pointer; /* 1 */ + -webkit-appearance: button; /* 2 */ +} + +/* + * 1. Addresses box sizing set to content-box in IE8/9 + * 2. Addresses excess padding in IE8/9 + */ + +input[type="checkbox"], +input[type="radio"] { + box-sizing: border-box; /* 1 */ + padding: 0; /* 2 */ +} + +/* + * 1. Addresses appearance set to searchfield in S5, Chrome + * 2. Addresses box sizing set to border-box in S5, Chrome (include -moz to future-proof) + */ + +input[type="search"] { + -webkit-appearance: textfield; /* 1 */ + -moz-box-sizing: content-box; + -webkit-box-sizing: content-box; /* 2 */ + box-sizing: content-box; +} + +/* + * Corrects inner padding displayed oddly in S5, Chrome on OSX + */ + +input[type="search"]::-webkit-search-decoration { + -webkit-appearance: none; +} + +/* + * Corrects inner padding and border displayed oddly in FF3/4 + * www.sitepen.com/blog/2008/05/14/the-devils-in-the-details-fixing-dojos-toolbar-buttons/ + */ + +button::-moz-focus-inner, +input::-moz-focus-inner { + border: 0; + padding: 0; +} + +/* + * 1. Removes default vertical scrollbar in IE6/7/8/9 + * 2. Improves readability and alignment in all browsers + */ + +textarea { + overflow: auto; /* 1 */ + vertical-align: top; /* 2 */ +} + + +/* ============================================================================= + Tables + ========================================================================== */ + +/* + * Remove most spacing between table cells + */ + +table { + border-collapse: collapse; + border-spacing: 0; +} diff -Nru haskell-yesod-0.6.7/scaffold/tiny/Application.hs.cg haskell-yesod-0.9.3.4/scaffold/tiny/Application.hs.cg --- haskell-yesod-0.6.7/scaffold/tiny/Application.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/tiny/Application.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( with~sitearg~ + , withDevelAppPort + ) where + +import Import +import Settings +import Yesod.Static +import Yesod.Default.Config +import Yesod.Default.Main (defaultDevelApp, defaultRunner) +import Yesod.Default.Handlers (getFaviconR, getRobotsR) +import Yesod.Logger (Logger) +import Network.Wai (Application) +import Data.Dynamic (Dynamic, toDyn) + +-- Import all relevant handler modules here. +import Handler.Root + +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in Foundation.hs. Please see +-- the comments there for more details. +mkYesodDispatch "~sitearg~" resources~sitearg~ + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +with~sitearg~ :: AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO () +with~sitearg~ conf logger f = do +#ifdef PRODUCTION + s <- static Settings.staticDir +#else + s <- staticDevel Settings.staticDir +#endif + let h = ~sitearg~ conf logger s + defaultRunner f h + +-- for yesod devel +withDevelAppPort :: Dynamic +withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~ diff -Nru haskell-yesod-0.6.7/scaffold/tiny/config/routes.cg haskell-yesod-0.9.3.4/scaffold/tiny/config/routes.cg --- haskell-yesod-0.6.7/scaffold/tiny/config/routes.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/tiny/config/routes.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,7 @@ +/static StaticR Static getStatic + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET + diff -Nru haskell-yesod-0.6.7/scaffold/tiny/Foundation.hs.cg haskell-yesod-0.9.3.4/scaffold/tiny/Foundation.hs.cg --- haskell-yesod-0.6.7/scaffold/tiny/Foundation.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/tiny/Foundation.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,101 @@ +module Foundation + ( ~sitearg~ (..) + , ~sitearg~Route (..) + , ~sitearg~Message (..) + , resources~sitearg~ + , Handler + , Widget + , module Yesod.Core + , module Settings + , StaticRoute (..) + , lift + , liftIO + ) where + +import Prelude +import Yesod.Core +import Yesod.Default.Config +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Static (Static, base64md5, StaticRoute(..)) +import Settings.StaticFiles +import Yesod.Logger (Logger, logLazyText) +import qualified Settings +import Settings (widgetFile) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) +import Web.ClientSession (getKey) +import Text.Hamlet (hamletFile) + +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data ~sitearg~ = ~sitearg~ + { settings :: AppConfig DefaultEnv + , getLogger :: Logger + , getStatic :: Static -- ^ Settings for static file serving. + } + +-- Set up i18n messages. See the message folder. +mkMessage "~sitearg~" "messages" "en" + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://docs.yesodweb.com/book/web-routes-quasi/ +-- +-- This function does three things: +-- +-- * Creates the route datatype ~sitearg~Route. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route ~sitearg~ = ~sitearg~Route +-- * Creates the value resources~sitearg~ which contains information on the +-- resources declared below. This is used in Handler.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- ~sitearg~. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the ~sitearg~Route datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod ~sitearg~ where + approot = appRoot . settings + + -- Place the session key file in the config folder + encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + + defaultLayout widget = do + mmsg <- getMessage + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + pc <- widgetToPageContent $ do + $(widgetFile "normalize") + $(widgetFile "default-layout") + hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticroot setting in Settings.hs + urlRenderOverride y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s + urlRenderOverride _ _ = Nothing + + messageLogger y loc level msg = + formatLogMessage loc level msg >>= logLazyText (getLogger y) + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent = addStaticContentExternal (const $ Left ()) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) + + -- Enable Javascript async loading + yepnopeJs _ = Just $ Right $ StaticR js_modernizr_js diff -Nru haskell-yesod-0.6.7/scaffold/tiny/project.cabal.cg haskell-yesod-0.9.3.4/scaffold/tiny/project.cabal.cg --- haskell-yesod-0.6.7/scaffold/tiny/project.cabal.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/tiny/project.cabal.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,80 @@ +name: ~project~ +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: ~name~ +maintainer: ~name~ +synopsis: The greatest Yesod web application ever. +description: I'm sure you can say something clever here if you try. +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://~project~.yesodweb.com/ + +Flag production + Description: Build the production executable. + Default: False + +Flag devel + Description: Build for use with "yesod devel" + Default: False + +library + if flag(devel) + Buildable: True + else + Buildable: False + exposed-modules: Application + other-modules: Foundation + Import + Settings + Settings.StaticFiles + Handler.Root + + ghc-options: -Wall -threaded -O0 + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded -O0 + + main-is: main.hs + + extensions: TemplateHaskell + QuasiQuotes + OverloadedStrings + NoImplicitPrelude + CPP + OverloadedStrings + MultiParamTypeClasses + TypeFamilies + + build-depends: base >= 4 && < 5 + , yesod-core >= 0.9.3 && < 0.10 + , yesod-static >= 0.3.1 && < 0.4 + , yesod-default >= 0.4 && < 0.5 + , clientsession >= 0.7.3 && < 0.8 + , bytestring >= 0.9 && < 0.10 + , text >= 0.11 && < 0.12 + , template-haskell + , hamlet >= 0.10 && < 0.11 + , shakespeare-text >= 0.10 && < 0.11 + , wai >= 0.4.2 && < 0.5 + , transformers >= 0.2 && < 0.3 + , monad-control >= 0.3 && < 0.4 + diff -Nru haskell-yesod-0.6.7/scaffold/tiny/Settings.hs.cg haskell-yesod-0.9.3.4/scaffold/tiny/Settings.hs.cg --- haskell-yesod-0.6.7/scaffold/tiny/Settings.hs.cg 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/tiny/Settings.hs.cg 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,45 @@ +-- | Settings are centralized, as much as possible, into this file. This +-- includes database connection settings, static file locations, etc. +-- In addition, you can configure a number of different aspects of Yesod +-- by overriding methods in the Yesod typeclass. That instance is +-- declared in the ~project~.hs file. +module Settings + ( widgetFile + , staticRoot + , staticDir + ) where + +import Prelude (FilePath, String) +import Text.Shakespeare.Text (st) +import Language.Haskell.TH.Syntax +import Yesod.Default.Config +import qualified Yesod.Default.Util +import Data.Text (Text) + +-- | The location of static files on your system. This is a file system +-- path. The default value works properly with your scaffolded site. +staticDir :: FilePath +staticDir = "static" + +-- | The base URL for your static files. As you can see by the default +-- value, this can simply be "static" appended to your application root. +-- A powerful optimization can be serving static files from a separate +-- domain name. This allows you to use a web server optimized for static +-- files, more easily set expires and cache values, and avoid possibly +-- costly transference of cookies on static files. For more information, +-- please see: +-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain +-- +-- If you change the resource pattern for StaticR in ~project~.hs, you will +-- have to make a corresponding change here. +-- +-- To see how this value is used, see urlRenderOverride in ~project~.hs +staticRoot :: AppConfig DefaultEnv -> Text +staticRoot conf = [~qq~st|#{appRoot conf}/static|] + +widgetFile :: String -> Q Exp +#if PRODUCTION +widgetFile = Yesod.Default.Util.widgetFileProduction +#else +widgetFile = Yesod.Default.Util.widgetFileDebug +#endif diff -Nru haskell-yesod-0.6.7/scaffold/welcome.cg haskell-yesod-0.9.3.4/scaffold/welcome.cg --- haskell-yesod-0.6.7/scaffold/welcome.cg 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold/welcome.cg 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -Welcome to the Yesod scaffolder. -I'm going to be creating a skeleton Yesod project for you. - -What is your name? We're going to put this in the cabal and LICENSE files. - -Your name: diff -Nru haskell-yesod-0.6.7/scaffold.hs haskell-yesod-0.9.3.4/scaffold.hs --- haskell-yesod-0.6.7/scaffold.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/scaffold.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -import CodeGen -import System.IO -import System.Directory -import qualified Data.ByteString.Char8 as S -import Language.Haskell.TH.Syntax -import Data.Time (getCurrentTime, utctDay, toGregorian) -import Control.Applicative ((<$>)) -import qualified Data.ByteString.Lazy as L -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -qq :: String -#if GHC7 -qq = "" -#else -qq = "$" -#endif - -main :: IO () -main = do - putStr $(codegen "welcome") - hFlush stdout - name <- getLine - - putStr $(codegen "project-name") - hFlush stdout - project <- getLine - - putStr $(codegen "dir-name") - hFlush stdout - dirRaw <- getLine - let dir = if null dirRaw then project else dirRaw - - putStr $(codegen "site-arg") - hFlush stdout - sitearg <- getLine - - putStr $(codegen "database") - hFlush stdout - backendS <- getLine - let pconn1 = $(codegen "pconn1") - let pconn2 = $(codegen "pconn2") - let (lower, upper, connstr1, connstr2) = - case backendS of - "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3") - "p" -> ("postgresql", "Postgresql", pconn1, pconn2) - _ -> error $ "Invalid backend: " ++ backendS - - putStrLn "That's it! I'm creating your files now..." - - let fst3 (x, _, _) = x - year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime - - let writeFile' fp s = do - putStrLn $ "Generating " ++ fp - L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s - mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp - - mkDir "Handler" - mkDir "hamlet" - mkDir "cassius" - mkDir "julius" - - writeFile' "simple-server.hs" $(codegen "simple-server_hs") - writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") - writeFile' "devel-server.hs" $(codegen "devel-server_hs") - writeFile' (project ++ ".cabal") $(codegen "cabal") - writeFile' "LICENSE" $(codegen "LICENSE") - writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs") - writeFile' "Controller.hs" $(codegen "Controller_hs") - writeFile' "Handler/Root.hs" $(codegen "Root_hs") - writeFile' "Model.hs" $(codegen "Model_hs") - writeFile' "Settings.hs" $(codegen "Settings_hs") - writeFile' "cassius/default-layout.cassius" - $(codegen "default-layout_cassius") - writeFile' "hamlet/default-layout.hamlet" - $(codegen "default-layout_hamlet") - writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet") - writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") - writeFile' "julius/homepage.julius" $(codegen "homepage_julius") - - S.writeFile (dir ++ "/favicon.ico") - $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do - pack <- [|S.pack|] - return $ pack `AppE` LitE (StringL $ S.unpack bs)) diff -Nru haskell-yesod-0.6.7/Scaffolding/CodeGen.hs haskell-yesod-0.9.3.4/Scaffolding/CodeGen.hs --- haskell-yesod-0.6.7/Scaffolding/CodeGen.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/Scaffolding/CodeGen.hs 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | A code generation template haskell. Everything is taken as literal text, +-- with ~var~ variable interpolation. +module Scaffolding.CodeGen (codegen, codegenDir) where + +import Language.Haskell.TH.Syntax +import Text.ParserCombinators.Parsec +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +data Token = VarToken String | LitToken String | EmptyToken + +codegenDir :: FilePath -> FilePath -> Q Exp +codegenDir dir fp = do + s' <- qRunIO $ L.readFile $ (dir ++ "/" ++ fp ++ ".cg") + let s = init $ LT.unpack $ LT.decodeUtf8 s' + case parse (many parseToken) s s of + Left e -> error $ show e + Right tokens' -> do + let tokens'' = map toExp tokens' + concat' <- [|concat|] + return $ concat' `AppE` ListE tokens'' + +codegen :: FilePath -> Q Exp +codegen fp = codegenDir "scaffold" fp + +toExp :: Token -> Exp +toExp (LitToken s) = LitE $ StringL s +toExp (VarToken s) = VarE $ mkName s +toExp EmptyToken = LitE $ StringL "" + +parseToken :: Parser Token +parseToken = + parseVar <|> parseLit + where + parseVar = do + _ <- char '~' + s <- many alphaNum + _ <- char '~' + return $ if null s then EmptyToken else VarToken s + parseLit = do + s <- many1 $ noneOf "~" + return $ LitToken s diff -Nru haskell-yesod-0.6.7/Scaffolding/Scaffolder.hs haskell-yesod-0.9.3.4/Scaffolding/Scaffolder.hs --- haskell-yesod-0.6.7/Scaffolding/Scaffolder.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-yesod-0.9.3.4/Scaffolding/Scaffolder.hs 2011-12-05 11:31:07.000000000 +0000 @@ -0,0 +1,202 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Scaffolding.Scaffolder (scaffold) where + +import Scaffolding.CodeGen + +import Language.Haskell.TH.Syntax +import Control.Monad (unless) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.ByteString.Lazy as L +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 as S +import Data.Time (getCurrentTime, utctDay, toGregorian) +import Data.Char (toLower) +import System.Directory +import System.IO + +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 + +qq :: String +#if __GLASGOW_HASKELL__ >= 700 +qq = "" +#else +qq = "$" +#endif + +data Backend = Sqlite | Postgresql | MongoDB | Tiny + deriving (Eq, Read, Show, Enum, Bounded) + +puts :: String -> IO () +puts s = putStr s >> hFlush stdout + +backends :: [Backend] +backends = [minBound .. maxBound] + + +scaffold :: IO () +scaffold = do + puts $(codegenDir "input" "welcome") + name <- getLine + + puts $(codegenDir "input" "project-name") + let validPN c + | 'A' <= c && c <= 'Z' = True + | 'a' <= c && c <= 'z' = True + | '0' <= c && c <= '9' = True + validPN '-' = True + validPN _ = False + project <- prompt $ all validPN + let dir = project + + puts $(codegenDir "input" "site-arg") + let isUpperAZ c = 'A' <= c && c <= 'Z' + sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main" + + puts $(codegenDir "input" "database") + + backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends + let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) = + case backendC of + "s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlSettings") + "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlSettings") + "m" -> (MongoDB, "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }") + "t" -> (Tiny, "","","",undefined) + _ -> error $ "Invalid backend: " ++ backendC + (modelImports) = case backend of + MongoDB -> "import Database.Persist." ++ importGenericDB ++ "\nimport Language.Haskell.TH.Syntax" + Sqlite -> "" + Postgresql -> "" + Tiny -> undefined + + uncapitalize s = toLower (head s) : tail s + backendLower = uncapitalize $ show backend + upper = show backend + + let runMigration = + case backend of + MongoDB -> "" + _ -> "\n Database.Persist.Base.runPool dbconf (runMigration migrateAll) p" + + let importMigration = + case backend of + MongoDB -> "" + _ -> "\nimport Database.Persist.GenericSql (runMigration)" + + let dbConfigFile = + case backend of + MongoDB -> "mongoDB" + Sqlite -> "sqlite" + Postgresql -> "postgresql" + Tiny -> error "Accessing dbConfigFile for Tiny" + + let configPersist = + case backend of + MongoDB -> "MongoConf" + Sqlite -> "SqliteConf" + Postgresql -> "PostgresConf" + Tiny -> error "Accessing configPersist for Tiny" + + putStrLn "That's it! I'm creating your files now..." + + let withConnectionPool = case backend of + Sqlite -> $(codegen $ "sqliteConnPool") + Postgresql -> $(codegen $ "postgresqlConnPool") + MongoDB -> $(codegen $ "mongoDBConnPool") + Tiny -> "" + + packages = + if backend == MongoDB + then " , persistent-mongoDB >= 0.6.1 && < 0.7\n , mongoDB >= 1.1\n , bson >= 0.1.5\n" + else " , persistent-" ++ backendLower ++ " >= 0.6 && < 0.7" + + monadControlVersion = + if backend == MongoDB + then "== 0.2.*" + else "== 0.3.*" + + + let fst3 (x, _, _) = x + year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime + + let writeFile' fp s = do + putStrLn $ "Generating " ++ fp + L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s + mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp + + mkDir "Handler" + mkDir "templates" + mkDir "static" + mkDir "static/css" + mkDir "static/js" + mkDir "config" + mkDir "Model" + mkDir "deploy" + mkDir "Settings" + mkDir "messages" + + writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") + + case backend of + Sqlite -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml")) + Postgresql -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml")) + MongoDB -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/mongoDB.yml")) + Tiny -> return () + + let isTiny = backend == Tiny + ifTiny a b = if isTiny then a else b + + writeFile' ("config/settings.yml") $(codegen "config/settings.yml") + writeFile' ("main.hs") $(codegen "main.hs") + writeFile' (project ++ ".cabal") $ ifTiny $(codegen "tiny/project.cabal") $(codegen "project.cabal") + writeFile' ".ghci" $(codegen ".ghci") + writeFile' "LICENSE" $(codegen "LICENSE") + writeFile' ("Foundation.hs") $ ifTiny $(codegen "tiny/Foundation.hs") $(codegen "Foundation.hs") + writeFile' "Import.hs" $(codegen "Import.hs") + writeFile' "Application.hs" $ ifTiny $(codegen "tiny/Application.hs") $(codegen "Application.hs") + writeFile' "Handler/Root.hs" $(codegen "Handler/Root.hs") + unless isTiny $ writeFile' "Model.hs" $(codegen "Model.hs") + writeFile' "Settings.hs" $ ifTiny $(codegen "tiny/Settings.hs") $(codegen "Settings.hs") + writeFile' "Settings/StaticFiles.hs" $(codegen "Settings/StaticFiles.hs") + writeFile' "templates/default-layout.lucius" + $(codegen "templates/default-layout.lucius") + writeFile' "templates/default-layout.hamlet" + $(codegen "templates/default-layout.hamlet") + writeFile' "templates/default-layout-wrapper.hamlet" + $(codegen "templates/default-layout-wrapper.hamlet") + writeFile' "templates/boilerplate-wrapper.hamlet" + $(codegen "templates/boilerplate-wrapper.hamlet") + writeFile' "templates/normalize.lucius" + $(codegen "templates/normalize.lucius") + writeFile' "templates/homepage.hamlet" + $(codegen "templates/homepage.hamlet") + writeFile' "config/routes" $ ifTiny $(codegen "tiny/config/routes") $(codegen "config/routes") + writeFile' "templates/homepage.lucius" + $(codegen "templates/homepage.lucius") + writeFile' "templates/homepage.julius" + $(codegen "templates/homepage.julius") + unless isTiny $ writeFile' "config/models" $(codegen "config/models") + writeFile' "messages/en.msg" $(codegen "messages/en.msg") + + S.writeFile (dir ++ "/static/js/modernizr.js") + $(runIO (S.readFile "scaffold/static/js/modernizr.js.cg") >>= \bs -> + [|S.pack $(return $ LitE $ StringL $ S.unpack bs)|]) + + S.writeFile (dir ++ "/config/favicon.ico") + $(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do + pack <- [|S.pack|] + return $ pack `AppE` LitE (StringL $ S.unpack bs)) + + S.writeFile (dir ++ "/config/robots.txt") + $(runIO (S.readFile "scaffold/config/robots.txt.cg") >>= \bs -> do + [|S.pack $(return $ LitE $ StringL $ S.unpack bs)|]) + + puts $(codegenDir "input" "done") diff -Nru haskell-yesod-0.6.7/Setup.lhs haskell-yesod-0.9.3.4/Setup.lhs --- haskell-yesod-0.6.7/Setup.lhs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Setup.lhs 2011-12-05 11:31:07.000000000 +0000 @@ -2,10 +2,6 @@ > module Main where > import Distribution.Simple -> import System.Cmd (system) > main :: IO () -> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) - -> runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return () +> main = defaultMain diff -Nru haskell-yesod-0.6.7/Yesod/Content.hs haskell-yesod-0.9.3.4/Yesod/Content.hs --- haskell-yesod-0.6.7/Yesod/Content.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Content.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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" diff -Nru haskell-yesod-0.6.7/Yesod/Dispatch.hs haskell-yesod-0.9.3.4/Yesod/Dispatch.hs --- haskell-yesod-0.6.7/Yesod/Dispatch.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Dispatch.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Form/Class.hs haskell-yesod-0.9.3.4/Yesod/Form/Class.hs --- haskell-yesod-0.6.7/Yesod/Form/Class.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Class.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Form/Core.hs haskell-yesod-0.9.3.4/Yesod/Form/Core.hs --- haskell-yesod-0.6.7/Yesod/Form/Core.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Core.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Form/Fields.hs haskell-yesod-0.9.3.4/Yesod/Form/Fields.hs --- haskell-yesod-0.6.7/Yesod/Form/Fields.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Fields.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 -|] diff -Nru haskell-yesod-0.6.7/Yesod/Form/Jquery.hs haskell-yesod-0.9.3.4/Yesod/Form/Jquery.hs --- haskell-yesod-0.6.7/Yesod/Form/Jquery.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Jquery.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 - } diff -Nru haskell-yesod-0.6.7/Yesod/Form/Nic.hs haskell-yesod-0.9.3.4/Yesod/Form/Nic.hs --- haskell-yesod-0.6.7/Yesod/Form/Nic.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Nic.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Form/Profiles.hs haskell-yesod-0.9.3.4/Yesod/Form/Profiles.hs --- haskell-yesod-0.6.7/Yesod/Form/Profiles.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form/Profiles.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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$ -|] - } diff -Nru haskell-yesod-0.6.7/Yesod/Form.hs haskell-yesod-0.9.3.4/Yesod/Form.hs --- haskell-yesod-0.6.7/Yesod/Form.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Form.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Hamlet.hs haskell-yesod-0.9.3.4/Yesod/Hamlet.hs --- haskell-yesod-0.6.7/Yesod/Hamlet.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Hamlet.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Hamlet - ( -- * Hamlet library - -- ** Hamlet - hamlet - , xhamlet - , Hamlet - , Html - , renderHamlet - , renderHtml - , string - , preEscapedString - , cdata - -- ** Julius - , julius - , Julius - , renderJulius - -- ** Cassius - , cassius - , Cassius - , renderCassius - -- * Convert to something displayable - , hamletToContent - , hamletToRepHtml - -- * Page templates - , PageContent (..) - ) - where - -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Content -import Yesod.Handler - --- | Content for a web page. By providing this datatype, we can easily create --- generic site templates, which would have the type signature: --- --- > PageContent url -> Hamlet url -data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: Hamlet url - , pageBody :: Hamlet url - } - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ renderHamlet render h - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent diff -Nru haskell-yesod-0.6.7/Yesod/Handler.hs haskell-yesod-0.9.3.4/Yesod/Handler.hs --- haskell-yesod-0.6.7/Yesod/Handler.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Handler.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Helpers/AtomFeed.hs haskell-yesod-0.9.3.4/Yesod/Helpers/AtomFeed.hs --- haskell-yesod-0.6.7/Yesod/Helpers/AtomFeed.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Helpers/AtomFeed.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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$ -|] diff -Nru haskell-yesod-0.6.7/Yesod/Helpers/Crud.hs haskell-yesod-0.9.3.4/Yesod/Helpers/Crud.hs --- haskell-yesod-0.6.7/Yesod/Helpers/Crud.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Helpers/Crud.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 - } diff -Nru haskell-yesod-0.6.7/Yesod/Helpers/Sitemap.hs haskell-yesod-0.9.3.4/Yesod/Helpers/Sitemap.hs --- haskell-yesod-0.6.7/Yesod/Helpers/Sitemap.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Helpers/Sitemap.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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) diff -Nru haskell-yesod-0.6.7/Yesod/Helpers/Static.hs haskell-yesod-0.9.3.4/Yesod/Helpers/Static.hs --- haskell-yesod-0.6.7/Yesod/Helpers/Static.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Helpers/Static.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Internal.hs haskell-yesod-0.9.3.4/Yesod/Internal.hs --- haskell-yesod-0.6.7/Yesod/Internal.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Internal.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Normal users should never need access to these. -module Yesod.Internal - ( -- * Error responses - ErrorResponse (..) - -- * Header - , Header (..) - -- * Cookie names - , langKey - -- * Widgets - , Location (..) - , UniqueList (..) - , Script (..) - , Stylesheet (..) - , Title (..) - , Head (..) - , Body (..) - , locationToHamlet - , runUniqueList - , toUnique - -- * UTF8 helpers - , bsToChars - , lbsToChars - , charsToBs - ) where - -import Text.Hamlet (Hamlet, hamlet, Html) -import Data.Monoid (Monoid (..)) -import Data.List (nub) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | Responses to indicate some form of an error occurred. These are different --- from 'SpecialResponse' in that they allow for custom error pages. -data ErrorResponse = - NotFound - | InternalError String - | InvalidArgs [String] - | PermissionDenied String - | BadMethod String - deriving (Show, Eq) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - deriving (Eq, Show) - -langKey :: String -langKey = "_LANG" - -data Location url = Local url | Remote String - deriving (Show, Eq) -locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [HAMLET|@url@|] -locationToHamlet (Remote s) = [HAMLET|$s$|] - -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -newtype Script url = Script { unScript :: Location url } - deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } - -newtype Head url = Head (Hamlet url) - deriving Monoid -newtype Body url = Body (Hamlet url) - deriving Monoid - -lbsToChars :: L.ByteString -> String -lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode - -bsToChars :: S.ByteString -> String -bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode - -charsToBs :: String -> S.ByteString -charsToBs = T.encodeUtf8 . T.pack diff -Nru haskell-yesod-0.6.7/Yesod/Json.hs haskell-yesod-0.9.3.4/Yesod/Json.hs --- haskell-yesod-0.6.7/Yesod/Json.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Json.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Request.hs haskell-yesod-0.9.3.4/Yesod/Request.hs --- haskell-yesod-0.6.7/Yesod/Request.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Request.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/Yesod/Widget.hs haskell-yesod-0.9.3.4/Yesod/Widget.hs --- haskell-yesod-0.6.7/Yesod/Widget.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Widget.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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) diff -Nru haskell-yesod-0.6.7/Yesod/Yesod.hs haskell-yesod-0.9.3.4/Yesod/Yesod.hs --- haskell-yesod-0.6.7/Yesod/Yesod.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod/Yesod.hs 1970-01-01 00:00:00.000000000 +0000 @@ -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 diff -Nru haskell-yesod-0.6.7/yesod.cabal haskell-yesod-0.9.3.4/yesod.cabal --- haskell-yesod-0.6.7/yesod.cabal 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/yesod.cabal 2011-12-05 11:31:07.000000000 +0000 @@ -1,113 +1,125 @@ name: yesod -version: 0.6.7 +version: 0.9.3.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Creation of type-safe, RESTful web applications. description: - Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. + A RESTful web framework with strong compile-time guarantees of correctness. It also affords space efficient code, highly concurrent loads, and portability to many deployment backends (via the wai package), from CGI to stand-alone serving. . - The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. + Yesod also focuses on developer productivity. Yesod integrates well with tools for all your basic web development (wai, persistent, and shakespeare/hamlet) + . + The Yesod documentation site <http://www.yesodweb.com/> has much more information, including on the supporting packages mentioned above. category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple -homepage: http://docs.yesodweb.com/ -extra-source-files: scaffold/*.cg +homepage: http://www.yesodweb.com/ + +extra-source-files: + input/*.cg + scaffold/templates/default-layout.lucius.cg + scaffold/templates/homepage.lucius.cg + scaffold/Model.hs.cg + scaffold/Import.hs.cg + scaffold/Foundation.hs.cg + scaffold/LICENSE.cg + scaffold/mongoDBConnPool.cg + scaffold/tiny/Foundation.hs.cg + scaffold/tiny/project.cabal.cg + scaffold/tiny/Application.hs.cg + scaffold/tiny/config/routes.cg + scaffold/tiny/Settings.hs.cg + scaffold/templates/normalize.lucius.cg + scaffold/postgresqlConnPool.cg + scaffold/sqliteConnPool.cg + scaffold/.ghci.cg + scaffold/project.cabal.cg + scaffold/Application.hs.cg + scaffold/templates/homepage.julius.cg + scaffold/templates/homepage.hamlet.cg + scaffold/templates/default-layout.hamlet.cg + scaffold/templates/default-layout-wrapper.hamlet.cg + scaffold/templates/boilerplate-wrapper.hamlet.cg + scaffold/deploy/Procfile.cg + scaffold/main.hs.cg + scaffold/Handler/Root.hs.cg + scaffold/config/models.cg + scaffold/config/sqlite.yml.cg + scaffold/config/settings.yml.cg + scaffold/config/favicon.ico.cg + scaffold/config/postgresql.yml.cg + scaffold/config/mongoDB.yml.cg + scaffold/config/routes.cg + scaffold/config/robots.txt.cg + scaffold/Settings.hs.cg + scaffold/Settings/StaticFiles.hs.cg + scaffold/messages/en.msg.cg + scaffold/static/js/modernizr.js.cg -flag test - description: Build the executable to run unit tests - default: False flag ghc7 +flag threaded + default: True + description: Build with support for multithreaded execution + 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 - , 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 + build-depends: base >= 4 && < 4.3 + build-depends: yesod-core >= 0.9.3.4 && < 0.10 + , yesod-auth >= 0.7 && < 0.8 + , yesod-json >= 0.2.2 && < 0.3 + , yesod-persistent >= 0.2 && < 0.3 + , yesod-form >= 0.3 && < 0.4 + , monad-control >= 0.2 && < 0.4 + , transformers >= 0.2.2 && < 0.3 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4.1 && < 0.5 + , hamlet >= 0.10 && < 0.11 + , shakespeare-js >= 0.10 && < 0.11 + , shakespeare-css >= 0.10 && < 0.11 + , warp >= 0.4 && < 0.5 + , blaze-html >= 0.4.1.3 && < 0.5 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 + if os(windows) + cpp-options: -DWINDOWS + build-depends: parsec >= 2.1 && < 4 + , text >= 0.11 && < 0.12 + , shakespeare-text >= 0.10 && < 0.11 + , bytestring >= 0.9.1.4 && < 0.10 + , time >= 1.1.4 + , template-haskell + , directory >= 1.0 && < 1.2 + , Cabal >= 1.8 && < 1.13 + , unix-compat >= 0.2 && < 0.4 + , containers >= 0.2 && < 0.5 + , attoparsec >= 0.10 + , http-types >= 0.6.1 && < 0.7 + , blaze-builder >= 0.2.1.4 && < 0.4 + , filepath >= 1.1 && < 1.3 + , process 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 + if flag(threaded) + ghc-options: -threaded + main-is: main.hs + other-modules: Scaffolding.CodeGen + Scaffolding.Scaffolder + Devel + Build source-repository head type: git - location: git://github.com/snoyberg/yesod.git + location: git://github.com/yesodweb/yesod.git diff -Nru haskell-yesod-0.6.7/Yesod.hs haskell-yesod-0.9.3.4/Yesod.hs --- haskell-yesod-0.6.7/Yesod.hs 2010-12-13 21:26:37.000000000 +0000 +++ haskell-yesod-0.9.3.4/Yesod.hs 2011-12-05 11:31:07.000000000 +0000 @@ -1,47 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | This module simply re-exports from other modules for your convenience. module Yesod - ( module Yesod.Request - , module Yesod.Content - , module Yesod.Yesod - , module Yesod.Handler - , module Yesod.Dispatch + ( -- * Re-exports from yesod-core + module Yesod.Core , 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 +#if MIN_VERSION_monad_control(0, 3, 0) + , MonadBaseControl +#else + , MonadControlIO +#endif + -- * Utilities , showIntegral , readIntegral + -- * Hamlet library + -- ** Hamlet + , hamlet + , xhamlet + , HtmlUrl + , Html + , toHtml + -- ** Julius + , julius + , JavascriptUrl + , renderJavascriptUrl + -- ** Cassius/Lucius + , cassius + , lucius + , CssUrl + , renderCssUrl ) 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.Handler hiding (runHandler) -#endif +import Yesod.Core +import Text.Hamlet +import Text.Cassius +import Text.Lucius +import Text.Julius -import Yesod.Request import Yesod.Form -import Yesod.Widget +import Yesod.Json +import Yesod.Persist import Network.Wai (Application) -import Yesod.Hamlet +import Network.Wai.Middleware.Debug import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) -import Control.Monad.Invert (MonadInvertIO) +#if MIN_VERSION_monad_control(0, 3, 0) +import Control.Monad.Trans.Control (MonadBaseControl) +#else +import Control.Monad.IO.Control (MonadControlIO) +#endif + +import Network.Wai.Handler.Warp (run) +import System.IO (stderr, hPutStrLn) +import Text.Blaze (toHtml) showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -51,3 +72,40 @@ 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 () + +develServer port modu func = + mapM_ putStrLn + [ "Due to issues with GHC 7.0.2, you must now run the devel server" + , "separately. To do so, ensure you have installed the " + , "wai-handler-devel package >= 0.2.1 and run:" + , concat + [ " wai-handler-devel " + , show port + , " " + , modu + , " " + , func + , " --yesod" + ] + , "" + ] +