haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into yesod-1.4

Browse Source 
Conflicts:
	yesod-routes/Yesod/Routes/Parse.hs
	yesod-routes/test/Hierarchy.hs
	yesod-routes/yesod-routes.cabal
This commit is contained in:
Michael Snoyman 2014-07-26 21:20:01 +03:00
commit e6eae8ee5a
32 changed files with 657 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-auth-oauth/Yesod/Auth/OAuth.hs
View File

@ -43,6 +43,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
url = PluginR name []
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
oauthSessionName = "__oauth_token_secret"
dispatch "GET" ["forward"] = do
render <- lift getUrlRender
tm <- getRouteToParent
@ -72,8 +73,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
master <- getYesod
accTok <- getAccessToken oauth reqTok (authHttpManager master)
creds <- liftIO $ mkCreds accTok
setCreds True creds
setCredsRedirect creds
dispatch _ _ = notFound
login tm = do
render <- getUrlRender
let oaUrl = render $ tm $ oauthUrl name

10
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth-oauth
version: 1.2.0
version: 1.3.0
license: BSD3
license-file: LICENSE
author: Hiromi Ishii
@ -20,13 +20,13 @@ library
cpp-options: -DGHC7
else
build-depends: base >= 4 && < 4.3
build-depends: authenticate-oauth >= 1.4 && < 1.5
build-depends: authenticate-oauth >= 1.5 && < 1.6
, bytestring >= 0.9.1.4
, yesod-core >= 1.2 && < 1.3
, yesod-auth >= 1.2 && < 1.3
, text >= 0.7 && < 1.1
, yesod-auth >= 1.3 && < 1.4
, text >= 0.7
, yesod-form >= 1.3 && < 1.4
, transformers >= 0.2.2 && < 0.4
, transformers >= 0.2.2 && < 0.5
, lifted-base >= 0.2 && < 0.3
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

3
yesod-auth/Yesod/Auth.hs
View File

@ -57,7 +57,6 @@ import Data.Monoid (Endo)
import Network.HTTP.Conduit (Manager)
import qualified Network.Wai as W
import Text.Hamlet (shamlet)
import Yesod.Core
import Yesod.Persist
@ -483,7 +482,7 @@ type AuthEntity master = KeyEntity (AuthId master)
-- authenticated.
--
-- Since 1.1.0
requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
requireAuthId = maybeAuthId >>= maybe redirectLogin return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not

