Merge branch 'master' of github.com:yesodweb/yesod

This commit is contained in:
Greg Weber 2011-10-18 06:59:08 -07:00
commit 9c57f4bfd9
35 changed files with 150 additions and 83 deletions

View File

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OpenId
( authOpenId
, authOpenIdExtended
, forwardUrl
) where
@ -26,7 +27,10 @@ forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
authOpenId :: YesodAuth m => AuthPlugin m
authOpenId =
authOpenId = authOpenIdExtended []
authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
authOpenIdExtended extensionFields =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
@ -57,7 +61,7 @@ authOpenId =
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing []
res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing extensionFields
attempt
(\err -> do
setMessage $ toHtml $ show err
@ -87,5 +91,5 @@ completeHelper gets' = do
setMessage $ toHtml $ show err
redirect RedirectTemporary $ toMaster LoginR
let onSuccess (OpenId.Identifier ident, _) =
setCreds True $ Creds "openid" ident []
setCreds True $ Creds "openid" ident gets'
attempt onFailure onSuccess res

View File

@ -29,7 +29,6 @@ module Yesod.Internal
) where
import Text.Hamlet (HtmlUrl, hamlet, Html)
import Text.Cassius (CssUrl)
import Text.Julius (JavascriptUrl)
import Data.Monoid (Monoid (..), Last)
import Data.List (nub)
@ -44,6 +43,7 @@ import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
import Data.String (IsString)
import qualified Data.Map as Map
import Data.Text.Lazy.Builder (Builder)
#if GHC7
#define HAMLET hamlet
@ -107,12 +107,14 @@ nonceKey = "_NONCE"
sessionName :: IsString a => a
sessionName = "_SESSION"
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
data GWData a = GWData
!(Body a)
!(Last Title)
!(UniqueList (Script a))
!(UniqueList (Stylesheet a))
!(Map.Map (Maybe Text) (CssUrl a)) -- media type
!(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
!(Maybe (JavascriptUrl a))
!(Head a)
instance Monoid (GWData a) where

View File

@ -50,7 +50,6 @@ import qualified Data.ByteString.Lazy as L
import Data.Monoid
import Control.Monad.Trans.RWS
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)
import qualified Text.Blaze.Html5 as TBH
@ -504,7 +503,7 @@ widgetToPageContent (GWidget w) = do
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
css <- forM (Map.toList style) $ \(mmedia, content) -> do
let rendered = renderCssUrl render content
let rendered = toLazyText $ content render
x <- addStaticContent "css" "text/css; charset=utf-8"
$ encodeUtf8 rendered
return (mmedia,

View File

@ -192,7 +192,7 @@ addWidget = id
-- | Add some raw CSS to the style tag. Applies to all media types.
addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
-- | Identical to 'addCassius'.
addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
@ -200,7 +200,7 @@ addLucius = addCassius
-- | Add some raw CSS to the style tag, for a specific media type.
addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
-- | Identical to 'addCassiusMedia'.
addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()

View File

@ -60,7 +60,7 @@ library
, monad-control >= 0.2 && < 0.3
, enumerator >= 0.4.7 && < 0.5
, cookie >= 0.3 && < 0.4
, blaze-html >= 0.4 && < 0.5
, blaze-html >= 0.4.1.3 && < 0.5
, http-types >= 0.6.5 && < 0.7
, case-insensitive >= 0.2 && < 0.4
, parsec >= 2 && < 3.2

View File

@ -5,10 +5,10 @@ module Yesod.Default.Handlers
) where
import Yesod.Handler (GHandler, sendFile)
import Yesod.Content (RepPlain(..), ToContent(..))
import Yesod.Content (RepPlain(..))
getFaviconR :: GHandler s m ()
getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
getRobotsR :: GHandler s m RepPlain
getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: String)
getRobotsR = sendFile "text/plain" "config/robots.txt"

View File

