Fix up scaffolded site

This commit is contained in:
Michael Snoyman 2011-01-31 12:02:15 +02:00
parent e9eab1ee8e
commit 3afb0f7442
17 changed files with 73 additions and 74 deletions

View File

@ -58,7 +58,6 @@ import Yesod.Json
import Yesod.Persist import Yesod.Persist
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Middleware.Debug import Network.Wai.Middleware.Debug
import qualified Network.Wai as W
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad.IO.Peel (MonadPeelIO)
@ -77,12 +76,12 @@ readIntegral s =
-- | A convenience method to run an application using the Warp webserver on the -- | A convenience method to run an application using the Warp webserver on the
-- specified port. Automatically calls 'toWaiApp'. -- specified port. Automatically calls 'toWaiApp'.
warp :: (Yesod a, YesodSite a) => Int -> a -> IO () warp :: (Yesod a, YesodDispatch a a) => Int -> a -> IO ()
warp port a = toWaiApp a >>= run port warp port a = toWaiApp a >>= run port
-- | Same as 'warp', but also sends a message to stderr for each request, and -- | 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. -- an \"application launched\" message as well. Can be useful for development.
warpDebug :: (Yesod a, YesodSite a) => Int -> a -> IO () warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO ()
warpDebug port a = do warpDebug port a = do
hPutStrLn stderr $ "Application launched, listening on port " ++ show port hPutStrLn stderr $ "Application launched, listening on port " ++ show port
toWaiApp a >>= run port . debug toWaiApp a >>= run port . debug

View File

@ -63,8 +63,8 @@ main = do
mkDir "cassius" mkDir "cassius"
mkDir "julius" mkDir "julius"
writeFile' "simple-server.hs" $(codegen "simple-server_hs") writeFile' "test.hs" $(codegen "test_hs")
writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") writeFile' "production.hs" $(codegen "production_hs")
writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs")
writeFile' (project ++ ".cabal") $(codegen "cabal") writeFile' (project ++ ".cabal") $(codegen "cabal")
writeFile' "LICENSE" $(codegen "LICENSE") writeFile' "LICENSE" $(codegen "LICENSE")

View File

