Scaffolded site works with 0.6 (no email login)

This commit is contained in:
Michael Snoyman 2010-10-26 09:59:58 +02:00
parent 300f0a4f4d
commit ad8eeab039
5 changed files with 43 additions and 32 deletions

View File

@ -16,7 +16,7 @@ getRootR = do
defaultLayout $ do defaultLayout $ do
h2id <- newIdent h2id <- newIdent
setTitle "~project~ homepage" setTitle "~project~ homepage"
addBody $(hamletFile "homepage") addCassius $(cassiusFile "homepage")
addStyle $(cassiusFile "homepage") addJulius $(juliusFile "homepage")
addJavascript $(juliusFile "homepage") addWidget $(hamletFile "homepage")

View File

@ -22,7 +22,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 (MonadCatchIO) import Yesod (MonadInvertIO)
-- | The base URL for your application. This will usually be different for -- | The base URL for your application. This will usually be different for
-- development and production. Yesod automatically constructs URLs for you, -- development and production. Yesod automatically constructs URLs for you,
@ -93,13 +93,13 @@ connectionCount = 10
-- is used for increased performance. -- is used for increased performance.
-- --
-- You can see an example of how to call these functions in Handler/Root.hs -- 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.
hamletFile :: FilePath -> Q Exp hamletFile :: FilePath -> Q Exp
#ifdef PRODUCTION
hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet"
#else
hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet"
#endif
cassiusFile :: FilePath -> Q Exp cassiusFile :: FilePath -> Q Exp
#ifdef PRODUCTION #ifdef PRODUCTION
@ -119,9 +119,9 @@ juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius"
-- 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 :: MonadCatchIO m => (ConnectionPool -> m a) -> m a withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a
withConnectionPool = with~upper~Pool connStr connectionCount withConnectionPool = with~upper~Pool connStr connectionCount
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a
runConnectionPool = runSqlPool runConnectionPool = runSqlPool

View File

@ -20,15 +20,18 @@ executable simple-server
if flag(production) if flag(production)
Buildable: False Buildable: False
main-is: simple-server.hs main-is: simple-server.hs
build-depends: base >= 4 && < 5, build-depends: base >= 4 && < 5
yesod >= 0.5 && < 0.6, , yesod >= 0.6 && < 0.7
wai-extra, , yesod-auth >= 0.2 && < 0.3
directory, , mime-mail >= 0.0 && < 0.1
bytestring, , wai-extra
persistent, , directory
persistent-~lower~, , bytestring
template-haskell, , persistent
hamlet , persistent-~lower~
, template-haskell
, hamlet
, web-routes
ghc-options: -Wall ghc-options: -Wall
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies extensions: TemplateHaskell, QuasiQuotes, TypeFamilies
@ -47,7 +50,7 @@ executable fastcgi
Buildable: False Buildable: False
cpp-options: -DPRODUCTION cpp-options: -DPRODUCTION
main-is: fastcgi.hs main-is: fastcgi.hs
build-depends: wai-handler-fastcgi build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3
ghc-options: -Wall ghc-options: -Wall
extensions: TemplateHaskell, QuasiQuotes, TypeFamilies extensions: TemplateHaskell, QuasiQuotes, TypeFamilies

View File

@ -1,5 +1,5 @@
Great, we'll be creating ~project~ today, and placing it in ~dir~. 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 What's going to be the name of your foundation datatype? This name must
start with a capital letter. start with a capital letter.
Site argument: Foundation:

View File

@ -14,18 +14,16 @@ module ~sitearg~
) where ) where
import Yesod import Yesod
import Yesod.Mail
import Yesod.Helpers.Static import Yesod.Helpers.Static
import Yesod.Helpers.Auth import Yesod.Helpers.Auth
import Yesod.Helpers.Auth.OpenId
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 Yesod.WebRoutes import Web.Routes.Site (Site (formatPathSegments))
import Database.Persist.GenericSql import Database.Persist.GenericSql
import Settings (hamletFile, cassiusFile, juliusFile) import Settings (hamletFile, cassiusFile, juliusFile)
import Model import Model
import Control.Monad (join)
import Data.Maybe (isJust)
-- | The site argument for your application. This can be a good place to -- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
@ -82,7 +80,7 @@ instance Yesod ~sitearg~ where
mmsg <- getMessage mmsg <- getMessage
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
widget widget
addStyle $(Settings.cassiusFile "default-layout") addCassius $(Settings.cassiusFile "default-layout")
hamletToRepHtml $(Settings.hamletFile "default-layout") hamletToRepHtml $(Settings.hamletFile "default-layout")
-- This is done to provide an optimization for serving static files from -- This is done to provide an optimization for serving static files from
@ -115,20 +113,29 @@ instance YesodPersist ~sitearg~ where
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
instance YesodAuth ~sitearg~ where instance YesodAuth ~sitearg~ where
type AuthEntity ~sitearg~ = User type AuthId ~sitearg~ = UserId
type AuthEmailEntity ~sitearg~ = Email
defaultDest _ = RootR -- Where to send a user after successful login
loginDest _ = RootR
-- Where to send a user after logout
logoutDest _ = RootR
getAuthId creds _extra = runDB $ do getAuthId creds = runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds x <- getBy $ UniqueUser $ credsIdent creds
case x of case x of
Just (uid, _) -> return $ Just uid Just (uid, _) -> return $ Just uid
Nothing -> do Nothing -> do
fmap Just $ insert $ User (credsIdent creds) Nothing fmap Just $ insert $ User (credsIdent creds) Nothing
openIdEnabled _ = True showAuthId _ x = show (fromIntegral x :: Integer)
readAuthId _ s = case reads s of
(i, _):_ -> Just $ fromInteger i
[] -> Nothing
authPlugins = [ authOpenId
]
{- FIXME
emailSettings _ = Just EmailSettings emailSettings _ = Just EmailSettings
{ addUnverified = \email verkey -> { addUnverified = \email verkey ->
runDB $ insert $ Email email Nothing (Just verkey) runDB $ insert $ Email email Nothing (Just verkey)
@ -183,4 +190,5 @@ sendVerifyEmail' email _ verurl =
|~~] |~~]
} }
} }
-}