@ -13,6 +13,11 @@ import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Debug (debugHandle)
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
import Network.Wai.Middleware.Gzip (gzip', GzipFiles (GzipCacheFolder), gzipFiles, def)
import Network.Wai.Middleware.Autohead (autohead)
import Network.Wai.Middleware.Jsonp (jsonp)
import Control.Monad (when)
#ifndef WINDOWS
import qualified System.Posix.Signals as Signal
@ -55,19 +60,25 @@ defaultRunner :: (YesodDispatch y y, Yesod y)
=> (Application -> IO a)
-> y -- ^ your foundation type
-> IO ()
defaultRunner f h =
defaultRunner f h = do
-- clear the .static-cache so we don't have stale content
exists <- doesDirectoryExist staticCache
when exists $ removeDirectoryRecursive staticCache
#ifdef WINDOWS
toWaiApp h >>= f >> return ()
toWaiAppPlain h >>= f . middlewares >> return ()
#else
do
tid <- forkIO $ toWaiApp h >>= f >> return ()
flag <- newEmptyMVar
_ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
putStrLn "Caught an interrupt"
killThread tid
putMVar flag ()) Nothing
takeMVar flag
tid <- forkIO $ toWaiAppPlain h >>= f . middlewares >> return ()
flag <- newEmptyMVar
_ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
putStrLn "Caught an interrupt"
killThread tid
putMVar flag ()) Nothing
takeMVar flag
#endif
where
middlewares = gzip' gset . jsonp . autohead
gset = def { gzipFiles = GzipCacheFolder staticCache }
staticCache = ".static-cache"
-- | Run your development app using the provided @'DefaultEnv'@ type
--

View File

@ -52,9 +52,9 @@ addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
| ext' == "js" = either (const content) id $ minify content
| otherwise = content
-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/
-- | expects a file extension for each type, e.g: hamlet lucius julius
globFile :: String -> String -> FilePath
globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
globFile kind x = "templates/" ++ x ++ "." ++ kind
widgetFileProduction :: FilePath -> Q Exp
widgetFileProduction x = do

View File

@ -1,5 +1,5 @@
name: yesod-default
version: 0.3.1
version: 0.4.0
license: BSD3
license-file: LICENSE
author: Patrick Brisbin
@ -22,7 +22,7 @@ library
, cmdargs >= 0.8 && < 0.9
, warp >= 0.4 && < 0.5
, wai >= 0.4 && < 0.5
, wai-extra >= 0.4 && < 0.5
, wai-extra >= 0.4.4 && < 0.5
, bytestring >= 0.9 && < 0.10
, transformers >= 0.2 && < 0.3
, text >= 0.9 && < 1.0

View File

@ -1,5 +1,5 @@
name: yesod-static
version: 0.3.1.1
version: 0.3.1.2
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -20,7 +20,7 @@ flag test
library
build-depends: base >= 4 && < 5
, containers >= 0.4
, containers
, old-time >= 1.0
, yesod-core >= 0.9 && < 0.10
, base64-bytestring >= 0.1.0.1 && < 0.2

View File

@ -125,7 +125,7 @@ determineHamletDeps x = do
A.Fail{} -> return []
A.Done _ r -> mapM go r >>= filterM doesFileExist . concat
where
go (Just (Hamlet, f)) = return [f, "hamlet/" ++ f ++ ".hamlet"]
go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"]
go (Just (Verbatim, f)) = return [f]
go (Just (Messages f, _)) = return [f]
go (Just (StaticFiles fp, _)) = getFolderContents fp

View File