16
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -53,9 +53,10 @@ import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, MonadHandler,
getRouteToParent, getUrlRender,
getYesod, invalidArgs, lift,
liftBase, lookupGetParam,
lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:))
setSession, whamlet, (.:),
TypedContent, HandlerT, liftIO)
pid :: Text
pid = "googleemail2"
@ -75,7 +76,7 @@ getCreateCsrfToken = do
case mtoken of
Just token -> return token
Nothing -> do
stdgen <- liftBase newStdGen
stdgen <- liftIO newStdGen
let token = T.pack $ fst $ randomString 10 stdgen
setSession csrfKey token
return token
@ -111,6 +112,11 @@ authGoogleEmail clientID clientSecret =
login tm = do
url <- getDest tm
[whamlet|<a href=#{url}>_{Msg.LoginGoogle}|]
dispatch :: YesodAuth site
=> Text
-> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
lift (getDest tm) >>= redirect
@ -130,7 +136,7 @@ authGoogleEmail clientID clientSecret =
render <- getUrlRender
req' <- parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
let req =
urlEncodedBody
[ ("code", encodeUtf8 code)
@ -152,7 +158,7 @@ authGoogleEmail clientID clientSecret =
unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType
req2' <- parseUrl "https://www.googleapis.com/plus/v1/people/me"
req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
let req2 = req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.3.1
version: 1.3.1.1
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin

2
yesod-bin/Devel.hs
View File

@ -266,7 +266,7 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
unless (anyTouched || haskellFileChanged) $ loop list1
if not success
then liftIO $ do
putStrLn "Build failure, pausing..."
putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m"
runBuildHook $ failHook opts
else do
liftIO $ runBuildHook $ successHook opts

2
yesod-bin/Keter.hs
View File

@ -7,7 +7,7 @@ import Data.Yaml
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T
import System.Exit
import System.Cmd
import System.Process
import Control.Monad
import System.Directory
import Data.Maybe (mapMaybe)

1
yesod-bin/Scaffolding/Scaffolder.hs
View File

@ -73,7 +73,6 @@ scaffold isBare = do
if validPackageName s && s /= "test"
then Just s
else Nothing
let dir = project
puts $ renderTextUrl undefined $(textFile "input/database.cg")

84
yesod-bin/hsfiles/mongo.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -204,6 +211,13 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -351,6 +365,7 @@ import Database.Persist.Quasi
import Database.Persist.MongoDB hiding (master)
import Language.Haskell.TH.Syntax
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -594,6 +609,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

84
yesod-bin/hsfiles/mysql.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -211,6 +218,13 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -358,6 +372,7 @@ import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -598,6 +613,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

84
yesod-bin/hsfiles/postgres-fay.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -215,6 +222,13 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -390,6 +404,7 @@ import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -647,6 +662,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

84
yesod-bin/hsfiles/postgres.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -211,6 +218,13 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -358,6 +372,7 @@ import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -598,6 +613,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

83
yesod-bin/hsfiles/simple.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -189,6 +196,13 @@ instance Yesod App where
Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
urlRenderOverride _ _ = Nothing
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -517,6 +531,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

84
yesod-bin/hsfiles/sqlite.hsfiles
View File

@ -1,5 +1,12 @@
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .ghci #-}
:set -i.:config:dist/build/autogen
:set -DDEVELOPMENT
:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable
{-# START_FILE .gitignore #-}
@ -211,6 +218,13 @@ instance Yesod App where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authenitcation.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
-- Default to Authorized for now.
isAuthorized _ _ = return Authorized
-- 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
@ -358,6 +372,7 @@ import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Prelude
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -598,6 +613,75 @@ combineStylesheets = combineStylesheets' development combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts' development combineSettings
{-# START_FILE app/DevelMain.hs #-}
-- | Development version to be run inside GHCi.
--
-- start this up with:
--
-- cabal repl --ghc-options="-O0 -fobject-code"
--
-- run with:
--
-- :l DevelMain
-- DevelMain.update
--
-- You will need to add these packages to your .cabal file
-- * foreign-store >= 0.1 (very light-weight)
-- * warp (you already depend on this, it just isn't in your .cabal file)
--
-- If you don't use cabal repl, you will need
-- to add settings to your .ghci file.
--
-- :set -DDEVELOPMENT
--
-- There is more information about using ghci
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
module DevelMain where
import Application (getApplicationDev)
import Control.Exception (finally)
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
-- | Start or restart the server.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore ->
-- shut the server down with killThread and wait for the done signal
modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar >> readStore doneStore >>= start
where
doneStore = Store 0
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port,app) <- getApplicationDev
forkIO (finally (runSettings (setPort port defaultSettings) app)
(putMVar done ()))
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Yesod.Default.Config (fromArgs)

2
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.2.10.2
version: 1.2.11
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

2
yesod-core/README
View File

@ -1 +1 @@
Learn more at http://docs.yesodweb.com/
Learn more at http://www.yesodweb.com/

4
yesod-core/Yesod/Core/Handler.hs
View File

@ -1018,8 +1018,8 @@ lookupCookies pn = do
-- representations, e.g.:
--
-- > selectRep $ do
-- > provideRep typeHtml $ produceHtmlOutput
-- > provideRep typeJson $ produceJsonOutput
-- > provideRep produceHtmlOutput
-- > provideRep produceJsonOutput
--
-- The first provided representation will be used if no matches are found.

2
yesod-form/Yesod/Form/Fields.hs
View File

@ -237,7 +237,7 @@ $newline never
}
readMay :: Read a => String -> Maybe a
readMay s = case reads s of
readMay s = case filter (Prelude.null . snd) $ reads s of
(x, _):_ -> Just x
[] -> Nothing

26
yesod-form/Yesod/Form/Functions.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -23,6 +24,7 @@ module Yesod.Form.Functions
, runFormGet
-- * Generate a blank form
, generateFormPost
, generateFormGet'
, generateFormGet
-- * More than one form on a handler
, identifyForm
@ -270,6 +272,17 @@ runFormGet form = do
Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
getHelper form env
{- FIXME: generateFormGet' "Will be renamed to generateFormGet in next verison of Yesod" -}
-- |
--
-- Since 1.3.11
generateFormGet'
:: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
=> (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype)
generateFormGet' form = first snd `liftM` getHelper form Nothing
{-# DEPRECATED generateFormGet "Will require RenderMessage in next verison of Yesod" #-}
generateFormGet :: MonadHandler m
=> (Html -> MForm m a)
-> m (a, Enctype)
@ -345,15 +358,21 @@ type FormRender m a =
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow
-- you to add extra rows to the table, this function does /not/ wrap up
-- the resulting HTML in a table tag; you must do that yourself.
renderTable aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
$if null views
\#{fragment}
$forall (isFirst, view) <- addIsFirst views
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
<td>
$if isFirst
\#{fragment}
<label for=#{fvId view}>#{fvLabel view}
$maybe tt <- fvTooltip view
<div .tooltip>#{tt}
@ -362,6 +381,9 @@ $forall view <- views
<td .errors>#{err}
|]
return (res, widget)
where
addIsFirst [] = []
addIsFirst (x:y) = (True, x) : map (False, ) y
-- | render a field inside a div
renderDivs = renderDivsMaybeLabels True

2
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.3.10
version: 1.3.11
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

6
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -20,6 +20,7 @@
-- | Generation of Atom newsfeeds.
module Yesod.AtomFeed
( atomFeed
, atomFeedText
, atomLink
, RepAtom (..)
, module Yesod.FeedTypes
@ -47,6 +48,11 @@ atomFeed feed = do
render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render
-- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
atomFeedText :: MonadHandler m => Feed Text -> m RepAtom
atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
Document (Prologue [] Nothing []) (addNS root) []

10
yesod-newsfeed/Yesod/Feed.hs
View File

@ -17,6 +17,7 @@
-------------------------------------------------------------------------------
module Yesod.Feed
( newsFeed
, newsFeedText
, module Yesod.FeedTypes
) where
@ -25,7 +26,16 @@ import Yesod.AtomFeed
import Yesod.RssFeed
import Yesod.Core
import Data.Text
newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed f = selectRep $ do
provideRep $ atomFeed f
provideRep $ rssFeed f
-- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
newsFeedText :: MonadHandler m => Feed Text -> m TypedContent
newsFeedText f = selectRep $ do
provideRep $ atomFeedText f
provideRep $ rssFeedText f

6
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -16,6 +16,7 @@
-------------------------------------------------------------------------------
module Yesod.RssFeed
( rssFeed
, rssFeedText
, rssLink
, RepRss (..)
, module Yesod.FeedTypes
@ -44,6 +45,11 @@ rssFeed feed = do
render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render
-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
-- generating a feed of external links.
rssFeedText :: MonadHandler m => Feed Text -> m RepRss
rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
Document (Prologue [] Nothing []) root []

45
yesod-routes/Yesod/Routes/Parse.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Routes.Parse
( parseRoutes
@ -18,6 +19,8 @@ import qualified System.IO as SIO
import Yesod.Routes.TH
import Yesod.Routes.Overlap (findOverlapNames)
import Data.List (foldl')
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@ -67,14 +70,30 @@ resourcesFromString =
| length spaces < indent = ([], thisLine : otherLines)
| otherwise = (this others, remainder)
where
parseAttr ('!':x) = Just x
parseAttr _ = Nothing
stripColonLast =
go id
where
go _ [] = Nothing
go front [x]
| null x = Nothing
| last x == ':' = Just $ front [init x]
| otherwise = Nothing
go front (x:xs) = go (front . (x:)) xs
spaces = takeWhile (== ' ') thisLine
(others, remainder) = parse indent otherLines'
(this, otherLines') =
case takeWhile (/= "--") $ words thisLine of
[pattern, constr] | last constr == ':' ->
(pattern:rest0)
| Just (constr:rest) <- stripColonLast rest0
, Just attrs <- mapM parseAttr rest ->
let (children, otherLines'') = parse (length spaces + 1) otherLines
children' = addAttrs attrs children
(pieces, Nothing, check) = piecesFromStringCheck pattern
in ((ResourceParent (init constr) check pieces children :), otherLines'')
in ((ResourceParent constr check pieces children' :), otherLines'')
(pattern:constr:rest) ->
let (pieces, mmulti, check) = piecesFromStringCheck pattern
(attrs, rest') = takeAttrs rest
@ -96,6 +115,28 @@ piecesFromStringCheck s0 =
stripBang ('!':rest) = (rest, False)
stripBang x = (x, True)
addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
addAttrs attrs =
map goTree
where
goTree (ResourceLeaf res) = ResourceLeaf (goRes res)
goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z)
goRes res =
res { resourceAttrs = noDupes ++ resourceAttrs res }
where
usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res
used attr =
case toPair attr of
Nothing -> False
Just (key, _) -> key `Set.member` usedKeys
noDupes = filter (not . used) attrs
toPair s =
case break (== '=') s of
(x, '=':y) -> Just (x, y)
_ -> Nothing
-- | Take attributes out of the list and put them in the first slot in the
-- result tuple.
takeAttrs :: [String] -> ([String], [String])

15
yesod-routes/test/Hierarchy.hs
View File

@ -32,6 +32,7 @@ import qualified Data.ByteString.Char8 as S8
#if SIMPLE_DISPATCH
import Yesod.Routes.TH.Simple
#endif
import qualified Data.Set as Set
class ToText a where
toText :: a -> Text
@ -89,9 +90,9 @@ do
/login LoginR GET POST
/table/#Text TableR GET
/nest/ NestR:
/nest/ NestR !NestingAttr:
/spaces SpacedR GET
/spaces SpacedR GET !NonNested
/nest2 Nest2:
/ GetPostR GET POST
@ -103,8 +104,8 @@ do
/post Post3 POST
-- /#Int Delete3 DELETE
/afterwards AfterR:
/ After GET
/afterwards AfterR !parent !key=value1:
/ After GET !child !key=value2
-- /trailing-nest TrailingNestR:
-- /foo TrailingFooR GET
@ -112,6 +113,7 @@ do
|]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
#if SIMPLE_DISPATCH
dispatch <- mkSimpleDispatchClause MkDispatchSettings
@ -135,6 +137,7 @@ do
`AppT` ConT ''Hierarchy)
[FunD (mkName "dispatcher") [dispatch]]
: prinst
: rainst
: rrinst
getSpacedR :: Handler site String
@ -208,3 +211,7 @@ hierarchy = describe "hierarchy" $ do
parseRoute ([], [("foo", "bar")]) @?= Just HomeR
parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)
parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
it "inherited attributes" $ do
routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]
it "pair attributes" $
routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]

11
yesod-test/Yesod/Test.hs
View File

@ -421,10 +421,10 @@ nameFromLabel label = do
Just res -> return res
let
body = simpleBody res
mfor = parseHTML body
mlabel = parseHTML body
$// C.element "label"
>=> contentContains label
>=> attribute "for"
mfor = mlabel >>= attribute "for"
contentContains x c
| x `T.isInfixOf` T.concat (c $// content) = [c]
@ -444,8 +444,11 @@ nameFromLabel label = do
, " which was not found. "
]
name:_ -> return name
_ -> failure $ "More than one input with id " <> for
[] -> failure $ "No label contained: " <> label
[] -> failure $ "No input with id " <> for
[] ->
case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
[] -> failure $ "No label contained: " <> label
name:_ -> return name
_ -> failure $ "More than one label contained " <> label
(<>) :: T.Text -> T.Text -> T.Text

11
yesod-test/test/main.hs
View File

@ -132,6 +132,14 @@ main = hspec $ do
get ("/dynamic2/שלום" :: Text)
statusIs 200
bodyEquals "שלום"
ydescribe "labels" $ do
yit "can click checkbox" $ do
get ("/labels" :: Text)
request $ do
setMethod "POST"
setUrl ("/labels" :: Text)
byLabel "Foo Bar" "yes"
describe "cookies" $ yesodSpec cookieApp $ do
yit "should send the cookie #730" $ do
get ("/" :: Text)
@ -174,6 +182,9 @@ app = liteApp $ do
onStatic "html" $ dispatchTo $
return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)
onStatic "labels" $ dispatchTo $
return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
cookieApp :: LiteApp
cookieApp = liteApp $ do

2
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test
version: 1.2.3
version: 1.2.3.1
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>

4
yesod-websockets/Yesod/WebSockets.hs
View File

@ -67,13 +67,13 @@ webSockets inner = do
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
receiveData = ReaderT $ liftIO . WS.receiveData
-- | Send a textual messsage to the client.
-- | Send a textual message to the client.
--
-- Since 0.1.0
sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x
-- | Send a binary messsage to the client.
-- | Send a binary message to the client.
--
-- Since 0.1.0
sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()

2
yesod-websockets/yesod-websockets.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: yesod-websockets
version: 0.1.1.1
version: 0.1.1.2
synopsis: WebSockets support for Yesod
description: WebSockets support for Yesod
homepage: https://github.com/yesodweb/yesod

2
yesod/Yesod/Default/Config.hs
View File

@ -23,7 +23,7 @@ import Data.Maybe (fromMaybe)
import qualified Data.HashMap.Strict as M
import System.Environment (getArgs, getProgName, getEnvironment)
import System.Exit (exitFailure)
import Data.Conduit.Network (HostPreference)
import Data.Streaming.Network (HostPreference)
import Data.String (fromString)
-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and

3
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 1.2.6
version: 1.2.6.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -50,6 +50,7 @@ library
, fast-logger
, conduit-extra
, shakespeare
, streaming-commons
exposed-modules: Yesod
, Yesod.Default.Config