@ -1,4 +1,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Controller module Controller
( with~sitearg~ ( with~sitearg~
@ -9,6 +11,7 @@ import Settings
import Yesod.Helpers.Static import Yesod.Helpers.Static
import Yesod.Helpers.Auth import Yesod.Helpers.Auth
import Database.Persist.GenericSql import Database.Persist.GenericSql
import Data.ByteString (ByteString)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
import Handler.Root import Handler.Root
@ -24,7 +27,7 @@ getFaviconR :: Handler ()
getFaviconR = sendFile "image/x-icon" "favicon.ico" getFaviconR = sendFile "image/x-icon" "favicon.ico"
getRobotsR :: Handler RepPlain getRobotsR :: Handler RepPlain
getRobotsR = return $ RepPlain $ toContent "User-agent: *" getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
-- This function allocates resources (such as a database connection pool), -- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the -- performs initialization and creates a WAI application. This is also the
@ -36,5 +39,5 @@ with~sitearg~ f = Settings.withConnectionPool $ \p -> do
let h = ~sitearg~ s p let h = ~sitearg~ s p
toWaiApp h >>= f toWaiApp h >>= f
where where
s = fileLookupDir Settings.staticdir typeByExt s = static Settings.staticdir

View File

@ -14,7 +14,7 @@ getRootR :: Handler RepHtml
getRootR = do getRootR = do
mu <- maybeAuth mu <- maybeAuth
defaultLayout $ do defaultLayout $ do
h2id <- newIdent h2id <- lift newIdent
setTitle "~project~ homepage" setTitle "~project~ homepage"
addWidget $(widgetFile "homepage") addWidget $(widgetFile "homepage")

View File

@ -24,7 +24,7 @@ import qualified Text.Cassius as H
import qualified Text.Julius as H import qualified Text.Julius as H
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Database.Persist.~upper~ import Database.Persist.~upper~
import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) import Yesod (MonadPeelIO, addWidget, addCassius, addJulius)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
@ -139,9 +139,9 @@ widgetFile x = do
-- database actions using a pool, respectively. It is used internally -- database actions using a pool, respectively. It is used internally
-- by the scaffolded application, and therefore you will rarely need to use -- by the scaffolded application, and therefore you will rarely need to use
-- them yourself. -- them yourself.
withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a withConnectionPool :: MonadPeelIO m => (ConnectionPool -> m a) -> m a
withConnectionPool = with~upper~Pool connStr connectionCount withConnectionPool = with~upper~Pool connStr connectionCount
runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool :: MonadPeelIO m => SqlPersist m a -> ConnectionPool -> m a
runConnectionPool = runSqlPool runConnectionPool = runSqlPool

View File

@ -16,41 +16,35 @@ Flag production
Description: Build the production executable. Description: Build the production executable.
Default: False Default: False
executable simple-server executable ~project~-test
if flag(production) if flag(production)
Buildable: False Buildable: False
main-is: simple-server.hs main-is: test.hs
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod >= 0.6 && < 0.7 , yesod >= 0.7 && < 0.8
, yesod-auth >= 0.2 && < 0.3 , yesod-auth
, mime-mail >= 0.0 && < 0.1 , yesod-static
, mime-mail
, wai-extra , wai-extra
, directory , directory
, bytestring , bytestring
, text , text
, persistent >= 0.3.1.1 , persistent
, persistent-~lower~ , persistent-~lower~
, template-haskell , template-haskell
, hamlet , hamlet
, web-routes , web-routes
, hjsmin >= 0.0.4 && < 0.1 , hjsmin
, transformers
, warp
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
executable devel-server executable ~project~-production
if flag(production)
Buildable: False
else
build-depends: wai-handler-devel >= 0.1.0 && < 0.2
main-is: devel-server.hs
ghc-options: -Wall -O2 -threaded
executable fastcgi
if flag(production) if flag(production)
Buildable: True Buildable: True
build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3
else else
Buildable: False Buildable: False
cpp-options: -DPRODUCTION cpp-options: -DPRODUCTION
main-is: fastcgi.hs main-is: production.hs
ghc-options: -Wall -threaded ghc-options: -Wall -threaded

View File

@ -1,10 +1,10 @@
!!! !!!
%html <html
%head <head
%title $pageTitle.pc$ <title>#{pageTitle pc}
^pageHead.pc^ ^{pageHead pc}
%body <body
$maybe mmsg msg $maybe msg <- mmsg
#message $msg$ <div #message>#{msg}
^pageBody.pc^ ^{pageBody pc}

View File

@ -1,6 +0,0 @@
import Controller
import Network.Wai.Handler.FastCGI (run)
main :: IO ()
main = with~sitearg~ run

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

View File

@ -1,5 +1,5 @@
h1 h1
text-align: center text-align: center
h2#$h2id$ h2##{h2id}
color: #990 color: #990

View File

@ -1,13 +1,13 @@
%h1 Hello <h1>Hello
%h2#$h2id$ You do not have Javascript enabled. <h2 ##{h2id}>You do not have Javascript enabled.
$maybe mu u $maybe u <- mu
%p <p
You are logged in as $userIdent.snd.u$. $ You are logged in as #{userIdent $ snd u}. #
%a!href=@AuthR.LogoutR@ Logout <a href=@{AuthR LogoutR}>Logout
\. .
$nothing $nothing
%p <p
You are not logged in. $ You are not logged in. #
%a!href=@AuthR.LoginR@ Login now <a href=@{AuthR LoginR}>Login now
\. .

View File

@ -1,4 +1,4 @@
window.onload = function(){ window.onload = function(){
document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>";
} }

View File

@ -0,0 +1,6 @@
import Controller (with~sitearg~)
import Network.Wai.Handler.Warp (run)
main :: IO ()
main = with~sitearg~ $ run 3000

View File

@ -1,6 +0,0 @@
import Controller
import Network.Wai.Handler.SimpleServer (run)
main :: IO ()
main = putStrLn "Loaded" >> with~sitearg~ (run 3000)

View File

@ -22,7 +22,6 @@ import Yesod.Helpers.Auth.Email
import qualified Settings import qualified Settings
import System.Directory import System.Directory
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Web.Routes.Site (Site (formatPathSegments))
import Database.Persist.GenericSql import Database.Persist.GenericSql
import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Settings (hamletFile, cassiusFile, juliusFile, widgetFile)
import Model import Model
@ -94,11 +93,7 @@ instance Yesod ~sitearg~ where
-- This is done to provide an optimization for serving static files from -- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticroot setting in Settings.hs -- a separate domain. Please see the staticroot setting in Settings.hs
urlRenderOverride a (StaticR s) = urlRenderOverride a (StaticR s) =
Just $ uncurry (joinPath a Settings.staticroot) $ format s Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s
where
format = formatPathSegments ss
ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))
ss = getSubSite
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-- The page to be redirected to when authentication is required. -- The page to be redirected to when authentication is required.
@ -126,7 +121,8 @@ instance Yesod ~sitearg~ where
-- How to run database actions. -- How to run database actions.
instance YesodPersist ~sitearg~ where instance YesodPersist ~sitearg~ where
type YesodDB ~sitearg~ = SqlPersist type YesodDB ~sitearg~ = SqlPersist
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db runDB db = liftIOHandler
$ fmap connPool getYesod >>= Settings.runConnectionPool db
instance YesodAuth ~sitearg~ where instance YesodAuth ~sitearg~ where
type AuthId ~sitearg~ = UserId type AuthId ~sitearg~ = UserId
@ -179,17 +175,19 @@ instance YesodAuthEmail ~sitearg~ where
, "" , ""
, "Thank you" , "Thank you"
] ]
, partHeaders = []
} }
htmlPart = Part htmlPart = Part
{ partType = "text/html; charset=utf-8" { partType = "text/html; charset=utf-8"
, partEncoding = None , partEncoding = None
, partFilename = Nothing , partFilename = Nothing
, partContent = renderHtml [~qq~hamlet| , partContent = renderHtml [~qq~hamlet|
%p Please confirm your email address by clicking on the link below. <p>Please confirm your email address by clicking on the link below.
%p <p>
%a!href=$verurl$ $verurl$ <a href=#{verurl} #{verurl}
%p Thank you <p>Thank you
|] |]
, partHeaders = []
} }
getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key]

11
scaffold/test_hs.cg Normal file
View File

@ -0,0 +1,11 @@
import Controller (with~sitearg~)
import System.IO (hPutStrLn, stderr)
import Network.Wai.Middleware.Debug (debug)
import Network.Wai.Handler.Warp (run)
main :: IO ()
main = do
let port = 3000
hPutStrLn stderr $ "Application launched, listening on port " ++ show port
with~sitearg~ $ run port . debug

View File

@ -35,7 +35,7 @@ library
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.7 && < 0.8
, warp >= 0.3 && < 0.4 , warp >= 0.3 && < 0.4
, mime-mail >= 0.1 && < 0.2 , mime-mail >= 0.1 && < 0.2
, hjsmin >= 0.0.5 && < 0.1 , hjsmin >= 0.0.12 && < 0.1
exposed-modules: Yesod exposed-modules: Yesod
ghc-options: -Wall ghc-options: -Wall