@ -128,10 +128,7 @@ scaffold = do
mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp
mkDir "Handler"
mkDir "hamlet"
mkDir "cassius"
mkDir "lucius"
mkDir "julius"
mkDir "templates"
mkDir "static"
mkDir "static/css"
mkDir "static/js"
@ -158,25 +155,29 @@ scaffold = do
writeFile' ".ghci" $(codegen ".ghci")
writeFile' "LICENSE" $(codegen "LICENSE")
writeFile' ("Foundation.hs") $ ifTiny $(codegen "tiny/Foundation.hs") $(codegen "Foundation.hs")
writeFile' "Import.hs" $(codegen "Import.hs")
writeFile' "Application.hs" $ ifTiny $(codegen "tiny/Application.hs") $(codegen "Application.hs")
writeFile' "Handler/Root.hs" $(codegen "Handler/Root.hs")
unless isTiny $ writeFile' "Model.hs" $(codegen "Model.hs")
writeFile' "Settings.hs" $ ifTiny $(codegen "tiny/Settings.hs") $(codegen "Settings.hs")
writeFile' "Settings/StaticFiles.hs" $(codegen "Settings/StaticFiles.hs")
writeFile' "lucius/default-layout.lucius"
$(codegen "lucius/default-layout.lucius")
writeFile' "hamlet/default-layout.hamlet"
$(codegen "hamlet/default-layout.hamlet")
writeFile' "hamlet/default-layout-wrapper.hamlet"
$(codegen "hamlet/default-layout-wrapper.hamlet")
writeFile' "hamlet/boilerplate-layout.hamlet"
$(codegen "hamlet/boilerplate-layout.hamlet")
writeFile' "lucius/normalize.lucius"
$(codegen "lucius/normalize.lucius")
writeFile' "hamlet/homepage.hamlet" $(codegen "hamlet/homepage.hamlet")
writeFile' "templates/default-layout.lucius"
$(codegen "templates/default-layout.lucius")
writeFile' "templates/default-layout.hamlet"
$(codegen "templates/default-layout.hamlet")
writeFile' "templates/default-layout-wrapper.hamlet"
$(codegen "templates/default-layout-wrapper.hamlet")
writeFile' "templates/boilerplate-layout.hamlet"
$(codegen "templates/boilerplate-layout.hamlet")
writeFile' "templates/normalize.lucius"
$(codegen "templates/normalize.lucius")
writeFile' "templates/homepage.hamlet"
$(codegen "templates/homepage.hamlet")
writeFile' "config/routes" $ ifTiny $(codegen "tiny/config/routes") $(codegen "config/routes")
writeFile' "lucius/homepage.lucius" $(codegen "lucius/homepage.lucius")
writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius")
writeFile' "templates/homepage.lucius"
$(codegen "templates/homepage.lucius")
writeFile' "templates/homepage.julius"
$(codegen "templates/homepage.julius")
unless isTiny $ writeFile' "config/models" $(codegen "config/models")
writeFile' "messages/en.msg" $(codegen "messages/en.msg")
@ -188,5 +189,9 @@ scaffold = do
$(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do
pack <- [|S.pack|]
return $ pack `AppE` LitE (StringL $ S.unpack bs))
S.writeFile (dir ++ "/config/robots.txt")
$(runIO (S.readFile "scaffold/config/robots.txt.cg") >>= \bs -> do
[|S.pack $(return $ LitE $ StringL $ S.unpack bs)|])
puts $(codegenDir "input" "done")

View File

@ -1,13 +1,10 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( with~sitearg~
, withDevelAppPort
) where
import Foundation
import Import
import Settings
import Yesod.Static
import Yesod.Auth
@ -15,7 +12,6 @@ import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers
import Yesod.Logger (Logger)
import Data.ByteString (ByteString)
import Data.Dynamic (Dynamic, toDyn)
import qualified Database.Persist.Base~importMigration~

View File

@ -1,6 +1,3 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
module Foundation
( ~sitearg~ (..)
, ~sitearg~Route (..)
@ -17,6 +14,7 @@ module Foundation
, AuthRoute (..)
) where
import Prelude
import Yesod
import Yesod.Static (Static, base64md5, StaticRoute(..))
import Settings.StaticFiles
@ -95,7 +93,7 @@ instance Yesod ~sitearg~ where
pc <- widgetToPageContent $ do
$(widgetFile "normalize")
$(widgetFile "default-layout")
hamletToRepHtml $(hamletFile "hamlet/default-layout-wrapper.hamlet")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticRoot setting in Settings.hs

View File

@ -1,7 +1,6 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module Handler.Root where
import Foundation
import Import
-- This is a handler function for the GET request method on the RootR
-- resource pattern. All of your resource patterns are defined in

View File

@ -0,0 +1,18 @@
module Import
( module Prelude
, module Foundation
, (<>)
, Text
, module Data.Monoid
, module Control.Applicative
) where
import Prelude hiding (writeFile, readFile)
import Foundation
import Data.Monoid (Monoid (mappend, mempty, mconcat))
import Control.Applicative ((<$>), (<*>), pure)
import Data.Text (Text)
infixr 5 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend

View File

@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, GADTs #-}
module Model where
import Prelude
import Yesod
import Data.Text (Text)
~modelImports~

View File

@ -1,6 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# 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
@ -13,6 +10,7 @@ module Settings
, staticDir
) where
import Prelude (FilePath, String)
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
import Database.Persist.~importPersist~ (~configPersist~)

View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
module Settings.StaticFiles where
import Yesod.Static (staticFiles, StaticRoute (StaticRoute))

View File

@ -0,0 +1 @@
User-agent: *

View File

@ -1,6 +1,7 @@
import Yesod.Default.Config (fromArgs)
import Yesod.Default.Main (defaultMain)
import Application (with~sitearg~)
import Prelude (IO)
main :: IO ()
main = defaultMain fromArgs with~sitearg~

View File

