Scaffolder uses separate files
This commit is contained in:
Michael Snoyman
parent
b13c08f001
commit
83368b05fd
@ -1,29 +1,24 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | A code generation quasi-quoter. Everything is taken as literal text, with ~var~ variable interpolation, and ~~ is completely ignored.
|
||||
module CodeGenQ (codegen) where
|
||||
-- | A code generation template haskell. Everything is taken as literal text,
|
||||
-- with ~var~ variable interpolation.
|
||||
module CodeGen (codegen) where
|
||||
|
||||
import Language.Haskell.TH.Quote
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Text.ParserCombinators.Parsec
|
||||
|
||||
codegen :: QuasiQuoter
|
||||
codegen = QuasiQuoter codegen' $ error "codegen cannot be a pattern"
|
||||
import qualified System.IO.UTF8 as U
|
||||
|
||||
data Token = VarToken String | LitToken String | EmptyToken
|
||||
|
||||
codegen' :: String -> Q Exp
|
||||
codegen' s' = do
|
||||
let s = killFirstBlank s'
|
||||
codegen :: FilePath -> Q Exp
|
||||
codegen fp = do
|
||||
s' <- qRunIO $ U.readFile $ "scaffold/" ++ fp ++ ".cg"
|
||||
let s = init 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''
|
||||
where
|
||||
killFirstBlank ('\n':x) = x
|
||||
killFirstBlank ('\r':'\n':x) = x
|
||||
killFirstBlank x = x
|
||||
|
||||
toExp :: Token -> Exp
|
||||
toExp (LitToken s) = LitE $ StringL s
|
||||
491
scaffold.hs
491
scaffold.hs
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
|
||||
import CodeGenQ
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
import CodeGen
|
||||
import System.IO
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Char8 as S
|
||||
@ -7,63 +7,35 @@ import Language.Haskell.TH.Syntax
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStr [$codegen|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: |]
|
||||
putStr $(codegen "welcome")
|
||||
hFlush stdout
|
||||
name <- getLine
|
||||
|
||||
putStr [$codegen|
|
||||
Welcome ~name~.
|
||||
What do you want to call your project? We'll use this for the cabal name.
|
||||
|
||||
Project name: |]
|
||||
putStr $(codegen "project-name")
|
||||
hFlush stdout
|
||||
project <- getLine
|
||||
|
||||
putStr [$codegen|
|
||||
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: |]
|
||||
putStr $(codegen "dir-name")
|
||||
hFlush stdout
|
||||
dirRaw <- getLine
|
||||
let dir = if null dirRaw then project else dirRaw
|
||||
|
||||
putStr [$codegen|
|
||||
Great, we'll be creating ~project~ today, and placing it in ~dir~.
|
||||
What's going to be the name of your site argument datatype? This name must
|
||||
start with a capital letter.
|
||||
|
||||
Site argument: |]
|
||||
putStr $(codegen "site-arg")
|
||||
hFlush stdout
|
||||
sitearg <- getLine
|
||||
|
||||
putStr [$codegen|
|
||||
That's it! I'm creating your files now...
|
||||
|]
|
||||
|
||||
putStr [$codegen|
|
||||
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: |]
|
||||
putStr $(codegen "database")
|
||||
hFlush stdout
|
||||
backendS <- getLine
|
||||
let pconn1 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug|]
|
||||
let pconn2 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production|]
|
||||
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 writeFile' fp s = do
|
||||
putStrLn $ "Generating " ++ fp
|
||||
@ -75,433 +47,24 @@ So, what'll it be? s for sqlite, p for postgresql: |]
|
||||
mkDir "cassius"
|
||||
mkDir "julius"
|
||||
|
||||
writeFile' "simple-server.hs" [$codegen|
|
||||
import Controller
|
||||
import Network.Wai.Handler.SimpleServer (run)
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Loaded" >> with~sitearg~ (run 3000)
|
||||
|]
|
||||
|
||||
writeFile' "fastcgi.hs" [$codegen|
|
||||
import Controller
|
||||
import Network.Wai.Handler.FastCGI (run)
|
||||
|
||||
main :: IO ()
|
||||
main = with~sitearg~ run
|
||||
|]
|
||||
|
||||
writeFile' (project ++ ".cabal") [$codegen|
|
||||
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://www.yesodweb.com/~project~
|
||||
|
||||
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.5 && < 0.6,
|
||||
wai-extra,
|
||||
directory,
|
||||
bytestring,
|
||||
persistent,
|
||||
persistent-~lower~,
|
||||
template-haskell,
|
||||
hamlet
|
||||
ghc-options: -Wall
|
||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
||||
|
||||
executable fastcgi
|
||||
if flag(production)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
cpp-options: -DPRODUCTION
|
||||
main-is: fastcgi.hs
|
||||
build-depends: wai-handler-fastcgi
|
||||
ghc-options: -Wall
|
||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
||||
|]
|
||||
|
||||
writeFile' "LICENSE" [$codegen|
|
||||
The following license covers this documentation, and the source code, except
|
||||
where otherwise indicated.
|
||||
|
||||
Copyright 2010, ~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.
|
||||
|]
|
||||
|
||||
writeFile' (sitearg ++ ".hs") [$codegen|
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
||||
module ~sitearg~
|
||||
( ~sitearg~ (..)
|
||||
, ~sitearg~Route (..)
|
||||
, resources~sitearg~
|
||||
, Handler
|
||||
, maybeAuth
|
||||
, requireAuth
|
||||
, module Yesod
|
||||
, module Settings
|
||||
, module Model
|
||||
, StaticRoute (..)
|
||||
, AuthRoute (..)
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Mail
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Helpers.Auth
|
||||
import qualified Settings
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Yesod.WebRoutes
|
||||
import Database.Persist.GenericSql
|
||||
import Settings (hamletFile, cassiusFile, juliusFile)
|
||||
import Model
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ getStatic :: Static
|
||||
, connPool :: Settings.ConnectionPool
|
||||
}
|
||||
|
||||
type Handler = GHandler ~sitearg~ ~sitearg~
|
||||
|
||||
mkYesodData "~sitearg~" [$parseRoutes|
|
||||
/static StaticR Static getStatic
|
||||
/auth AuthR Auth getAuth
|
||||
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
|
||||
/ RootR GET
|
||||
|~~]
|
||||
|
||||
instance Yesod ~sitearg~ where
|
||||
approot _ = Settings.approot
|
||||
defaultLayout widget = do
|
||||
mmsg <- getMessage
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
addStyle $(Settings.cassiusFile "default-layout")
|
||||
hamletToRepHtml $(Settings.hamletFile "default-layout")
|
||||
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
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
addStaticContent ext' _ content = do
|
||||
let fn = base64md5 content ++ '.' : ext'
|
||||
let statictmp = Settings.staticdir ++ "/tmp/"
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
liftIO $ L.writeFile (statictmp ++ fn) content
|
||||
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
||||
|
||||
instance YesodPersist ~sitearg~ where
|
||||
type YesodDB ~sitearg~ = SqlPersist
|
||||
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
|
||||
|
||||
instance YesodAuth ~sitearg~ where
|
||||
type AuthEntity ~sitearg~ = User
|
||||
type AuthEmailEntity ~sitearg~ = Email
|
||||
|
||||
defaultDest _ = RootR
|
||||
|
||||
getAuthId creds _extra = runDB $ do
|
||||
x <- getBy $ UniqueUser $ credsIdent creds
|
||||
case x of
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
|
||||
openIdEnabled _ = True
|
||||
|
||||
emailSettings _ = Just EmailSettings
|
||||
{ addUnverified = \email verkey ->
|
||||
runDB $ insert $ Email email Nothing (Just verkey)
|
||||
, sendVerifyEmail = sendVerifyEmail'
|
||||
, 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]
|
||||
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
|
||||
}
|
||||
|
||||
sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
|
||||
sendVerifyEmail' email _ verurl =
|
||||
liftIO $ renderSendMail Mail
|
||||
{ mailHeaders =
|
||||
[ ("From", "noreply")
|
||||
, ("To", email)
|
||||
, ("Subject", "Verify your email address")
|
||||
]
|
||||
, mailPlain = verurl
|
||||
, mailParts = return Part
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partDisposition = Inline
|
||||
, partContent = renderHamlet id [$hamlet|
|
||||
%p Please confirm your email address by clicking on the link below.
|
||||
%p
|
||||
%a!href=$verurl$ $verurl$
|
||||
%p Thank you
|
||||
|~~]
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
writeFile' "Controller.hs" [$codegen|
|
||||
{-# 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 Handler.Root
|
||||
|
||||
mkYesodDispatch "~sitearg~" resources~sitearg~
|
||||
|
||||
getFaviconR :: Handler ()
|
||||
getFaviconR = sendFile "image/x-icon" "favicon.ico"
|
||||
|
||||
getRobotsR :: Handler RepPlain
|
||||
getRobotsR = return $ RepPlain $ toContent "User-agent: *"
|
||||
|
||||
with~sitearg~ :: (Application -> IO a) -> IO a
|
||||
with~sitearg~ f = Settings.withConnectionPool $ \p -> do
|
||||
flip runConnectionPool p $ runMigration $ do
|
||||
migrate (undefined :: User)
|
||||
migrate (undefined :: Email)
|
||||
let h = ~sitearg~ s p
|
||||
toWaiApp h >>= f
|
||||
where
|
||||
s = fileLookupDir Settings.staticdir typeByExt
|
||||
|]
|
||||
|
||||
writeFile' "Handler/Root.hs" [$codegen|
|
||||
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
|
||||
module Handler.Root where
|
||||
|
||||
import ~sitearg~
|
||||
|
||||
getRootR :: Handler RepHtml
|
||||
getRootR = do
|
||||
mu <- maybeAuth
|
||||
defaultLayout $ do
|
||||
h2id <- newIdent
|
||||
setTitle "~project~ homepage"
|
||||
addBody $(hamletFile "homepage")
|
||||
addStyle $(cassiusFile "homepage")
|
||||
addJavascript $(juliusFile "homepage")
|
||||
|]
|
||||
|
||||
writeFile' "Model.hs" [$codegen|
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
|
||||
module Model where
|
||||
|
||||
import Yesod
|
||||
|
||||
mkPersist [$persist|
|
||||
User
|
||||
ident String
|
||||
password String null update
|
||||
UniqueUser ident
|
||||
Email
|
||||
email String
|
||||
user UserId null update
|
||||
verkey String null update
|
||||
UniqueEmail email
|
||||
|~~]
|
||||
|]
|
||||
|
||||
writeFile' "Settings.hs" [$codegen|
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Settings
|
||||
( hamletFile
|
||||
, cassiusFile
|
||||
, juliusFile
|
||||
, 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 (MonadCatchIO)
|
||||
|
||||
hamletFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"
|
||||
#else
|
||||
hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet"
|
||||
#endif
|
||||
|
||||
cassiusFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius"
|
||||
#else
|
||||
cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius"
|
||||
#endif
|
||||
|
||||
juliusFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius"
|
||||
#else
|
||||
juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"
|
||||
#endif
|
||||
|
||||
connStr :: String
|
||||
#ifdef PRODUCTION
|
||||
connStr = "~connstr2~"
|
||||
#else
|
||||
connStr = "~connstr1~"
|
||||
#endif
|
||||
|
||||
connectionCount :: Int
|
||||
connectionCount = 10
|
||||
|
||||
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool = with~upper~Pool connStr connectionCount
|
||||
|
||||
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
|
||||
approot :: String
|
||||
#ifdef PRODUCTION
|
||||
approot = "http://localhost:3000"
|
||||
#else
|
||||
approot = "http://localhost:3000"
|
||||
#endif
|
||||
|
||||
staticroot :: String
|
||||
staticroot = approot ++ "/static"
|
||||
|
||||
staticdir :: FilePath
|
||||
staticdir = "static"
|
||||
|]
|
||||
|
||||
writeFile' "cassius/default-layout.cassius" [$codegen|
|
||||
body
|
||||
font-family: sans-serif
|
||||
|]
|
||||
|
||||
writeFile' "hamlet/default-layout.hamlet" [$codegen|
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
%title $pageTitle.pc$
|
||||
^pageHead.pc^
|
||||
%body
|
||||
$maybe mmsg msg
|
||||
#message $msg$
|
||||
^pageBody.pc^
|
||||
|]
|
||||
|
||||
writeFile' "hamlet/homepage.hamlet" [$codegen|
|
||||
%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
|
||||
\.
|
||||
|]
|
||||
|
||||
writeFile' "cassius/homepage.cassius" [$codegen|
|
||||
body
|
||||
font-family: sans-serif
|
||||
h1
|
||||
text-align: center
|
||||
h2#$h2id$
|
||||
color: #990
|
||||
|]
|
||||
|
||||
writeFile' "julius/homepage.julius" [$codegen|
|
||||
window.onload = function(){
|
||||
document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";
|
||||
}
|
||||
|]
|
||||
writeFile' "simple-server.hs" $(codegen "simple-server_hs")
|
||||
writeFile' "fastcgi.hs" $(codegen "fastcgi_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 "favicon.ico") >>= \bs -> do
|
||||
$(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do
|
||||
pack <- [|S.pack|]
|
||||
return $ pack `AppE` LitE (StringL $ S.unpack bs))
|
||||
|
||||
32
scaffold/Controller_hs.cg
Normal file
32
scaffold/Controller_hs.cg
Normal file
@ -0,0 +1,32 @@
|
||||
{-# 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 Handler.Root
|
||||
|
||||
mkYesodDispatch "~sitearg~" resources~sitearg~
|
||||
|
||||
getFaviconR :: Handler ()
|
||||
getFaviconR = sendFile "image/x-icon" "favicon.ico"
|
||||
|
||||
getRobotsR :: Handler RepPlain
|
||||
getRobotsR = return $ RepPlain $ toContent "User-agent: *"
|
||||
|
||||
with~sitearg~ :: (Application -> IO a) -> IO a
|
||||
with~sitearg~ f = Settings.withConnectionPool $ \p -> do
|
||||
flip runConnectionPool p $ runMigration $ do
|
||||
migrate (undefined :: User)
|
||||
migrate (undefined :: Email)
|
||||
let h = ~sitearg~ s p
|
||||
toWaiApp h >>= f
|
||||
where
|
||||
s = fileLookupDir Settings.staticdir typeByExt
|
||||
|
||||
26
scaffold/LICENSE.cg
Normal file
26
scaffold/LICENSE.cg
Normal file
@ -0,0 +1,26 @@
|
||||
The following license covers this documentation, and the source code, except
|
||||
where otherwise indicated.
|
||||
|
||||
Copyright 2010, ~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.
|
||||
|
||||
17
scaffold/Model_hs.cg
Normal file
17
scaffold/Model_hs.cg
Normal file
@ -0,0 +1,17 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
|
||||
module Model where
|
||||
|
||||
import Yesod
|
||||
|
||||
mkPersist [$persist|
|
||||
User
|
||||
ident String
|
||||
password String null update
|
||||
UniqueUser ident
|
||||
Email
|
||||
email String
|
||||
user UserId null update
|
||||
verkey String null update
|
||||
UniqueEmail email
|
||||
|~~]
|
||||
|
||||
15
scaffold/Root_hs.cg
Normal file
15
scaffold/Root_hs.cg
Normal file
@ -0,0 +1,15 @@
|
||||
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
|
||||
module Handler.Root where
|
||||
|
||||
import ~sitearg~
|
||||
|
||||
getRootR :: Handler RepHtml
|
||||
getRootR = do
|
||||
mu <- maybeAuth
|
||||
defaultLayout $ do
|
||||
h2id <- newIdent
|
||||
setTitle "~project~ homepage"
|
||||
addBody $(hamletFile "homepage")
|
||||
addStyle $(cassiusFile "homepage")
|
||||
addJavascript $(juliusFile "homepage")
|
||||
|
||||
71
scaffold/Settings_hs.cg
Normal file
71
scaffold/Settings_hs.cg
Normal file
@ -0,0 +1,71 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Settings
|
||||
( hamletFile
|
||||
, cassiusFile
|
||||
, juliusFile
|
||||
, 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 (MonadCatchIO)
|
||||
|
||||
hamletFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"
|
||||
#else
|
||||
hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet"
|
||||
#endif
|
||||
|
||||
cassiusFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius"
|
||||
#else
|
||||
cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius"
|
||||
#endif
|
||||
|
||||
juliusFile :: FilePath -> Q Exp
|
||||
#ifdef PRODUCTION
|
||||
juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius"
|
||||
#else
|
||||
juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"
|
||||
#endif
|
||||
|
||||
connStr :: String
|
||||
#ifdef PRODUCTION
|
||||
connStr = "~connstr2~"
|
||||
#else
|
||||
connStr = "~connstr1~"
|
||||
#endif
|
||||
|
||||
connectionCount :: Int
|
||||
connectionCount = 10
|
||||
|
||||
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool = with~upper~Pool connStr connectionCount
|
||||
|
||||
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
|
||||
approot :: String
|
||||
#ifdef PRODUCTION
|
||||
approot = "http://localhost:3000"
|
||||
#else
|
||||
approot = "http://localhost:3000"
|
||||
#endif
|
||||
|
||||
staticroot :: String
|
||||
staticroot = approot ++ "/static"
|
||||
|
||||
staticdir :: FilePath
|
||||
staticdir = "static"
|
||||
|
||||
45
scaffold/cabal.cg
Normal file
45
scaffold/cabal.cg
Normal file
@ -0,0 +1,45 @@
|
||||
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://www.yesodweb.com/~project~
|
||||
|
||||
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.5 && < 0.6,
|
||||
wai-extra,
|
||||
directory,
|
||||
bytestring,
|
||||
persistent,
|
||||
persistent-~lower~,
|
||||
template-haskell,
|
||||
hamlet
|
||||
ghc-options: -Wall
|
||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
||||
|
||||
executable fastcgi
|
||||
if flag(production)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
cpp-options: -DPRODUCTION
|
||||
main-is: fastcgi.hs
|
||||
build-depends: wai-handler-fastcgi
|
||||
ghc-options: -Wall
|
||||
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
|
||||
|
||||
6
scaffold/database.cg
Normal file
6
scaffold/database.cg
Normal file
@ -0,0 +1,6 @@
|
||||
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:
|
||||
3
scaffold/default-layout_cassius.cg
Normal file
3
scaffold/default-layout_cassius.cg
Normal file
@ -0,0 +1,3 @@
|
||||
body
|
||||
font-family: sans-serif
|
||||
|
||||
10
scaffold/default-layout_hamlet.cg
Normal file
10
scaffold/default-layout_hamlet.cg
Normal file
@ -0,0 +1,10 @@
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
%title $pageTitle.pc$
|
||||
^pageHead.pc^
|
||||
%body
|
||||
$maybe mmsg msg
|
||||
#message $msg$
|
||||
^pageBody.pc^
|
||||
|
||||
5
scaffold/dir-name.cg
Normal file
5
scaffold/dir-name.cg
Normal file
@ -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:
|
||||
6
scaffold/fastcgi_hs.cg
Normal file
6
scaffold/fastcgi_hs.cg
Normal file
@ -0,0 +1,6 @@
|
||||
import Controller
|
||||
import Network.Wai.Handler.FastCGI (run)
|
||||
|
||||
main :: IO ()
|
||||
main = with~sitearg~ run
|
||||
|
||||
|
Before Width: | Height: | Size: 1.1 KiB After Width: | Height: | Size: 1.1 KiB |
5
scaffold/homepage_cassius.cg
Normal file
5
scaffold/homepage_cassius.cg
Normal file
@ -0,0 +1,5 @@
|
||||
h1
|
||||
text-align: center
|
||||
h2#$h2id$
|
||||
color: #990
|
||||
|
||||
13
scaffold/homepage_hamlet.cg
Normal file
13
scaffold/homepage_hamlet.cg
Normal file
@ -0,0 +1,13 @@
|
||||
%h1 Hello
|
||||
%h2#$h2id$ You do not have Javascript enabled.
|
||||
$maybe mu u
|
||||
%p
|
||||
You are logged in as $userIdent.snd.u$. $
|
||||
%a!href=@AuthR.LogoutR@ Logout
|
||||
\.
|
||||
$nothing
|
||||
%p
|
||||
You are not logged in. $
|
||||
%a!href=@AuthR.LoginR@ Login now
|
||||
\.
|
||||
|
||||
4
scaffold/homepage_julius.cg
Normal file
4
scaffold/homepage_julius.cg
Normal file
@ -0,0 +1,4 @@
|
||||
window.onload = function(){
|
||||
document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";
|
||||
}
|
||||
|
||||
1
scaffold/pconn1.cg
Normal file
1
scaffold/pconn1.cg
Normal file
@ -0,0 +1 @@
|
||||
user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug
|
||||
1
scaffold/pconn2.cg
Normal file
1
scaffold/pconn2.cg
Normal file
@ -0,0 +1 @@
|
||||
user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production
|
||||
4
scaffold/project-name.cg
Normal file
4
scaffold/project-name.cg
Normal file
@ -0,0 +1,4 @@
|
||||
Welcome ~name~.
|
||||
What do you want to call your project? We'll use this for the cabal name.
|
||||
|
||||
Project name:
|
||||
6
scaffold/simple-server_hs.cg
Normal file
6
scaffold/simple-server_hs.cg
Normal file
@ -0,0 +1,6 @@
|
||||
import Controller
|
||||
import Network.Wai.Handler.SimpleServer (run)
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Loaded" >> with~sitearg~ (run 3000)
|
||||
|
||||
5
scaffold/site-arg.cg
Normal file
5
scaffold/site-arg.cg
Normal file
@ -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 site argument datatype? This name must
|
||||
start with a capital letter.
|
||||
|
||||
Site argument:
|
||||
143
scaffold/sitearg_hs.cg
Normal file
143
scaffold/sitearg_hs.cg
Normal file
@ -0,0 +1,143 @@
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
||||
module ~sitearg~
|
||||
( ~sitearg~ (..)
|
||||
, ~sitearg~Route (..)
|
||||
, resources~sitearg~
|
||||
, Handler
|
||||
, maybeAuth
|
||||
, requireAuth
|
||||
, module Yesod
|
||||
, module Settings
|
||||
, module Model
|
||||
, StaticRoute (..)
|
||||
, AuthRoute (..)
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Mail
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Helpers.Auth
|
||||
import qualified Settings
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Yesod.WebRoutes
|
||||
import Database.Persist.GenericSql
|
||||
import Settings (hamletFile, cassiusFile, juliusFile)
|
||||
import Model
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ getStatic :: Static
|
||||
, connPool :: Settings.ConnectionPool
|
||||
}
|
||||
|
||||
type Handler = GHandler ~sitearg~ ~sitearg~
|
||||
|
||||
mkYesodData "~sitearg~" [$parseRoutes|
|
||||
/static StaticR Static getStatic
|
||||
/auth AuthR Auth getAuth
|
||||
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
|
||||
/ RootR GET
|
||||
|~~]
|
||||
|
||||
instance Yesod ~sitearg~ where
|
||||
approot _ = Settings.approot
|
||||
defaultLayout widget = do
|
||||
mmsg <- getMessage
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
addStyle $(Settings.cassiusFile "default-layout")
|
||||
hamletToRepHtml $(Settings.hamletFile "default-layout")
|
||||
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
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
addStaticContent ext' _ content = do
|
||||
let fn = base64md5 content ++ '.' : ext'
|
||||
let statictmp = Settings.staticdir ++ "/tmp/"
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
liftIO $ L.writeFile (statictmp ++ fn) content
|
||||
return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
||||
|
||||
instance YesodPersist ~sitearg~ where
|
||||
type YesodDB ~sitearg~ = SqlPersist
|
||||
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
|
||||
|
||||
instance YesodAuth ~sitearg~ where
|
||||
type AuthEntity ~sitearg~ = User
|
||||
type AuthEmailEntity ~sitearg~ = Email
|
||||
|
||||
defaultDest _ = RootR
|
||||
|
||||
getAuthId creds _extra = runDB $ do
|
||||
x <- getBy $ UniqueUser $ credsIdent creds
|
||||
case x of
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
|
||||
openIdEnabled _ = True
|
||||
|
||||
emailSettings _ = Just EmailSettings
|
||||
{ addUnverified = \email verkey ->
|
||||
runDB $ insert $ Email email Nothing (Just verkey)
|
||||
, sendVerifyEmail = sendVerifyEmail'
|
||||
, 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]
|
||||
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
|
||||
}
|
||||
|
||||
sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
|
||||
sendVerifyEmail' email _ verurl =
|
||||
liftIO $ renderSendMail Mail
|
||||
{ mailHeaders =
|
||||
[ ("From", "noreply")
|
||||
, ("To", email)
|
||||
, ("Subject", "Verify your email address")
|
||||
]
|
||||
, mailPlain = verurl
|
||||
, mailParts = return Part
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partDisposition = Inline
|
||||
, partContent = renderHamlet id [$hamlet|
|
||||
%p Please confirm your email address by clicking on the link below.
|
||||
%p
|
||||
%a!href=$verurl$ $verurl$
|
||||
%p Thank you
|
||||
|~~]
|
||||
}
|
||||
}
|
||||
|
||||
6
scaffold/welcome.cg
Normal file
6
scaffold/welcome.cg
Normal file
@ -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:
|
||||
@ -14,7 +14,7 @@ stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://docs.yesodweb.com/yesod/
|
||||
extra-source-files: favicon.ico
|
||||
extra-source-files: scaffold/*.cg
|
||||
|
||||
flag buildtests
|
||||
description: Build the executable to run unit tests
|
||||
@ -79,7 +79,7 @@ executable yesod
|
||||
build-depends: parsec >= 2.1 && < 4
|
||||
ghc-options: -Wall
|
||||
main-is: scaffold.hs
|
||||
other-modules: CodeGenQ
|
||||
other-modules: CodeGen
|
||||
extensions: TemplateHaskell
|
||||
|
||||
executable runtests
|
||||
|
||||
Loading…
Reference in New Issue
Block a user