diff --git a/yesod/.gitignore b/yesod/.gitignore new file mode 100644 index 00000000..08e46243 --- /dev/null +++ b/yesod/.gitignore @@ -0,0 +1,7 @@ +/dist/ +*.swp +client_session_key.aes +*.hi +*.o +blog.db3 +static/tmp/ diff --git a/yesod/CodeGen.hs b/yesod/CodeGen.hs new file mode 100644 index 00000000..878159ad --- /dev/null +++ b/yesod/CodeGen.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | A code generation template haskell. Everything is taken as literal text, +-- with ~var~ variable interpolation. +module 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 --git a/yesod/LICENSE b/yesod/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/yesod/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod/README b/yesod/README new file mode 100644 index 00000000..f98ab5ec --- /dev/null +++ b/yesod/README @@ -0,0 +1,3 @@ +After installing, type "yesod init" to start a new project. + +Learn more at http://www.yesodweb.com/book diff --git a/yesod/Scaffold/Build.hs b/yesod/Scaffold/Build.hs new file mode 100644 index 00000000..64202dc4 --- /dev/null +++ b/yesod/Scaffold/Build.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scaffold.Build + ( touch + , getDeps + , touchDeps + , findHaskellFiles + ) where + +-- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) + +import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) +import Data.List (isSuffixOf) +import qualified Data.Attoparsec.Text.Lazy as A +import qualified Data.Text.Lazy.IO as TIO +import Control.Applicative ((<|>)) +import Data.Char (isSpace) +import Data.Monoid (mappend) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) +import Control.Monad (filterM, forM) +import Control.Exception (SomeException, try) + +-- | Touch any files with altered dependencies but do not build +touch :: IO () +touch = do + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + let deps = fixDeps $ zip hss deps' + touchDeps deps + +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 :: Deps -> IO () +touchDeps = + mapM_ go . Map.toList + where + go (x, ys) = do + (_, mod1) <- getFileStatus' x + flip mapM_ (Set.toList ys) $ \y -> do + (access, mod2) <- getFileStatus' y + if mod2 < mod1 + then do + putStrLn $ "Touching " ++ y ++ " because of " ++ x + _ <- try' $ setFileTimes y access mod1 + return () + else return () + +try' :: IO x -> IO (Either SomeException x) +try' = try + +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 "dist" = 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 (A.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, "hamlet/" ++ 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 "tmp" = 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 --git a/yesod/Scaffold/Devel.hs b/yesod/Scaffold/Devel.hs new file mode 100644 index 00000000..ebd82a04 --- /dev/null +++ b/yesod/Scaffold/Devel.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scaffold.Devel + ( devel + ) where + +import qualified Distribution.Simple.Build as B +import Distribution.Simple.Configure (configure) +import Distribution.Simple (defaultMainArgs) +import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags) +import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Verbosity (normal) +import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo) +import Distribution.PackageDescription (FlagName (FlagName), package, emptyHookedBuildInfo) +import Distribution.Simple.LocalBuildInfo (localPkgDescr) +import Scaffold.Build (getDeps, touchDeps, findHaskellFiles) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Debug (debug) +import Distribution.Text (display) +import Distribution.Simple.Install (install) +import Distribution.Simple.Register (register) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Exception (try, SomeException, finally) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import qualified Data.Map as Map +import System.Posix.Types (EpochTime) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Network.Wai (Application, Response (ResponseBuilder), responseLBS) +import Network.HTTP.Types (status500) +import Control.Monad (when, forever) +import System.Process (runCommand, terminateProcess, getProcessExitCode, waitForProcess) +import qualified Data.IORef as I +import qualified Data.ByteString.Lazy.Char8 as L +import System.Directory (doesFileExist, removeFile, getDirectoryContents) +import Distribution.Package (PackageName (..), pkgName) +import Data.Maybe (mapMaybe) + +appMessage :: L.ByteString -> IO () +appMessage l = forever $ do + -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l + threadDelay 10000 + +swapApp :: I.IORef ThreadId -> IO ThreadId -> IO () +swapApp i f = do + I.readIORef i >>= killThread + f >>= I.writeIORef i + +devel :: ([String] -> IO ()) -- ^ cabal + -> IO () +devel cabalCmd = do + e <- doesFileExist "dist/devel-flag" + when e $ removeFile "dist/devel-flag" + listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef + + cabal <- defaultPackageDesc normal + gpd <- readPackageDescription normal cabal + + mhpd <- defaultHookedPackageDesc + hooked <- + case mhpd of + Nothing -> return emptyHookedBuildInfo + Just fp -> readHookedBuildInfo normal fp + + cabalCmd ["configure", "-fdevel"] + + let myTry :: IO () -> IO () + myTry f = try f >>= \x -> case x of + Left e -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (e :: SomeException) + Right y -> return y + let getNewApp :: IO () + getNewApp = myTry $ do + putStrLn "Rebuilding app" + swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait" + + deps <- getDeps + touchDeps deps + + cabalCmd ["build"] + defaultMainArgs ["install"] + + pi' <- getPackageName + writeFile "dist/devel.hs" $ unlines + [ "{-# LANGUAGE PackageImports #-}" + , concat + [ "import \"" + , pi' + , "\" Controller (withDevelApp)" + ] + , "import Data.Dynamic (fromDynamic)" + , "import Network.Wai.Handler.Warp (run)" + , "import Network.Wai.Middleware.Debug (debug)" + , "import Data.Maybe (fromJust)" + , "import Control.Concurrent (forkIO)" + , "import System.Directory (doesFileExist, removeFile)" + , "import Control.Concurrent (threadDelay)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Starting app\"" + , " forkIO $ (fromJust $ fromDynamic withDevelApp) $ run 3000" + , " loop" + , "" + , "loop :: IO ()" + , "loop = do" + , " threadDelay 100000" + , " e <- doesFileExist \"dist/devel-flag\"" + , " if e then removeFile \"dist/devel-flag\" else loop" + ] + swapApp listenThread $ forkIO $ do + putStrLn "Calling runghc..." + ph <- runCommand "runghc dist/devel.hs" + let forceType :: Either SomeException () -> () + forceType = const () + fmap forceType $ try sleepForever + writeFile "dist/devel-flag" "" + putStrLn "Terminating external process" + terminateProcess ph + putStrLn "Process terminated" + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec + + loop Map.empty getNewApp + +sleepForever :: IO () +sleepForever = forever $ threadDelay 1000000 + +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) + +loop :: FileList -> IO () -> IO () +loop oldList getNewApp = do + newList <- getFileList + when (newList /= oldList) getNewApp + threadDelay 1000000 + loop newList getNewApp + +errApp :: String -> Application +errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s + +getPackageName :: IO String +getPackageName = do + xs <- getDirectoryContents "." + case mapMaybe (toCabal . reverse) xs of + [x] -> return x + [] -> error "No cabal files found" + _ -> error "Too many cabal files found" + where + toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x + toCabal _ = Nothing diff --git a/yesod/Setup.lhs b/yesod/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod/Yesod.hs b/yesod/Yesod.hs new file mode 100644 index 00000000..b1546520 --- /dev/null +++ b/yesod/Yesod.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-- | This module simply re-exports from other modules for your convenience. +module Yesod + ( -- * Re-exports from yesod-core + module Yesod.Core + , module Yesod.Form + , module Yesod.Json + , module Yesod.Persist + -- * Running your application + , warp + , warpDebug + , develServer + -- * Commonly referenced functions/datatypes + , Application + , lift + , liftIO + , MonadControlIO + -- * Utilities + , showIntegral + , readIntegral + -- * Hamlet library + -- ** Hamlet + , hamlet + , xhamlet + , Hamlet + , Html + , renderHamlet + , renderHtml + , string + , preEscapedString + , cdata + , toHtml + -- ** Julius + , julius + , Julius + , renderJulius + -- ** Cassius + , cassius + , Cassius + , renderCassius + ) where + +import Yesod.Core +import Text.Hamlet +import Text.Cassius +import Text.Julius + +import Yesod.Form +import Yesod.Json +import Yesod.Persist +import Network.Wai (Application) +import Network.Wai.Middleware.Debug +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Control (MonadControlIO) + +import Network.Wai.Handler.Warp (run) +import System.IO (stderr, hPutStrLn) + +showIntegral :: Integral a => a -> String +showIntegral x = show (fromIntegral x :: Integer) + +readIntegral :: Num a => String -> Maybe a +readIntegral s = + 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" + ] + , "" + ] + diff --git a/yesod/development.md b/yesod/development.md new file mode 100644 index 00000000..531621ea --- /dev/null +++ b/yesod/development.md @@ -0,0 +1,23 @@ +# Scaffolding + +## Test suite + +install the shelltest package: cabal install shelltests + +Run this from the project root directory. It will make sure each site type builds. It first does an sdist, which ensures we are testing what will be put on hackage. + + tests/run.sh + +Give it the --debug flag to see all output + +## Quicker, repeatable site building + +Useful for debugging individual failures. + + tests/runscaffold.sh < sqlite-input.txt + +## Getting a list of scaffold files for the cabal file + +It is necessary after adding a scaffolding file to add it to the list of files in the cabal file. + + find scaffold -type f diff --git a/yesod/input/database.cg b/yesod/input/database.cg new file mode 100644 index 00000000..198c20ac --- /dev/null +++ b/yesod/input/database.cg @@ -0,0 +1,9 @@ +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. + +We also have a new option: a mini project. This is a site with minimal +dependencies. In particular: no database, no authentication. + +So, what'll it be? s for sqlite, p for postgresql, m for mini: diff --git a/yesod/input/dir-name.cg b/yesod/input/dir-name.cg new file mode 100644 index 00000000..dc74c147 --- /dev/null +++ b/yesod/input/dir-name.cg @@ -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 --git a/yesod/input/project-name.cg b/yesod/input/project-name.cg new file mode 100644 index 00000000..a9742993 --- /dev/null +++ b/yesod/input/project-name.cg @@ -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 --git a/yesod/input/site-arg.cg b/yesod/input/site-arg.cg new file mode 100644 index 00000000..f49604c5 --- /dev/null +++ b/yesod/input/site-arg.cg @@ -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 --git a/yesod/input/welcome.cg b/yesod/input/welcome.cg new file mode 100644 index 00000000..ac3742a7 --- /dev/null +++ b/yesod/input/welcome.cg @@ -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 --git a/yesod/scaffold.hs b/yesod/scaffold.hs new file mode 100644 index 00000000..23a1f1c1 --- /dev/null +++ b/yesod/scaffold.hs @@ -0,0 +1,154 @@ +{-# 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 +import Control.Monad (when, unless) +import System.Environment (getArgs) + +import Scaffold.Build (touch) +import Scaffold.Devel (devel) + +import System.Process (rawSystem) + +qq :: String +#if __GLASGOW_HASKELL__ >= 700 +qq = "" +#else +qq = "$" +#endif + +prompt :: (String -> Bool) -> IO String +prompt f = do + s <- getLine + if f s + then return s + else do + putStrLn "That was not a valid entry, please try again: " + prompt f + +main :: IO () +main = do + args' <- getArgs + let (isDev, args) = + case args' of + "--dev":rest -> (True, rest) + _ -> (False, args') + let cmd = if isDev then "cabal-dev" else "cabal" + let cabal rest = rawSystem cmd rest >> return () + let conf rest = cabal $ "configure":rest + let build rest = cabal $ "build":rest + case args of + ["init"] -> scaffold + "build":rest -> touch >> build rest + ["touch"] -> touch + ["devel"] -> devel cabal + "configure":rest -> conf rest + _ -> 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)" + putStrLn " touch Touch any files with altered TH dependencies but do not build" + putStrLn " devel Run project with the devel server" + +puts :: String -> IO () +puts s = putStr s >> hFlush stdout + +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") + backendS <- prompt $ flip elem ["s", "p", "m"] + let pconn1 = $(codegen "pconn1") + let (backendLower, upper, connstr, importDB) = + case backendS of + "s" -> ("sqlite", "Sqlite", " return database", "import Database.Persist.Sqlite\n") + "p" -> ("postgresql", "Postgresql", pconn1, "import Database.Persist.Postgresql\n") + "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "") + _ -> 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 "lucius" + mkDir "julius" + mkDir "static" + mkDir "static/css" + mkDir "static/js" + mkDir "config" + mkDir "Model" + mkDir "deploy" + + writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") + + case backendS of + "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml")) + "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml")) + "m" -> return () + _ -> error $ "Invalid backend: " ++ backendS + + writeFile' ("config/settings.yml") $(codegen "config/settings.yml") + writeFile' ("config/" ++ project ++ ".hs") $(codegen "project.hs") + writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini/cabal") else $(codegen "cabal") + writeFile' ".ghci" $(codegen ".ghci") + writeFile' "LICENSE" $(codegen "LICENSE") + writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini/sitearg.hs") else $(codegen "sitearg.hs") + writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini/Controller.hs") else $(codegen "Controller.hs") + writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini/Handler/Root.hs") else $(codegen "Handler/Root.hs") + when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model.hs") + writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini/config/Settings.hs") else $(codegen "config/Settings.hs") + writeFile' "config/StaticFiles.hs" $(codegen "config/StaticFiles.hs") + writeFile' "cassius/default-layout.cassius" + $(codegen "cassius/default-layout.cassius") + writeFile' "hamlet/default-layout.hamlet" + $(codegen "hamlet/default-layout.hamlet") + writeFile' "hamlet/boilerplate-layout.hamlet" + $(codegen "hamlet/boilerplate-layout.hamlet") + writeFile' "static/css/html5boilerplate.css" + $(codegen "static/css/html5boilerplate.css") + writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini/hamlet/homepage.hamlet") else $(codegen "hamlet/homepage.hamlet") + writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini/config/routes") else $(codegen "config/routes") + writeFile' "cassius/homepage.cassius" $(codegen "cassius/homepage.cassius") + writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius") + unless (backendS == "m") $ writeFile' "config/models" $(codegen "config/models") + + 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)) + diff --git a/yesod/scaffold/.ghci.cg b/yesod/scaffold/.ghci.cg new file mode 100644 index 00000000..44fa6f76 --- /dev/null +++ b/yesod/scaffold/.ghci.cg @@ -0,0 +1,2 @@ +:set -i.:config:dist/build/autogen + diff --git a/yesod/scaffold/Controller.hs.cg b/yesod/scaffold/Controller.hs.cg new file mode 100644 index 00000000..ff405232 --- /dev/null +++ b/yesod/scaffold/Controller.hs.cg @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( with~sitearg~ + , withDevelApp + ) where + +import ~sitearg~ +import Settings +import Yesod.Helpers.Static +import Yesod.Helpers.Auth +import Database.Persist.GenericSql +import Data.ByteString (ByteString) +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 ~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" "config/favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a +with~sitearg~ conf f = do + Settings.withConnectionPool conf $ \p -> do + runConnectionPool (runMigration migrateAll) p + let h = ~sitearg~ conf s p + toWaiApp h >>= f + where + s = static Settings.staticDir + +with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a +with~sitearg~LoadConfig env f = do + conf <- Settings.loadConfig env + withFoobar conf f + +-- for yesod devel +withDevelApp :: Dynamic +withDevelApp = do + toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ()) + diff --git a/yesod/scaffold/Handler/Root.hs.cg b/yesod/scaffold/Handler/Root.hs.cg new file mode 100644 index 00000000..cb0375e7 --- /dev/null +++ b/yesod/scaffold/Handler/Root.hs.cg @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, 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 +-- 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 + mu <- maybeAuth + defaultLayout $ do + h2id <- lift newIdent + setTitle "~project~ homepage" + addWidget $(widgetFile "homepage") diff --git a/yesod/scaffold/LICENSE.cg b/yesod/scaffold/LICENSE.cg new file mode 100644 index 00000000..7830a89e --- /dev/null +++ b/yesod/scaffold/LICENSE.cg @@ -0,0 +1,26 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright ~year~, ~name~. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/yesod/scaffold/Model.hs.cg b/yesod/scaffold/Model.hs.cg new file mode 100644 index 00000000..ba2130ac --- /dev/null +++ b/yesod/scaffold/Model.hs.cg @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell #-} +module Model where + +import Yesod +import Data.Text (Text) + +-- 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, mkMigrate "migrateAll"] $(persistFile "config/models") + diff --git a/yesod/scaffold/cabal.cg b/yesod/scaffold/cabal.cg new file mode 100644 index 00000000..67b8b7b2 --- /dev/null +++ b/yesod/scaffold/cabal.cg @@ -0,0 +1,70 @@ +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: Controller + hs-source-dirs: ., config + other-modules: ~sitearg~ + Model + Settings + StaticFiles + Handler.Root + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded + + main-is: config/~project~.hs + hs-source-dirs: ., config + + build-depends: base >= 4 && < 5 + , yesod >= 0.8 && < 0.9 + , yesod-auth >= 0.4 && < 0.5 + , yesod-static >= 0.1 && < 0.2 + , mime-mail + , clientsession + , wai-extra + , directory + , bytestring + , text + , persistent + , persistent-template + , persistent-~backendLower~ >= 0.5 && < 0.6 + , template-haskell + , hamlet + , hjsmin + , transformers + , data-object + , data-object-yaml + , warp + , blaze-builder + , cmdargs diff --git a/yesod/scaffold/cassius/default-layout.cassius.cg b/yesod/scaffold/cassius/default-layout.cassius.cg new file mode 100644 index 00000000..77177469 --- /dev/null +++ b/yesod/scaffold/cassius/default-layout.cassius.cg @@ -0,0 +1,3 @@ +body + font-family: sans-serif + diff --git a/yesod/scaffold/cassius/homepage.cassius.cg b/yesod/scaffold/cassius/homepage.cassius.cg new file mode 100644 index 00000000..2ac20924 --- /dev/null +++ b/yesod/scaffold/cassius/homepage.cassius.cg @@ -0,0 +1,5 @@ +h1 + text-align: center +h2##{h2id} + color: #990 + diff --git a/yesod/scaffold/config/Settings.hs.cg b/yesod/scaffold/config/Settings.hs.cg new file mode 100644 index 00000000..956b0c5f --- /dev/null +++ b/yesod/scaffold/config/Settings.hs.cg @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | 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 + , luciusFile + , widgetFile + , ConnectionPool + , withConnectionPool + , runConnectionPool + , staticRoot + , staticDir + , loadConfig + , AppEnvironment(..) + , AppConfig(..) + ) where + +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import qualified Text.Lucius as H +import Language.Haskell.TH.Syntax +~importDB~ +import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius) +import Data.Monoid (mempty, mappend) +import System.Directory (doesFileExist) +import Prelude hiding (concat) +import Data.Text (Text, snoc, append, pack, concat) +import Data.Object +import qualified Data.Object.Yaml as YAML +import Control.Monad (join) + +data AppEnvironment = Test + | Development + | Staging + | Production + deriving (Eq, Show, Read, Enum, Bounded) + +-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. +-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments). +-- +-- By convention these settings should be overwritten by any command line arguments. +-- See config/~sitearg~.hs for command line arguments +-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku). +-- +data AppConfig = AppConfig { + appEnv :: AppEnvironment + + , appPort :: Int + + -- | 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. + -- + -- 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. + , connectionPoolSize :: Int + + -- | 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. + -- Please note that there is no trailing slash. + -- + -- You probably want to change this! If your domain name was "yesod.com", + -- you would probably want it to be: + -- > "http://yesod.com" + , appRoot :: Text +} deriving (Show) + +loadConfig :: AppEnvironment -> IO AppConfig +loadConfig env = do + allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + appPortS <- lookupScalar "appPort" settings + appRootS <- lookupScalar "appRoot" settings + connectionPoolSizeS <- lookupScalar "connectionPoolSize" settings + return $ AppConfig { + appEnv = env + , appPort = read $ appPortS + , appRoot = read $ (show appRootS) + , connectionPoolSize = read $ connectionPoolSizeS + } + +-- 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 ~sitearg~.hs, you will +-- have to make a corresponding change here. +-- +-- To see how this value is used, see urlRenderOverride in ~sitearg~.hs +staticRoot :: AppConfig -> Text +staticRoot conf = (appRoot conf) `mappend` "/static" + + +-- The rest of this file contains settings which rarely need changing by a +-- user. + +-- The next 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. +runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +-- | The database connection string. The meaning of this string is backend- +-- specific. +loadConnStr :: AppEnvironment -> IO Text +loadConnStr env = do + allSettings <- (join $ YAML.decodeFile ("config/~backendLower~.yml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + database <- lookupScalar "database" settings +~connstr~ + +withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a +withConnectionPool conf f = do + cs <- liftIO $ loadConnStr (appEnv conf) + with~upper~Pool cs (connectionPoolSize conf) 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 + + +-- 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. + +-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/ +globFile :: String -> String -> FilePath +globFile kind x = kind ++ "/" ++ x ++ "." ++ kind + +hamletFile :: FilePath -> Q Exp +hamletFile = H.hamletFile . globFile "hamlet" + +cassiusFile :: FilePath -> Q Exp +cassiusFile = +#ifdef PRODUCTION + H.cassiusFile . globFile "cassius" +#else + H.cassiusFileDebug . globFile "cassius" +#endif + +luciusFile :: FilePath -> Q Exp +luciusFile = +#ifdef PRODUCTION + H.luciusFile . globFile "lucius" +#else + H.luciusFileDebug . globFile "lucius" +#endif + +juliusFile :: FilePath -> Q Exp +juliusFile = +#ifdef PRODUCTION + H.juliusFile . globFile "julius" +#else + H.juliusFileDebug . globFile "julius" +#endif + +widgetFile :: FilePath -> Q Exp +widgetFile x = do + let h = unlessExists (globFile "hamlet") hamletFile + let c = unlessExists (globFile "cassius") cassiusFile + let j = unlessExists (globFile "julius") juliusFile + let l = unlessExists (globFile "lucius") luciusFile + [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] + where + unlessExists tofn f = do + e <- qRunIO $ doesFileExist $ tofn x + if e then f x else [|mempty|] diff --git a/yesod/scaffold/config/StaticFiles.hs.cg b/yesod/scaffold/config/StaticFiles.hs.cg new file mode 100644 index 00000000..1de80de6 --- /dev/null +++ b/yesod/scaffold/config/StaticFiles.hs.cg @@ -0,0 +1,11 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module StaticFiles where + +import Yesod.Helpers.Static + +-- | 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 --git a/yesod/scaffold/config/favicon.ico.cg b/yesod/scaffold/config/favicon.ico.cg new file mode 100644 index 00000000..283cccf0 Binary files /dev/null and b/yesod/scaffold/config/favicon.ico.cg differ diff --git a/yesod/scaffold/config/models.cg b/yesod/scaffold/config/models.cg new file mode 100644 index 00000000..0fafb17a --- /dev/null +++ b/yesod/scaffold/config/models.cg @@ -0,0 +1,10 @@ +User + ident Text + password Text Maybe Update + UniqueUser ident +Email + email Text + user UserId Maybe Update + verkey Text Maybe Update + UniqueEmail email + diff --git a/yesod/scaffold/config/postgresql.yml.cg b/yesod/scaffold/config/postgresql.yml.cg new file mode 100644 index 00000000..28926dab --- /dev/null +++ b/yesod/scaffold/config/postgresql.yml.cg @@ -0,0 +1,20 @@ +Default: &defaults + user: ~project~ + password: ~project~ + host: localhost + port: 5432 + database: ~project~ + +Development: + <<: *defaults + +Test: + database: ~project~_test + <<: *defaults + +Staging: + <<: *defaults + +Production: + database: ~project~_production + <<: *defaults diff --git a/yesod/scaffold/config/routes.cg b/yesod/scaffold/config/routes.cg new file mode 100644 index 00000000..7a0bb067 --- /dev/null +++ b/yesod/scaffold/config/routes.cg @@ -0,0 +1,7 @@ +/static StaticR Static getStatic +/auth AuthR Auth getAuth + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET diff --git a/yesod/scaffold/config/settings.yml.cg b/yesod/scaffold/config/settings.yml.cg new file mode 100644 index 00000000..38053042 --- /dev/null +++ b/yesod/scaffold/config/settings.yml.cg @@ -0,0 +1,16 @@ +Default: &defaults + appRoot: http://localhost + appPort: 3000 + connectionPoolSize: 10 + +Development: + <<: *defaults + +Test: + <<: *defaults + +Staging: + <<: *defaults + +Production: + <<: *defaults diff --git a/yesod/scaffold/config/sqlite.yml.cg b/yesod/scaffold/config/sqlite.yml.cg new file mode 100644 index 00000000..ec25b88e --- /dev/null +++ b/yesod/scaffold/config/sqlite.yml.cg @@ -0,0 +1,16 @@ +Default: &defaults + database: ~project~.sqlite3 + +Development: + <<: *defaults + +Test: + database: ~project~_test.sqlite3 + <<: *defaults + +Staging: + <<: *defaults + +Production: + database: ~project~_production.sqlite3 + <<: *defaults diff --git a/yesod/scaffold/deploy/Procfile.cg b/yesod/scaffold/deploy/Procfile.cg new file mode 100644 index 00000000..3f79f92c --- /dev/null +++ b/yesod/scaffold/deploy/Procfile.cg @@ -0,0 +1,47 @@ +# Simple and 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. +# +# Yesod setup: +# +# * Move this file out of the deploy directory and into your root directory +# +# mv deploy/Procfile ./ +# +# * Create an empty Gemfile and Gemfile.lock +# +# touch Gemfile && touch Gemfile.lock +# +# * TODO: 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 +# +# 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 add ./dist/build/~project~/~project~ +# +# * push to Heroku +# +# git push heroku deploy:master + + +# Heroku configuration that runs your app +web: ./dist/build/~project~/~project~ -p $PORT diff --git a/yesod/scaffold/hamlet/boilerplate-layout.hamlet.cg b/yesod/scaffold/hamlet/boilerplate-layout.hamlet.cg new file mode 100644 index 00000000..4e59cda3 --- /dev/null +++ b/yesod/scaffold/hamlet/boilerplate-layout.hamlet.cg @@ -0,0 +1,30 @@ +\M +\^M +\^M +\^M +\^M +\ +^M + + + + + + + + + #{pageTitle pc} + + <link rel="stylesheet" href=@{StaticR css_html5boilerplate_css}> + ^{pageHead pc} + + <!--[if lt IE 9]> + <script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> + <![endif]-->^M + + <script> + document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); + <body> + $maybe msg <- mmsg + <div #message>#{msg} + ^{pageBody pc} diff --git a/yesod/scaffold/hamlet/default-layout.hamlet.cg b/yesod/scaffold/hamlet/default-layout.hamlet.cg new file mode 100644 index 00000000..f31acb19 --- /dev/null +++ b/yesod/scaffold/hamlet/default-layout.hamlet.cg @@ -0,0 +1,10 @@ +!!! +<html + <head + <title>#{pageTitle pc} + ^{pageHead pc} + <body + $maybe msg <- mmsg + <div #message>#{msg} + ^{pageBody pc} + diff --git a/yesod/scaffold/hamlet/homepage.hamlet.cg b/yesod/scaffold/hamlet/homepage.hamlet.cg new file mode 100644 index 00000000..727f0eb6 --- /dev/null +++ b/yesod/scaffold/hamlet/homepage.hamlet.cg @@ -0,0 +1,13 @@ +<h1>Hello +<h2 ##{h2id}>You do not have Javascript enabled. +$maybe u <- mu + <p + You are logged in as #{userIdent $ snd u}. # + <a href=@{AuthR LogoutR}>Logout + . +$nothing + <p + You are not logged in. # + <a href=@{AuthR LoginR}>Login now + . + diff --git a/yesod/scaffold/julius/homepage.julius.cg b/yesod/scaffold/julius/homepage.julius.cg new file mode 100644 index 00000000..9b38774d --- /dev/null +++ b/yesod/scaffold/julius/homepage.julius.cg @@ -0,0 +1,4 @@ +window.onload = function(){ + document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>"; +} + diff --git a/yesod/scaffold/mini/Controller.hs.cg b/yesod/scaffold/mini/Controller.hs.cg new file mode 100644 index 00000000..c895acd0 --- /dev/null +++ b/yesod/scaffold/mini/Controller.hs.cg @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( with~sitearg~ + , withDevelApp + ) where + +import ~sitearg~ +import Settings +import Yesod.Helpers.Static +import Data.ByteString (ByteString) +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 ~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" "config/favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a +with~sitearg~ conf f = do + let h = ~sitearg~ conf s + toWaiApp h >>= f + where + s = static Settings.staticDir + +with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a +with~sitearg~LoadConfig env f = do + conf <- Settings.loadConfig env + withFoobar conf f + +withDevelApp :: Dynamic +withDevelApp = do + toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ()) + diff --git a/yesod/scaffold/mini/Handler/Root.hs.cg b/yesod/scaffold/mini/Handler/Root.hs.cg new file mode 100644 index 00000000..53b7a397 --- /dev/null +++ b/yesod/scaffold/mini/Handler/Root.hs.cg @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, 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 +-- 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" + addWidget $(widgetFile "homepage") diff --git a/yesod/scaffold/mini/cabal.cg b/yesod/scaffold/mini/cabal.cg new file mode 100644 index 00000000..20d3381f --- /dev/null +++ b/yesod/scaffold/mini/cabal.cg @@ -0,0 +1,68 @@ +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: Controller + hs-source-dirs: ., config + other-modules: ~sitearg~ + Settings + StaticFiles + Handler.Root + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded + + main-is: config/~project~.hs + hs-source-dirs: ., config + + build-depends: base >= 4 && < 5 + , yesod-core >= 0.8 && < 0.9 + , yesod-static + , clientsession + , wai-extra + , directory + , bytestring + , text + , template-haskell + , hamlet + , transformers + , data-object + , data-object-yaml + , wai + , warp + , blaze-builder + , cmdargs + , data-object + , data-object-yaml + ghc-options: -Wall -threaded + diff --git a/yesod/scaffold/mini/config/Settings.hs.cg b/yesod/scaffold/mini/config/Settings.hs.cg new file mode 100644 index 00000000..10d4ef28 --- /dev/null +++ b/yesod/scaffold/mini/config/Settings.hs.cg @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | 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 + ( hamletFile + , cassiusFile + , juliusFile + , luciusFile + , widgetFile + , staticRoot + , staticDir + , loadConfig + , AppEnvironment(..) + , AppConfig(..) + ) where + +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import qualified Text.Lucius as H +import Language.Haskell.TH.Syntax +import Yesod.Widget (addWidget, addCassius, addJulius, addLucius) +import Data.Monoid (mempty, mappend) +import System.Directory (doesFileExist) +import Data.Text (Text) +import Data.Object +import qualified Data.Object.Yaml as YAML +import Control.Monad (join) + +data AppEnvironment = Test + | Development + | Staging + | Production + deriving (Eq, Show, Read, Enum, Bounded) + +-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. +-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments). +-- +-- By convention these settings should be overwritten by any command line arguments. +-- See config/~sitearg~.hs for command line arguments +-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku). +-- +data AppConfig = AppConfig { + appEnv :: AppEnvironment + + , appPort :: Int + + -- | 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. + -- Please note that there is no trailing slash. + -- + -- You probably want to change this! If your domain name was "yesod.com", + -- you would probably want it to be: + -- > "http://yesod.com" + , appRoot :: Text +} deriving (Show) + +loadConfig :: AppEnvironment -> IO AppConfig +loadConfig env = do + allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + appPortS <- lookupScalar "appPort" settings + appRootS <- lookupScalar "appRoot" settings + return $ AppConfig { + appEnv = env + , appPort = read $ appPortS + , appRoot = read $ (show appRootS) + } + +-- | 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 -> Text +staticRoot conf = (appRoot conf) `mappend` "/static" + +-- 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, toLuciusFile :: String -> FilePath +toHamletFile x = "hamlet/" ++ x ++ ".hamlet" +toCassiusFile x = "cassius/" ++ x ++ ".cassius" +toJuliusFile x = "julius/" ++ x ++ ".julius" +toLuciusFile x = "lucius/" ++ x ++ ".lucius" + +hamletFile :: FilePath -> Q Exp +hamletFile = H.hamletFile . toHamletFile + +cassiusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +cassiusFile = H.cassiusFile . toCassiusFile +#else +cassiusFile = H.cassiusFileDebug . toCassiusFile +#endif + +luciusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +luciusFile = H.luciusFile . toLuciusFile +#else +luciusFile = H.luciusFileDebug . toLuciusFile +#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 + let l = unlessExists toLuciusFile luciusFile + [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] + where + unlessExists tofn f = do + e <- qRunIO $ doesFileExist $ tofn x + if e then f x else [|mempty|] diff --git a/yesod/scaffold/mini/config/routes.cg b/yesod/scaffold/mini/config/routes.cg new file mode 100644 index 00000000..f8eb4921 --- /dev/null +++ b/yesod/scaffold/mini/config/routes.cg @@ -0,0 +1,7 @@ +/static StaticR Static getStatic + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET + diff --git a/yesod/scaffold/mini/hamlet/homepage.hamlet.cg b/yesod/scaffold/mini/hamlet/homepage.hamlet.cg new file mode 100644 index 00000000..34432b74 --- /dev/null +++ b/yesod/scaffold/mini/hamlet/homepage.hamlet.cg @@ -0,0 +1,2 @@ +<h1>Hello +<h2 ##{h2id}>You do not have Javascript enabled. diff --git a/yesod/scaffold/mini/sitearg.hs.cg b/yesod/scaffold/mini/sitearg.hs.cg new file mode 100644 index 00000000..64763598 --- /dev/null +++ b/yesod/scaffold/mini/sitearg.hs.cg @@ -0,0 +1,99 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module ~sitearg~ + ( ~sitearg~ (..) + , ~sitearg~Route (..) + , resources~sitearg~ + , Handler + , Widget + , module Yesod.Core + , module Settings + , StaticRoute (..) + , lift + , liftIO + ) where + +import Yesod.Core +import Yesod.Helpers.Static +import qualified Settings +import System.Directory +import qualified Data.ByteString.Lazy as L +import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile) +import StaticFiles +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Web.ClientSession (getKey) + +-- | 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 :: Settings.AppConfig + , getStatic :: Static -- ^ Settings for static file serving. + } + +-- | 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~" $(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 = Settings.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 + 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 y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s + urlRenderOverride _ _ = Nothing + + -- 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 ++ '.' : T.unpack ext' + 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", T.pack fn] [], []) diff --git a/yesod/scaffold/pconn1.cg b/yesod/scaffold/pconn1.cg new file mode 100644 index 00000000..370aa79d --- /dev/null +++ b/yesod/scaffold/pconn1.cg @@ -0,0 +1,5 @@ + connPart <- fmap concat $ (flip mapM) ["user", "password", "host", "port"] $ \key -> do + value <- lookupScalar key settings + return $ append (snoc (pack key) '=') (snoc value ' ') + return $ append connPart (append " dbname= " database) + diff --git a/yesod/scaffold/project.hs.cg b/yesod/scaffold/project.hs.cg new file mode 100644 index 00000000..a7c76af1 --- /dev/null +++ b/yesod/scaffold/project.hs.cg @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +import qualified Settings as Settings +import Settings (AppConfig(..)) +import Controller (with~sitearg~) +import Network.Wai.Handler.Warp (run) +import System.Console.CmdArgs hiding (args) +import Data.Char (toUpper, toLower) + +#if PRODUCTION +#else +import System.IO (hPutStrLn, stderr) +import Network.Wai.Middleware.Debug (debug) +#endif + +main :: IO () +main = do + args <- cmdArgs argConfig + env <- getAppEnv args + config <- Settings.loadConfig env + let c = if (port args) /= 0 then config {appPort = (port args) } else config +#if PRODUCTION + with~sitearg~ c $ run (appPort c) +#else + hPutStrLn stderr $ (show env) ++ " application launched, listening on port " ++ show (appPort c) + with~sitearg~ c $ run (appPort c) . debug +#endif + +data ArgConfig = ArgConfig {environment :: String, port :: Int} + deriving (Show, Data, Typeable) + +argConfig = ArgConfig{ environment = def + &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments)) + &= typ "ENVIRONMENT" + ,port = def &= typ "PORT" +} + +environments :: [String] +environments = map ((map toLower) . show) ([minBound..maxBound] :: [Settings.AppEnvironment]) + +-- | retrieve the -e environment option +getAppEnv :: ArgConfig -> IO Settings.AppEnvironment +getAppEnv cfg = do + let e = if (environment cfg) /= "" then (environment cfg) + else +#if PRODUCTION + "production" +#else + "development" +#endif + return $ read $ capitalize e + where + capitalize [] = [] + capitalize (x:xs) = toUpper x : map toLower xs diff --git a/yesod/scaffold/sitearg.hs.cg b/yesod/scaffold/sitearg.hs.cg new file mode 100644 index 00000000..0bd383dc --- /dev/null +++ b/yesod/scaffold/sitearg.hs.cg @@ -0,0 +1,213 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +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 Database.Persist.GenericSql +import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile) +import Model +import StaticFiles +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) +import qualified Data.Text as T +import Web.ClientSession (getKey) + +-- | 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 :: Settings.AppConfig + , 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://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 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~" $(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 = Settings.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 + 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 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 + + -- 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 ++ '.' : T.unpack 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", T.pack fn] [], []) + +-- How to run database actions. +instance YesodPersist ~sitearg~ where + type YesodDB ~sitearg~ = SqlPersist + runDB db = liftIOHandler + $ 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 + + authPlugins = [ authOpenId + , authEmail + ] + +instance YesodAuthEmail ~sitearg~ where + type AuthEmailId ~sitearg~ = EmailId + + 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.unlines + [ "Please confirm your email address by clicking on the link below." + , "" + , Data.Text.Lazy.fromChunks [verurl] + , "" + , "Thank you" + ] + , partHeaders = [] + } + htmlPart = Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = renderHtml [~qq~hamlet| +<p>Please confirm your email address by clicking on the link below. +<p> + <a href=#{verurl}>#{verurl} +<p>Thank you +|] + , partHeaders = [] + } + 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 --git a/yesod/scaffold/static/css/html5boilerplate.css.cg b/yesod/scaffold/static/css/html5boilerplate.css.cg new file mode 100644 index 00000000..e24c3d37 --- /dev/null +++ b/yesod/scaffold/static/css/html5boilerplate.css.cg @@ -0,0 +1,116 @@ +/* HTML5 ✰ Boilerplate */ + +html, body, div, span, object, iframe, +h1, h2, h3, h4, h5, h6, p, blockquote, pre, +abbr, address, cite, code, del, dfn, em, img, ins, kbd, q, samp, +small, strong, sub, sup, var, b, i, dl, dt, dd, ol, ul, li, +fieldset, form, label, legend, +table, caption, tbody, tfoot, thead, tr, th, td, +article, aside, canvas, details, figcaption, figure, +footer, header, hgroup, menu, nav, section, summary, +time, mark, audio, video { + margin: 0; + padding: 0; + border: 0; + font-size: 100%; + font: inherit; + vertical-align: baseline; +} + +article, aside, details, figcaption, figure, +footer, header, hgroup, menu, nav, section { + display: block; +} + +blockquote, q { quotes: none; } +blockquote:before, blockquote:after, +q:before, q:after { content: ''; content: none; } +ins { background-color: #ff9; color: #000; text-decoration: none; } +mark { background-color: #ff9; color: #000; font-style: italic; font-weight: bold; } +del { text-decoration: line-through; } +abbr[title], dfn[title] { border-bottom: 1px dotted; cursor: help; } +table { border-collapse: collapse; border-spacing: 0; } +hr { display: block; height: 1px; border: 0; border-top: 1px solid #ccc; margin: 1em 0; padding: 0; } +input, select { vertical-align: middle; } + +body { font:13px/1.231 sans-serif; *font-size:small; } +select, input, textarea, button { font:99% sans-serif; } +pre, code, kbd, samp { font-family: monospace, sans-serif; } + +html { overflow-y: scroll; } +a:hover, a:active { outline: none; } +ul, ol { margin-left: 2em; } +ol { list-style-type: decimal; } +nav ul, nav li { margin: 0; list-style:none; list-style-image: none; } +small { font-size: 85%; } +strong, th { font-weight: bold; } +td { vertical-align: top; } + +sub, sup { font-size: 75%; line-height: 0; position: relative; } +sup { top: -0.5em; } +sub { bottom: -0.25em; } + +pre { white-space: pre; white-space: pre-wrap; word-wrap: break-word; padding: 15px; } +textarea { overflow: auto; } +.ie6 legend, .ie7 legend { margin-left: -7px; } +input[type="radio"] { vertical-align: text-bottom; } +input[type="checkbox"] { vertical-align: bottom; } +.ie7 input[type="checkbox"] { vertical-align: baseline; } +.ie6 input { vertical-align: text-bottom; } +label, input[type="button"], input[type="submit"], input[type="image"], button { cursor: pointer; } +button, input, select, textarea { margin: 0; } +input:valid, textarea:valid { } +input:invalid, textarea:invalid { border-radius: 1px; -moz-box-shadow: 0px 0px 5px red; -webkit-box-shadow: 0px 0px 5px red; box-shadow: 0px 0px 5px red; } +.no-boxshadow input:invalid, .no-boxshadow textarea:invalid { background-color: #f0dddd; } + +::-moz-selection{ background: #FF5E99; color:#fff; text-shadow: none; } +::selection { background:#FF5E99; color:#fff; text-shadow: none; } +a:link { -webkit-tap-highlight-color: #FF5E99; } + +button { width: auto; overflow: visible; } +.ie7 img { -ms-interpolation-mode: bicubic; } + +body, select, input, textarea { color: #444; } +h1, h2, h3, h4, h5, h6 { font-weight: bold; } +a, a:active, a:visited { color: #607890; } +a:hover { color: #036; } + +.ir { display: block; text-indent: -999em; overflow: hidden; background-repeat: no-repeat; text-align: left; direction: ltr; } +.hidden { display: none; visibility: hidden; } +.visuallyhidden { border: 0; clip: rect(0 0 0 0); height: 1px; margin: -1px; overflow: hidden; padding: 0; position: absolute; width: 1px; } +.visuallyhidden.focusable:active, +.visuallyhidden.focusable:focus { clip: auto; height: auto; margin: 0; overflow: visible; position: static; width: auto; } +.invisible { visibility: hidden; } +.clearfix:before, .clearfix:after { content: "\0020"; display: block; height: 0; overflow: hidden; } +.clearfix:after { clear: both; } +.clearfix { zoom: 1; } + + +@media all and (orientation:portrait) { + +} + +@media all and (orientation:landscape) { + +} + +@media screen and (max-device-width: 480px) { + + /* html { -webkit-text-size-adjust:none; -ms-text-size-adjust:none; } */ +} + + +@media print { + * { background: transparent !important; color: black !important; text-shadow: none !important; filter:none !important; + -ms-filter: none !important; } + a, a:visited { color: #444 !important; text-decoration: underline; } + a[href]:after { content: " (" attr(href) ")"; } + abbr[title]:after { content: " (" attr(title) ")"; } + .ir a:after, a[href^="javascript:"]:after, a[href^="#"]:after { content: ""; } + pre, blockquote { border: 1px solid #999; page-break-inside: avoid; } + thead { display: table-header-group; } + tr, img { page-break-inside: avoid; } + @page { margin: 0.5cm; } + p, h2, h3 { orphans: 3; widows: 3; } + h2, h3{ page-break-after: avoid; } +} diff --git a/yesod/static/script.js b/yesod/static/script.js new file mode 100644 index 00000000..43c21a53 --- /dev/null +++ b/yesod/static/script.js @@ -0,0 +1,3 @@ +$(function(){ + $("p.noscript").hide(); +}); diff --git a/yesod/static/style.css b/yesod/static/style.css new file mode 100644 index 00000000..d09c6b08 --- /dev/null +++ b/yesod/static/style.css @@ -0,0 +1,12 @@ +body { + font-family: sans-serif; + background: #eee; +} + +#wrapper { + width: 760px; + margin: 1em auto; + border: 2px solid #000; + padding: 0.5em; + background: #fff; +} diff --git a/yesod/static/style2.css b/yesod/static/style2.css new file mode 100644 index 00000000..853ac29a --- /dev/null +++ b/yesod/static/style2.css @@ -0,0 +1,3 @@ +body { + font-family: sans-serif; +} diff --git a/yesod/tests/mini-input.txt b/yesod/tests/mini-input.txt new file mode 100644 index 00000000..079224e8 --- /dev/null +++ b/yesod/tests/mini-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +m diff --git a/yesod/tests/postgresql-input.txt b/yesod/tests/postgresql-input.txt new file mode 100644 index 00000000..ad38e160 --- /dev/null +++ b/yesod/tests/postgresql-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +p diff --git a/yesod/tests/run.sh b/yesod/tests/run.sh new file mode 100755 index 00000000..93536b6d --- /dev/null +++ b/yesod/tests/run.sh @@ -0,0 +1,17 @@ +#!/bin/bash -x +# +# A wrapper for the shelltest test. Passes along options to shelltest. +# +# cabal install shelltestrunner + +cabal clean && cabal install && cabal sdist + +# I am not that good at shell scripting +# this for loop only operates on 1 file (as per tail -1) +for f in $(ls -1rt dist/*.tar.gz | tail -1) +do + tar -xzvf $f && cd `basename $f .tar.gz` + shelltest ../tests/scaffold.shelltest $@ + cd .. + rm -r `basename $f .tar.gz` +done diff --git a/yesod/tests/runscaffold.sh b/yesod/tests/runscaffold.sh new file mode 100755 index 00000000..03b40ced --- /dev/null +++ b/yesod/tests/runscaffold.sh @@ -0,0 +1,3 @@ +#!/bin/bash -x + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. diff --git a/yesod/tests/scaffold.shelltest b/yesod/tests/scaffold.shelltest new file mode 100644 index 00000000..a35a8554 --- /dev/null +++ b/yesod/tests/scaffold.shelltest @@ -0,0 +1,31 @@ +# Important! run with tests/run.sh + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. +<<< +Michael +foobar + +Foobar +s +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. +<<< +Michael +foobar + +Foobar +p +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar +<<< +Michael +foobar + +Foobar +m +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 diff --git a/yesod/tests/sqlite-input.txt b/yesod/tests/sqlite-input.txt new file mode 100644 index 00000000..6b02a6e9 --- /dev/null +++ b/yesod/tests/sqlite-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +s diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal new file mode 100644 index 00000000..b5171709 --- /dev/null +++ b/yesod/yesod.cabal @@ -0,0 +1,107 @@ +name: yesod +version: 0.8.2.1 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman <michael@snoyman.com> +maintainer: Michael Snoyman <michael@snoyman.com> +synopsis: Creation of type-safe, RESTful web applications. +description: + Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. + . + The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. +category: Web, Yesod +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com/ + +extra-source-files: + input/*.cg + scaffold/cassius/default-layout.cassius.cg, + scaffold/cassius/homepage.cassius.cg, + scaffold/Model.hs.cg scaffold/sitearg.hs.cg, + scaffold/LICENSE.cg, + scaffold/mini/sitearg.hs.cg, + scaffold/mini/cabal.cg, + scaffold/mini/Controller.hs.cg, + scaffold/mini/hamlet/homepage.hamlet.cg, + scaffold/mini/Handler/Root.hs.cg, + scaffold/mini/config/routes.cg, + scaffold/mini/config/Settings.hs.cg, + scaffold/static/css/html5boilerplate.css.cg, + scaffold/pconn1.cg, + scaffold/.ghci.cg, + scaffold/cabal.cg, + scaffold/deploy/Procfile.cg, + scaffold/Controller.hs.cg, + scaffold/julius/homepage.julius.cg, + scaffold/hamlet/homepage.hamlet.cg, + scaffold/hamlet/default-layout.hamlet.cg, + scaffold/hamlet/boilerplate-layout.hamlet.cg, + scaffold/project.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/routes.cg, + scaffold/config/Settings.hs.cg, + scaffold/config/StaticFiles.hs.cg + + +flag ghc7 + +library + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: yesod-core >= 0.8.1 && < 0.9 + , yesod-auth >= 0.4 && < 0.5 + , yesod-json >= 0.1 && < 0.2 + , yesod-persistent >= 0.1 && < 0.2 + , yesod-static >= 0.1 && < 0.2 + , yesod-form >= 0.1 && < 0.2 + , monad-control >= 0.2 && < 0.3 + , transformers >= 0.2 && < 0.3 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4 && < 0.5 + , hamlet >= 0.8.1 && < 0.9 + , warp >= 0.4 && < 0.5 + , mime-mail >= 0.3 && < 0.4 + , hjsmin >= 0.0.13 && < 0.1 + exposed-modules: Yesod + ghc-options: -Wall + +executable yesod + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: parsec >= 2.1 && < 4 + , text >= 0.11 && < 0.12 + , bytestring >= 0.9 && < 0.10 + , time >= 1.1.4 && < 1.3 + , template-haskell + , directory >= 1.0 && < 1.2 + , Cabal >= 1.8 && < 1.11 + , unix-compat >= 0.2 && < 0.3 + , containers >= 0.2 && < 0.5 + , attoparsec-text >= 0.8.5 && < 0.9 + , http-types >= 0.6.1 && < 0.7 + , blaze-builder >= 0.2 && < 0.4 + , process + ghc-options: -Wall -threaded + main-is: scaffold.hs + other-modules: CodeGen + Scaffold.Build + Scaffold.Devel + if flag(ghc7) + cpp-options: -DGHC7 + +source-repository head + type: git + location: git://github.com/snoyberg/yesod.git