@ -28,6 +28,7 @@ library
exposed-modules: Application
other-modules: Foundation
Import
Model
Settings
Settings.StaticFiles
@ -35,6 +36,17 @@ library
ghc-options: -Wall -threaded -O0
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
OverloadedStrings
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
executable ~project~
if flag(devel)
Buildable: False
@ -47,12 +59,23 @@ executable ~project~
main-is: main.hs
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
OverloadedStrings
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
build-depends: base >= 4 && < 5
, yesod >= 0.9 && < 0.10
, yesod-core >= 0.9.3 && < 0.10
, yesod-auth >= 0.7.3 && < 0.8
, yesod-static >= 0.3.1 && < 0.4
, yesod-default >= 0.3.1 && < 0.4
, yesod-default >= 0.4 && < 0.5
, yesod-form >= 0.3.3 && < 0.4
, mime-mail >= 0.3.0.3 && < 0.4
, clientsession >= 0.7.3 && < 0.8

View File

@ -1,20 +1,16 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( with~sitearg~
, withDevelAppPort
) where
import Foundation
import Import
import Settings
import Yesod.Static
import Yesod.Default.Config
import Yesod.Default.Main (defaultDevelApp, defaultRunner)
import Yesod.Default.Handlers (getFaviconR, getRobotsR)
import Yesod.Logger (Logger)
import Data.ByteString (ByteString)
import Network.Wai (Application)
import Data.Dynamic (Dynamic, toDyn)

View File

@ -1,5 +1,3 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
module Foundation
( ~sitearg~ (..)
, ~sitearg~Route (..)
@ -14,6 +12,7 @@ module Foundation
, liftIO
) where
import Prelude
import Yesod.Core
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
@ -81,7 +80,7 @@ instance Yesod ~sitearg~ where
pc <- widgetToPageContent $ do
$(widgetFile "normalize")
$(widgetFile "default-layout")
hamletToRepHtml $(hamletFile "hamlet/default-layout-wrapper.hamlet")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticroot setting in Settings.hs

View File

@ -1,6 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# 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
@ -12,6 +9,7 @@ module Settings
, staticDir
) where
import Prelude (FilePath, String)
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
import Yesod.Default.Config

View File

@ -27,12 +27,22 @@ library
Buildable: False
exposed-modules: Application
other-modules: Foundation
Import
Settings
Settings.StaticFiles
Handler.Root
ghc-options: -Wall -threaded -O0
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
OverloadedStrings
MultiParamTypeClasses
TypeFamilies
executable ~project~
if flag(devel)
Buildable: False
@ -45,10 +55,19 @@ executable ~project~
main-is: main.hs
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
OverloadedStrings
MultiParamTypeClasses
TypeFamilies
build-depends: base >= 4 && < 5
, yesod-core >= 0.9.3 && < 0.10
, yesod-static >= 0.3.1 && < 0.4
, yesod-default >= 0.3.1 && < 0.4
, yesod-default >= 0.4 && < 0.5
, clientsession >= 0.7.3 && < 0.8
, bytestring >= 0.9 && < 0.10
, text >= 0.11 && < 0.12

View File

@ -17,9 +17,10 @@ homepage: http://www.yesodweb.com/
extra-source-files:
input/*.cg
scaffold/lucius/default-layout.lucius.cg
scaffold/lucius/homepage.lucius.cg
scaffold/templates/default-layout.lucius.cg
scaffold/templates/homepage.lucius.cg
scaffold/Model.hs.cg
scaffold/Import.hs.cg
scaffold/Foundation.hs.cg
scaffold/LICENSE.cg
scaffold/mongoDBConnPool.cg
@ -28,17 +29,17 @@ extra-source-files:
scaffold/tiny/Application.hs.cg
scaffold/tiny/config/routes.cg
scaffold/tiny/Settings.hs.cg
scaffold/lucius/normalize.lucius.cg
scaffold/templates/normalize.lucius.cg
scaffold/postgresqlConnPool.cg
scaffold/sqliteConnPool.cg
scaffold/.ghci.cg
scaffold/project.cabal.cg
scaffold/Application.hs.cg
scaffold/julius/homepage.julius.cg
scaffold/hamlet/homepage.hamlet.cg
scaffold/hamlet/default-layout.hamlet.cg
scaffold/hamlet/default-layout-wrapper.hamlet.cg
scaffold/hamlet/boilerplate-layout.hamlet.cg
scaffold/templates/homepage.julius.cg
scaffold/templates/homepage.hamlet.cg
scaffold/templates/default-layout.hamlet.cg
scaffold/templates/default-layout-wrapper.hamlet.cg
scaffold/templates/boilerplate-layout.hamlet.cg
scaffold/deploy/Procfile.cg
scaffold/main.hs.cg
scaffold/Handler/Root.hs.cg