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

Merge branch 'master' into yesod1.2

Browse Source
This commit is contained in:
Michael Snoyman 2013-02-12 16:59:40 +02:00
commit 8eb898931a
22 changed files with 210 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
README.md
View File

@ -27,7 +27,7 @@ Your application is a cabal package and you use `cabal` to install its dependenc
Install conflicts are unfortunately common in Haskell development. Install conflicts are unfortunately common in Haskell development.
If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken.
You can prevent this by using sandbox tools: `cabal-dev` or `virthualenv`, now being renamed to `hsenv`. You can prevent this by using sandbox tools: `cabal-dev` or `hsenv`.
Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process. Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process.
[Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it. [Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
@ -62,15 +62,13 @@ If you aren't building from an application, remove the `./` and create a new dir
## virthualenv ## hsenv (Linux only)
We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv)/[hsenv](https://github.com/Paczesiowa/hsenv) when hacking on Yesod from Linux. This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages. [hsenv](http://hackage.haskell.org/package/hsenv) prevents your custom build of Yesod from interfering with your currently installed cabal packages:
virthualenv will not work on Windows and maybe not Mac. Use cabal-dev instead * hsenv creates an isolated environment like cabal-dev
* hsenv works at the shell level, so every shell must activate the hsenv
* virthualenv creates an isolated environment like cabal-dev * cabal-dev by default isolates a single cabal package, but hsenv isolates multiple packages together.
* virthualenv works at the shell level, so every shell must activate the virthualenv
* cabal-dev by default isolates a single cabal package, but virthualenv isolates multiple packages together.
* cabal-dev can isolate multiple packages together by using the -s sandbox argument * cabal-dev can isolate multiple packages together by using the -s sandbox argument

6
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Auth.Rpxnow module Yesod.Auth.Rpxnow
( authRpxnow ( authRpxnow
) where ) where
@ -25,6 +27,10 @@ authRpxnow :: YesodAuth m
authRpxnow app apiKey = authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login AuthPlugin "rpxnow" dispatch login
where where
login ::
forall sub master.
ToWidget sub master (GWidget sub master ())
=> (Route Auth -> Route master) -> GWidget sub master ()
login tm = do login tm = do
render <- lift getUrlRender render <- lift getUrlRender
let queryString = decodeUtf8With lenientDecode let queryString = decodeUtf8With lenientDecode

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

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

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

@ -129,6 +129,7 @@ import Control.Exception hiding (Handler, catch, finally)
import Control.Applicative import Control.Applicative
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Failure (Failure (failure))
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Class (MonadTrans)
@ -1059,3 +1060,6 @@ instance MonadLogger (GHandler sub master) where
monadLoggerLogSource a b c d = do monadLoggerLogSource a b c d = do
hd <- ask hd <- ask
liftIO $ handlerLog hd a b c (toLogStr d) liftIO $ handlerLog hd a b c (toLogStr d)
instance Exception e => Failure e (GHandler sub master) where
failure = liftIO . throwIO

2
yesod-core/Yesod/Internal/Core.hs
View File

@ -878,7 +878,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
let YesodApp yapp = let YesodApp yapp =
runHandler runHandler
handler' handler'
(yesodRender master "") (yesodRender master $ resolveApproot master fakeWaiRequest)
Nothing Nothing
id id
master master

4
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core name: yesod-core
version: 1.1.7.1 version: 1.1.8
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -72,7 +72,7 @@ library
, monad-control >= 0.3 && < 0.4 , monad-control >= 0.3 && < 0.4
, transformers-base >= 0.4 , transformers-base >= 0.4
, cookie >= 0.4 && < 0.5 , cookie >= 0.4 && < 0.5
, http-types >= 0.7 && < 0.8 , http-types >= 0.7
, case-insensitive >= 0.2 , case-insensitive >= 0.2
, parsec >= 2 && < 3.2 , parsec >= 2 && < 3.2
, directory >= 1 , directory >= 1

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

@ -60,6 +60,10 @@ import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)
import Text.Cassius import Text.Cassius
import Data.Time (Day, TimeOfDay(..)) import Data.Time (Day, TimeOfDay(..))
import qualified Text.Email.Validate as Email import qualified Text.Email.Validate as Email
#if MIN_VERSION_email_validate(1, 0, 0)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
#endif
import Network.URI (parseURI) import Network.URI (parseURI)
import Database.Persist (PersistField) import Database.Persist (PersistField)
import Database.Persist.Store (Entity (..)) import Database.Persist.Store (Entity (..))
@ -291,9 +295,16 @@ timeParser = do
emailField :: RenderMessage master FormMessage => Field sub master Text emailField :: RenderMessage master FormMessage => Field sub master Text
emailField = Field emailField = Field
{ fieldParse = parseHelper $ { fieldParse = parseHelper $
#if MIN_VERSION_email_validate(1, 0, 0)
\s ->
case Email.canonicalizeEmail $ encodeUtf8 s of
Just e -> Right $ decodeUtf8With lenientDecode e
Nothing -> Left $ MsgInvalidEmail s
#else
\s -> if Email.isValid (unpack s) \s -> if Email.isValid (unpack s)
then Right s then Right s
else Left $ MsgInvalidEmail s else Left $ MsgInvalidEmail s
#endif
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never $newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">

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

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

52
yesod-platform/yesod-platform.cabal
View File

@ -1,5 +1,5 @@
name: yesod-platform name: yesod-platform
version: 1.1.6.1 version: 1.1.7.2
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -33,19 +33,21 @@ library
, byteorder == 1.0.3 , byteorder == 1.0.3
, case-insensitive == 0.4.0.4 , case-insensitive == 0.4.0.4
, cereal == 0.3.5.2 , cereal == 0.3.5.2
, certificate == 1.3.3 , certificate == 1.3.5
, cipher-aes == 0.1.7
, cipher-rc4 == 0.1.2
, classy-prelude == 0.4.3 , classy-prelude == 0.4.3
, classy-prelude-conduit == 0.4.3 , classy-prelude-conduit == 0.4.3
, clientsession == 0.8.0.1 , clientsession == 0.8.1
, conduit == 0.5.6 , conduit == 0.5.6
, cookie == 0.4.0.1 , cookie == 0.4.0.1
, cprng-aes == 0.3.1 , cprng-aes == 0.3.4
, cpu == 0.1.1
, crypto-api == 0.10.2 , crypto-api == 0.10.2
, crypto-conduit == 0.4.2 , crypto-conduit == 0.4.3
, crypto-numbers == 0.1.3
, crypto-pubkey == 0.1.2
, crypto-pubkey-types == 0.2.0 , crypto-pubkey-types == 0.2.0
, crypto-random-api == 0.1.0 , crypto-random-api == 0.2.0
, cryptocipher == 0.3.7
, cryptohash == 0.8.3 , cryptohash == 0.8.3
, css-text == 0.1.1 , css-text == 0.1.1
, data-default == 0.5.0 , data-default == 0.5.0
@ -57,30 +59,30 @@ library
, fast-logger == 0.3.1 , fast-logger == 0.3.1
, file-embed == 0.0.4.7 , file-embed == 0.0.4.7
, filesystem-conduit == 0.5.0.2 , filesystem-conduit == 0.5.0.2
, fsnotify == 0.0.5 , fsnotify == 0.0.6
, ghc-paths == 0.1.0.9 , ghc-paths == 0.1.0.9
, hamlet == 1.1.3.1 , hamlet == 1.1.3.1
, hashable == 1.1.2.5 , hashable == 1.2.0.5
, hjsmin == 0.1.4 , hjsmin == 0.1.4
, hspec == 1.4.3 , hspec == 1.4.3
, hspec-expectations == 0.3.0.3 , hspec-expectations == 0.3.0.3
, html-conduit == 0.1.0.4 , html-conduit == 0.1.0.4
, http-conduit == 1.8.6.1 , http-conduit == 1.8.7
, http-date == 0.0.3 , http-date == 0.0.4
, http-reverse-proxy == 0.1.1 , http-reverse-proxy == 0.1.1.1
, http-types == 0.7.3.0.1 , http-types == 0.7.3.0.1
, language-javascript == 0.5.7 , language-javascript == 0.5.7
, largeword == 1.0.4 , largeword == 1.0.4
, lifted-base == 0.2.0.2 , lifted-base == 0.2.0.2
, mime-mail == 0.4.1.2 , mime-mail == 0.4.1.2
, mime-types == 0.1.0.1 , mime-types == 0.1.0.2
, monad-control == 0.3.1.4 , monad-control == 0.3.1.4
, monad-logger == 0.2.3.2 , monad-logger == 0.2.3.2
, network-conduit == 0.6.2.1 , network-conduit == 0.6.2.2
, optparse-applicative == 0.5.2.1 , optparse-applicative == 0.5.2.1
, path-pieces == 0.1.2 , path-pieces == 0.1.2
, pem == 0.1.2 , pem == 0.1.2
, persistent == 1.1.3.2 , persistent == 1.1.4
, persistent-template == 1.1.2.1 , persistent-template == 1.1.2.1
, pool-conduit == 0.1.1 , pool-conduit == 0.1.1
, primitive == 0.5.0.1 , primitive == 0.5.0.1
@ -91,7 +93,7 @@ library
, resource-pool == 0.2.1.1 , resource-pool == 0.2.1.1
, resourcet == 0.4.4 , resourcet == 0.4.4
, safe == 0.3.3 , safe == 0.3.3
, semigroups == 0.8.5 , semigroups == 0.9
, setenv == 0.1.0 , setenv == 0.1.0
, shakespeare == 1.0.2 , shakespeare == 1.0.2
, shakespeare-css == 1.0.2 , shakespeare-css == 1.0.2
@ -100,18 +102,18 @@ library
, shakespeare-text == 1.0.0.5 , shakespeare-text == 1.0.0.5
, silently == 1.2.4.1 , silently == 1.2.4.1
, simple-sendfile == 0.2.10 , simple-sendfile == 0.2.10
, skein == 0.1.0.10 , skein == 0.1.0.11
, socks == 0.4.2 , socks == 0.4.2
, split == 0.2.1.1 , split == 0.2.1.1
, stringsearch == 0.3.6.4 , stringsearch == 0.3.6.4
, system-fileio == 0.3.10 , system-fileio == 0.3.11
, system-filepath == 0.4.7 , system-filepath == 0.4.7
, tagged == 0.4.4 , tagged == 0.4.4
, tagsoup == 0.12.8 , tagsoup == 0.12.8
, tagstream-conduit == 0.5.3 , tagstream-conduit == 0.5.3
, tar == 0.4.0.1 , tar == 0.4.0.1
, tls == 1.0.3 , tls == 1.1.1
, tls-extra == 0.5.1 , tls-extra == 0.6.1
, transformers-base == 0.4.1 , transformers-base == 0.4.1
, unix-compat == 0.4.1.0 , unix-compat == 0.4.1.0
, unordered-containers == 0.2.3.0 , unordered-containers == 0.2.3.0
@ -119,13 +121,13 @@ library
, utf8-string == 0.3.7 , utf8-string == 0.3.7
, vault == 0.2.0.4 , vault == 0.2.0.4
, vector == 0.10.0.1 , vector == 0.10.0.1
, void == 0.5.10 , void == 0.5.11
, wai == 1.3.0.1 , wai == 1.3.0.1
, wai-app-static == 1.3.1 , wai-app-static == 1.3.1
, wai-extra == 1.3.1.1 , wai-extra == 1.3.2
, wai-logger == 0.3.0 , wai-logger == 0.3.0
, wai-test == 1.3.0 , wai-test == 1.3.0
, warp == 1.3.6 , warp == 1.3.7.1
, word8 == 0.0.3 , word8 == 0.0.3
, xml-conduit == 1.0.3.3 , xml-conduit == 1.0.3.3
, xml-types == 0.3.3 , xml-types == 0.3.3
@ -141,7 +143,7 @@ library
, yesod-routes == 1.1.1.1 , yesod-routes == 1.1.1.1
, yesod-static == 1.1.1.2 , yesod-static == 1.1.1.2
, yesod-test == 0.3.3 , yesod-test == 0.3.3
, zlib-bindings == 0.1.1.2 , zlib-bindings == 0.1.1.3
, zlib-conduit == 0.5.0.3 , zlib-conduit == 0.5.0.3
exposed-modules: Yesod.Platform exposed-modules: Yesod.Platform

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

@ -1,5 +1,5 @@
name: yesod-routes name: yesod-routes
version: 1.1.1.1 version: 1.1.2
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>

4
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static name: yesod-static
version: 1.1.1.2 version: 1.1.2
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -34,7 +34,7 @@ library
, wai >= 1.3 && < 1.4 , wai >= 1.3 && < 1.4
, text >= 0.9 , text >= 0.9
, file-embed >= 0.0.4.1 && < 0.5 , file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.7 && < 0.8 , http-types >= 0.7
, unix-compat >= 0.2 , unix-compat >= 0.2
, conduit >= 0.5 && < 0.6 , conduit >= 0.5 && < 0.6
, crypto-conduit >= 0.4 && < 0.5 , crypto-conduit >= 0.4 && < 0.5

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

@ -33,7 +33,7 @@ module Yesod.Test (
-- add values, add files, lookup fields by label and find the current -- add values, add files, lookup fields by label and find the current
-- nonce value and add it to your request too. -- nonce value and add it to your request too.
-- --
post, post_, get, get_, doRequest, post, post_, get, get_, doRequest, doRequestHeaders,
byName, fileByName, byName, fileByName,
-- | Yesod cat auto generate field ids, so you are never sure what -- | Yesod cat auto generate field ids, so you are never sure what
@ -363,9 +363,14 @@ get url paramsBuild = doRequest "GET" url paramsBuild
get_ :: BS8.ByteString -> OneSpec conn () get_ :: BS8.ByteString -> OneSpec conn ()
get_ = flip get $ return () get_ = flip get $ return ()
-- | General interface to performing requests, letting you specify the request method and extra headers. -- | General interface to performing requests, letting you specify the request method
doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> OneSpec conn () doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> OneSpec conn ()
doRequest method url paramsBuild = do doRequest method url paramsBuild = doRequestHeaders method url [] paramsBuild
-- | General interface to performing requests, allowing you to add extra
-- headers as well as letting you specify the request method.
doRequestHeaders :: H.Method -> BS8.ByteString -> [H.Header] -> RequestBuilder a -> OneSpec conn ()
doRequestHeaders method url extrahead paramsBuild = do
OneSpecData app conn oldCookies mRes <- ST.get OneSpecData app conn oldCookies mRes <- ST.get
-- expire cookies and filter them for the current path. TODO: support max age -- expire cookies and filter them for the current path. TODO: support max age
@ -398,10 +403,11 @@ doRequest method url paramsBuild = do
boundary = "*******noneedtomakethisrandom" boundary = "*******noneedtomakethisrandom"
separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
makeMultipart cookies parts = makeMultipart cookies parts =
flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest $
[ ("Cookie", Builder.toByteString $ Cookie.renderCookies [ ("Cookie", Builder.toByteString $ Cookie.renderCookies
[(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
, ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)] , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)
] ++ extrahead
multiPartBody parts = multiPartBody parts =
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
multipartPart (ReqPlainPart k v) = BS8.concat multipartPart (ReqPlainPart k v) = BS8.concat
@ -416,10 +422,11 @@ doRequest method url paramsBuild = do
, BS8.concat $ BSL8.toChunks bytes, "\r\n"] , BS8.concat $ BSL8.toChunks bytes, "\r\n"]
-- For building the regular non-multipart requests -- For building the regular non-multipart requests
makeSinglepart cookies parts = SRequest (mkRequest makeSinglepart cookies parts = SRequest (mkRequest $
[ ("Cookie", Builder.toByteString $ Cookie.renderCookies [ ("Cookie", Builder.toByteString $ Cookie.renderCookies
[(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
, ("Content-Type", "application/x-www-form-urlencoded")]) $ , ("Content-Type", "application/x-www-form-urlencoded")
] ++ extrahead) $
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts
singlepartPart (ReqFilePart _ _ _ _) = "" singlepartPart (ReqFilePart _ _ _ _) = ""

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

@ -1,5 +1,5 @@
name: yesod-test name: yesod-test
version: 0.3.3 version: 0.3.3.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar> author: Nubis <nubis@woobiz.com.ar>
@ -21,7 +21,7 @@ library
, wai >= 1.3 && < 1.4 , wai >= 1.3 && < 1.4
, wai-test >= 1.3 && < 1.4 , wai-test >= 1.3 && < 1.4
, network >= 2.2 , network >= 2.2
, http-types >= 0.7 && < 0.8 , http-types >= 0.7
, HUnit >= 1.2 && < 1.3 , HUnit >= 1.2 && < 1.3
, hspec >= 1.4 , hspec >= 1.4
, bytestring >= 0.9 , bytestring >= 0.9

5
yesod/Devel.hs
View File

@ -107,13 +107,14 @@ data DevelOpts = DevelOpts
, failHook :: Maybe String , failHook :: Maybe String
, buildDir :: Maybe String , buildDir :: Maybe String
, develPort :: Int , develPort :: Int
, proxyTimeout :: Int
} deriving (Show, Eq) } deriving (Show, Eq)
getBuildDir :: DevelOpts -> String getBuildDir :: DevelOpts -> String
getBuildDir opts = fromMaybe "dist" (buildDir opts) getBuildDir opts = fromMaybe "dist" (buildDir opts)
defaultDevelOpts :: DevelOpts defaultDevelOpts :: DevelOpts
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10
-- | Run a reverse proxy from port 3000 to 3001. If there is no response on -- | Run a reverse proxy from port 3000 to 3001. If there is no response on
-- 3001, give an appropriate message to the user. -- 3001, give an appropriate message to the user.
@ -127,7 +128,7 @@ reverseProxy opts iappPort = do
return $ Right $ ProxyDest "127.0.0.1" appPort) return $ Right $ ProxyDest "127.0.0.1" appPort)
def def
{ wpsOnExc = onExc { wpsOnExc = onExc
, wpsTimeout = Just 10000000 , wpsTimeout = Just (1000000 * proxyTimeout opts)
} }
manager manager
putStrLn "Reverse proxy stopped, but it shouldn't" putStrLn "Reverse proxy stopped, but it shouldn't"

47
yesod/GhcBuild.hs
View File

@ -19,29 +19,30 @@
module GhcBuild (getBuildFlags, buildPackage) where module GhcBuild (getBuildFlags, buildPackage) where
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad (when) import Control.Monad (when)
import Data.IORef import Data.IORef
import System.Process (rawSystem) import System.Process (rawSystem)
import System.Environment (getEnvironment)
import CmdLineParser import CmdLineParser
import Data.Char (toLower) import Data.Char (toLower)
import Data.List (isPrefixOf, partition) import Data.List (isPrefixOf, partition)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename, import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename,
isSourceFilename, startPhase) isSourceFilename, startPhase)
import DriverPipeline (compileFile, link, linkBinary, oneShot) import DriverPipeline (compileFile, link, linkBinary, oneShot)
import DynFlags (DynFlags, compilerInfo) import DynFlags (DynFlags, compilerInfo)
import qualified DynFlags import qualified DynFlags
import qualified GHC import qualified GHC
import GHC.Paths (libdir) import GHC.Paths (libdir)
import HscTypes (HscEnv (..), emptyHomePackageTable) import HscTypes (HscEnv (..), emptyHomePackageTable)
import MonadUtils (liftIO) import MonadUtils (liftIO)
import Panic (ghcError, panic) import Panic (ghcError, panic)
import SrcLoc (Located, mkGeneralLocated) import SrcLoc (Located, mkGeneralLocated)
import StaticFlags (v_Ld_inputs) import StaticFlags (v_Ld_inputs)
import qualified StaticFlags import qualified StaticFlags
import System.FilePath (normalise, (</>)) import System.FilePath (normalise, (</>))
import Util (consIORef, looksLikeModuleName) import Util (consIORef, looksLikeModuleName)
{- {-
This contains a huge hack: This contains a huge hack:
@ -53,7 +54,8 @@ import Util (consIORef, looksLikeModuleName)
getBuildFlags :: IO [Located String] getBuildFlags :: IO [Located String]
getBuildFlags = do getBuildFlags = do
argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 argv0' <- prependHsenvArgv argv0
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0'
mbMinusB | null minusB_args = Nothing mbMinusB | null minusB_args = Nothing
| otherwise = Just (drop 2 (last minusB_args)) | otherwise = Just (drop 2 (last minusB_args))
let argv1' = map (mkGeneralLocated "on the commandline") argv1 let argv1' = map (mkGeneralLocated "on the commandline") argv1
@ -61,6 +63,14 @@ getBuildFlags = do
(argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
return argv2 return argv2
prependHsenvArgv :: [String] -> IO [String]
prependHsenvArgv argv = do
env <- getEnvironment
return $ case (lookup "HSENV" env) of
Nothing -> argv
_ -> hsenvArgv ++ argv
where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)
buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool
buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do
putStrLn ("exception building package: " ++ show (e :: Ex.SomeException)) putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))
@ -416,4 +426,3 @@ isCompManagerMode DoMake = True
isCompManagerMode DoInteractive = True isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _) = True isCompManagerMode (DoEval _) = True
isCompManagerMode _ = False isCompManagerMode _ = False

2
yesod/ghcwrapper.hs
View File

@ -58,5 +58,3 @@ main = do
when e $ writeFile outFile (show args ++ "\n") when e $ writeFile outFile (show args ++ "\n")
ex <- runProgram cmd args ex <- runProgram cmd args
exitWith ex exitWith ex

26
yesod/hsfiles/mongo.hsfiles
View File

@ -425,6 +425,7 @@ test-suite test
, yesod-core , yesod-core
, persistent , persistent
, persistent-mongoDB , persistent-mongoDB
, resourcet
{-# START_FILE Settings.hs #-} {-# START_FILE Settings.hs #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
@ -5728,10 +5729,12 @@ module HomeTest
) where ) where
import TestImport import TestImport
import qualified Data.List as L
homeSpecs :: Specs homeSpecs :: Specs
homeSpecs = homeSpecs =
describe "These are some example tests" $ describe "These are some example tests" $ do
it "loads the index and checks it looks right" $ do it "loads the index and checks it looks right" $ do
get_ "/" get_ "/"
statusIs 200 statusIs 200
@ -5747,21 +5750,38 @@ homeSpecs =
htmlAllContain ".message" "Some Content" htmlAllContain ".message" "Some Content"
htmlAllContain ".message" "text/plain" htmlAllContain ".message" "text/plain"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get_ "/"
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ L.length users
{-# START_FILE tests/TestImport.hs #-} {-# START_FILE tests/TestImport.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module TestImport module TestImport
( module Yesod.Test ( module Yesod.Test
, module Model
, module Database.Persist
, runDB , runDB
, Specs , Specs
) where ) where
import Yesod.Test import Yesod.Test
import Database.Persist hiding (get)
import Database.Persist.MongoDB hiding (master) import Database.Persist.MongoDB hiding (master)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Model
type Specs = SpecsConn Connection type Specs = SpecsConn Connection
runDB :: Action IO a -> OneSpec Connection a runDB :: Action (ResourceT IO) a -> OneSpec Connection a
runDB = runDBRunner runMongoDBPoolDef runDB = runDBRunner poolRunner
where
poolRunner query pool = runResourceT $ runMongoDBPoolDef query pool
{-# START_FILE tests/main.hs #-} {-# START_FILE tests/main.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}

28
yesod/hsfiles/mysql.hsfiles
View File

@ -423,6 +423,7 @@ test-suite test
, yesod-core , yesod-core
, persistent , persistent
, persistent-mysql , persistent-mysql
, resourcet
{-# START_FILE Settings.hs #-} {-# START_FILE Settings.hs #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
@ -5752,10 +5753,12 @@ module HomeTest
) where ) where
import TestImport import TestImport
import qualified Data.List as L
homeSpecs :: Specs homeSpecs :: Specs
homeSpecs = homeSpecs =
describe "These are some example tests" $ describe "These are some example tests" $ do
it "loads the index and checks it looks right" $ do it "loads the index and checks it looks right" $ do
get_ "/" get_ "/"
statusIs 200 statusIs 200
@ -5771,21 +5774,38 @@ homeSpecs =
htmlAllContain ".message" "Some Content" htmlAllContain ".message" "Some Content"
htmlAllContain ".message" "text/plain" htmlAllContain ".message" "text/plain"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get_ "/"
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ L.length users
{-# START_FILE tests/TestImport.hs #-} {-# START_FILE tests/TestImport.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module TestImport module TestImport
( module Yesod.Test ( module Yesod.Test
, module Model
, module Database.Persist
, runDB , runDB
, Specs , Specs
) where ) where
import Yesod.Test import Yesod.Test
import Database.Persist.GenericSql import Database.Persist hiding (get)
import Database.Persist.GenericSql (runSqlPool, SqlPersist, Connection)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Model
type Specs = SpecsConn Connection type Specs = SpecsConn Connection
runDB :: SqlPersist IO a -> OneSpec Connection a runDB :: SqlPersist (ResourceT IO) a -> OneSpec Connection a
runDB = runDBRunner runSqlPool runDB = runDBRunner poolRunner
where
poolRunner query pool = runResourceT $ runSqlPool query pool
{-# START_FILE tests/main.hs #-} {-# START_FILE tests/main.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}

28
yesod/hsfiles/postgres.hsfiles
View File

@ -423,6 +423,7 @@ test-suite test
, yesod-core , yesod-core
, persistent , persistent
, persistent-postgresql , persistent-postgresql
, resourcet
{-# START_FILE Settings.hs #-} {-# START_FILE Settings.hs #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
@ -5726,10 +5727,12 @@ module HomeTest
) where ) where
import TestImport import TestImport
import qualified Data.List as L
homeSpecs :: Specs homeSpecs :: Specs
homeSpecs = homeSpecs =
describe "These are some example tests" $ describe "These are some example tests" $ do
it "loads the index and checks it looks right" $ do it "loads the index and checks it looks right" $ do
get_ "/" get_ "/"
statusIs 200 statusIs 200
@ -5745,21 +5748,38 @@ homeSpecs =
htmlAllContain ".message" "Some Content" htmlAllContain ".message" "Some Content"
htmlAllContain ".message" "text/plain" htmlAllContain ".message" "text/plain"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get_ "/"
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ L.length users
{-# START_FILE tests/TestImport.hs #-} {-# START_FILE tests/TestImport.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module TestImport module TestImport
( module Yesod.Test ( module Yesod.Test
, module Model
, module Database.Persist
, runDB , runDB
, Specs , Specs
) where ) where
import Yesod.Test import Yesod.Test
import Database.Persist.GenericSql import Database.Persist hiding (get)
import Database.Persist.GenericSql (runSqlPool, SqlPersist, Connection)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Model
type Specs = SpecsConn Connection type Specs = SpecsConn Connection
runDB :: SqlPersist IO a -> OneSpec Connection a runDB :: SqlPersist (ResourceT IO) a -> OneSpec Connection a
runDB = runDBRunner runSqlPool runDB = runDBRunner poolRunner
where
poolRunner query pool = runResourceT $ runSqlPool query pool
{-# START_FILE tests/main.hs #-} {-# START_FILE tests/main.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}

28
yesod/hsfiles/sqlite.hsfiles
View File

@ -423,6 +423,7 @@ test-suite test
, yesod-core , yesod-core
, persistent , persistent
, persistent-sqlite , persistent-sqlite
, resourcet
{-# START_FILE Settings.hs #-} {-# START_FILE Settings.hs #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
@ -5722,10 +5723,12 @@ module HomeTest
) where ) where
import TestImport import TestImport
import qualified Data.List as L
homeSpecs :: Specs homeSpecs :: Specs
homeSpecs = homeSpecs =
describe "These are some example tests" $ describe "These are some example tests" $ do
it "loads the index and checks it looks right" $ do it "loads the index and checks it looks right" $ do
get_ "/" get_ "/"
statusIs 200 statusIs 200
@ -5741,21 +5744,38 @@ homeSpecs =
htmlAllContain ".message" "Some Content" htmlAllContain ".message" "Some Content"
htmlAllContain ".message" "text/plain" htmlAllContain ".message" "text/plain"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get_ "/"
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEqual "user table empty" 0 $ L.length users
{-# START_FILE tests/TestImport.hs #-} {-# START_FILE tests/TestImport.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module TestImport module TestImport
( module Yesod.Test ( module Yesod.Test
, module Model
, module Database.Persist
, runDB , runDB
, Specs , Specs
) where ) where
import Yesod.Test import Yesod.Test
import Database.Persist.GenericSql import Database.Persist hiding (get)
import Database.Persist.GenericSql (runSqlPool, SqlPersist, Connection)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Model
type Specs = SpecsConn Connection type Specs = SpecsConn Connection
runDB :: SqlPersist IO a -> OneSpec Connection a runDB :: SqlPersist (ResourceT IO) a -> OneSpec Connection a
runDB = runDBRunner runSqlPool runDB = runDBRunner poolRunner
where
poolRunner query pool = runResourceT $ runSqlPool query pool
{-# START_FILE tests/main.hs #-} {-# START_FILE tests/main.hs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}

5
yesod/main.hs
View File

@ -58,6 +58,7 @@ data Command = Init
, develIgnore :: [String] , develIgnore :: [String]
, develExtraArgs :: [String] , develExtraArgs :: [String]
, _develPort :: Int , _develPort :: Int
, _proxyTimeout :: Int
} }
| Test | Test
| AddHandler | AddHandler
@ -95,7 +96,7 @@ main = do
Configure -> cabal ["configure"] Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es) Build es -> touch' >> cabal ("build":es)
Touch -> touch' Touch -> touch'
Devel da s f r b _ig es p -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p) es Devel da s f r b _ig es p t -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p t) es
Keter noRebuild -> keter (cabalCommand o) noRebuild Keter noRebuild -> keter (cabalCommand o) noRebuild
Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) Version -> do putStrLn ("yesod-core version:" ++ yesodVersion)
putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
@ -152,6 +153,8 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
<*> extraCabalArgs <*> extraCabalArgs
<*> option ( long "port" <> short 'p' <> value 3000 <> metavar "N" <*> option ( long "port" <> short 'p' <> value 3000 <> metavar "N"
<> help "Devel server listening port" ) <> help "Devel server listening port" )
<*> option ( long "proxy-timeout" <> short 'x' <> value 10 <> metavar "N"
<> help "Devel server timeout before returning 'not ready' message (in seconds)" )
extraCabalArgs :: Parser [String] extraCabalArgs :: Parser [String]
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"

4
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod name: yesod
version: 1.1.7.2 version: 1.1.8
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -86,7 +86,7 @@ executable yesod
, unix-compat >= 0.2 && < 0.5 , unix-compat >= 0.2 && < 0.5
, containers >= 0.2 , containers >= 0.2
, attoparsec >= 0.10 , attoparsec >= 0.10
, http-types >= 0.7 && < 0.8 , http-types >= 0.7
, blaze-builder >= 0.2.1.4 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4
, filepath >= 1.1 , filepath >= 1.1
, process , process