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

Merge branch 'master' into default-main

Browse Source
This commit is contained in:
patrick brisbin 2011-09-19 16:15:09 -04:00
commit 48bc765915
17 changed files with 105 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scripts

@ -1 +1 @@
Subproject commit fc9feeee6d330d4df7d4aab7c015387da93f0192
Subproject commit f56426fada59012329f23c928a2d7f9c3a515d75

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

@ -173,10 +173,10 @@ thResourceFromResource (Resource n _ _) =
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes three
-- middlewares: GZIP compression, JSON-P and path cleaning. This is the
-- middlewares: GZIP compression, JSON-P and autohead. This is the
-- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiApp y = gzip False . jsonp . autohead <$> toWaiAppPlain y
toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares.

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

@ -205,8 +205,9 @@ class RenderRoute (Route a) => Yesod a where
where
corrected = filter (not . TS.null) s
-- | Join the pieces of a path together into an absolute URL. This should
-- be the inverse of 'splitPath'.
-- | Builds an absolute URL by concatenating the application root with the
-- pieces of a path and a query string, if any.
-- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
joinPath :: a
-> TS.Text -- ^ application root
-> [TS.Text] -- ^ path pieces
@ -259,6 +260,10 @@ class RenderRoute (Route a) => Yesod a where
formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn
-- | Apply gzip compression to files. Default is false.
gzipCompressFiles :: a -> Bool
gzipCompressFiles _ = False
messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
messageLoggerHandler loc level msg = do

2
yesod-core/test/Test/CleanPath.hs
View File

@ -62,7 +62,7 @@ getBarR, getPlainR :: Handler RepPlain
getBarR = return $ RepPlain "bar"
getPlainR = return $ RepPlain "plain"
cleanPathTest :: IO [IO Spec]
cleanPathTest :: [Spec]
cleanPathTest =
describe "Test.CleanPath"
[ it "remove trailing slash" removeTrailingSlash

2
yesod-core/test/Test/Exceptions.hs
View File

@ -22,7 +22,7 @@ instance Yesod Y where
getRootR :: Handler ()
getRootR = error "FOOBAR" >> return ()
exceptionsTest :: IO [IO Spec]
exceptionsTest :: [Spec]
exceptionsTest = describe "Test.Exceptions"
[ it "500" case500
]

2
yesod-core/test/Test/Links.hs
View File

@ -21,7 +21,7 @@ instance Yesod Y where
getRootR :: Handler RepHtml
getRootR = defaultLayout $ addHamlet [hamlet|<a href=@{RootR}>|]
linksTest :: IO [IO Spec]
linksTest :: [Spec]
linksTest = describe "Test.Links"
[ it "linkToHome" case_linkToHome
]

2
yesod-core/test/Test/Media.hs
View File

@ -52,7 +52,7 @@ caseMediaLink = runner $ do
assertStatus 200 res
flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
mediaTest :: IO [IO Spec]
mediaTest :: [Spec]
mediaTest = describe "Test.Media"
[ it "media" caseMedia
, it "media link" caseMediaLink

2
yesod-core/test/Test/NoOverloadedStrings.hs
View File

@ -46,7 +46,7 @@ case_sanity = runner $ do
res <- request defaultRequest
assertBody mempty res
noOverloadedTest :: IO [IO Spec]
noOverloadedTest :: [Spec]
noOverloadedTest = describe "Test.NoOverloadedStrings"
[ it "sanity" case_sanity
]

2
yesod-core/test/Test/Widget.hs
View File

@ -69,7 +69,7 @@ getWhamletR = defaultLayout [whamlet|
where
embed = [whamlet|<h4>Embed|]
widgetTest :: IO [IO Spec]
widgetTest :: [Spec]
widgetTest = describe "Test.Widget"
[ it "addJuliusBody" case_addJuliusBody
, it "whamlet" case_whamlet

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

@ -1,5 +1,5 @@
name: yesod-core
version: 0.9.2
version: 0.9.3
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -95,7 +95,7 @@ test-suite runtests
build-depends: base >= 4 && < 4.3
main-is: main.hs
cpp-options: -DTEST
build-depends: hspec >= 0.6.1 && < 0.7
build-depends: hspec >= 0.8 && < 0.9
,wai-test
,wai
,yesod-core

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

@ -31,6 +31,13 @@ module Yesod.Form.Fields
-- * File 'AForm's
, fileAFormReq
, fileAFormOpt
-- * Options
, selectField'
, radioField'
, Option (..)
, optionsPersist
, optionsPairs
, optionsEnum
) where
import Yesod.Form.Types
@ -48,7 +55,7 @@ import Text.HTML.SanitizeXSS (sanitizeBalance)
import Control.Monad (when, unless)
import Data.List (intersect, nub)
import Data.Either (rights)
import Data.Maybe (catMaybes)
import Data.Maybe (catMaybes, listToMaybe)
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
@ -60,12 +67,16 @@ import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Applicative ((<$>))
import qualified Data.Map as Map
import Yesod.Handler (newIdent)
import Yesod.Handler (newIdent, liftIOHandler)
import Yesod.Request (FileInfo)
import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)
#if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet
#define HAMLET hamlet
@ -290,10 +301,13 @@ urlField = Field
}
selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
selectField = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
selectField = selectField' . optionsPairs
selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
selectField' = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -- inside
multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
multiSelectField = multiSelectFieldHelper
@ -301,7 +315,10 @@ multiSelectField = multiSelectFieldHelper
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioField = selectFieldHelper
radioField = radioField' . optionsPairs
radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
radioField' = selectFieldHelper
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
(\theId name isSel -> [WHAMLET|
<div>
@ -363,39 +380,65 @@ multiSelectFieldHelper outside inside opts = Field
selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
| otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
data Option a = Option
{ optionDisplay :: Text
, optionInternalValue :: a
, optionExternalValue :: Text
}
optionsPairs :: [(Text, a)] -> GGHandler sub master IO [Option a]
optionsPairs = return . zipWith (\external (display, internal) -> Option
{ optionDisplay = display
, optionInternalValue = internal
, optionExternalValue = pack $ show external
}) [1 :: Int ..]
optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO [Option a]
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
, SinglePiece (Key (YesodPersistBackend master) a)
)
=> [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO [Option (Key (YesodPersistBackend master) a, a)]
optionsPersist filts ords toDisplay = do
pairs <- runDB $ selectList filts ords
return $ map (\(key, value) -> Option
{ optionDisplay = toDisplay value
, optionInternalValue = (key, value)
, optionExternalValue = toSinglePiece key
}) pairs
selectFieldHelper
:: (Eq a, RenderMessage master FormMessage)
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Bool -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> [(Text, a)] -> Field sub master a
selectFieldHelper outside onOpt inside opts = Field
{ fieldParse = return . selectParser
, fieldView = \theId name val isReq ->
-> GGHandler sub master IO [Option a] -> Field sub master a
selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x -> do
opts <- opts'
return $ selectParser opts x
, fieldView = \theId name val isReq -> do
opts <- lift $ liftIOHandler opts'
outside theId name $ do
unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
flip mapM_ pairs $ \pair -> inside
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
flip mapM_ opts $ \opt -> inside
theId
name
(pack $ show $ fst pair)
((render val) == pack (show $ fst pair))
(fst $ snd pair)
(optionExternalValue opt)
((render opts val) == optionExternalValue opt)
(optionDisplay opt)
}
where
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
rpairs = zip (map snd opts) [1 :: Int ..]
render (Left _) = ""
render (Right a) = maybe "" (pack . show) $ lookup a rpairs
selectParser [] = Right Nothing
selectParser (s:_) = case s of
render _ (Left _) = ""
render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
selectParser _ [] = Right Nothing
selectParser opts (s:_) = case s of
"" -> Right Nothing
"none" -> Right Nothing
x -> case Data.Text.Read.decimal x of
Right (a, "") ->
case lookup a pairs of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
Just y -> Right $ Just $ snd y
_ -> Left $ SomeMessage $ MsgInvalidNumber x
x -> case listToMaybe $ filter ((== x) . optionExternalValue) opts of
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
Just y -> Right $ Just $ optionInternalValue y
fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo
fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do

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

@ -1,5 +1,5 @@
name: yesod-form
version: 0.3.2.1
version: 0.3.3
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -15,6 +15,7 @@ description: Form handling support for Yesod Web Framework
library
build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10
, yesod-persistent >= 0.2 && < 0.3
, time >= 1.1.4 && < 1.3
, hamlet >= 0.10 && < 0.11
, shakespeare-css >= 0.10 && < 0.11

3
yesod-static/tests/runtests.hs
View File

@ -6,7 +6,8 @@ import Test.Hspec.HUnit ()
-- import Test.Hspec.QuickCheck (prop)
main :: IO ()
main = hspecX $ return [] {- FIXME specs
main = return () -- hspecX $ return []
{- FIXME specs
specs :: IO [Spec]
specs = runSpecM $ do

2
yesod-static/tests/unicode/wai-app-static.cabal
View File

@ -48,7 +48,7 @@ test-suite runtests
type: exitcode-stdio-1.0
build-depends: base >= 4 && < 5
, hspec >= 0.6.1 && < 0.7
, hspec >= 0.8 && < 0.9
, HUnit
, unix-compat >= 0.2 && < 0.3
, time >= 1.1.4 && < 1.3

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

@ -44,7 +44,7 @@ test-suite runtests
cpp-options: -DTEST
build-depends: yesod-static
, base >= 4 && < 5
, hspec >= 0.6.1 && < 0.7
, hspec >= 0.8 && < 0.9
, HUnit
ghc-options: -Wall
main-is: runtests.hs

9
yesod/Devel.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Devel
( devel
) where
@ -35,6 +36,12 @@ import Text.Shakespeare.Text (st)
import Build (recompDeps, getDeps,findHaskellFiles)
#if __GLASGOW_HASKELL__ >= 700
#define ST st
#else
#define ST $st
#endif
lockFile :: FilePath
lockFile = "dist/devel-terminate"
@ -137,7 +144,7 @@ showPkgName :: D.PackageId -> String
showPkgName = (\(D.PackageName n) -> n) . D.pkgName
develFile :: D.PackageId -> T.Text
develFile pid = [st|
develFile pid = [ST|
{-# LANGUAGE PackageImports #-}
import "#{showPkgName pid}" Application (withDevelAppPort)
import Data.Dynamic (fromDynamic)

4
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 0.9.2.1
version: 0.9.2.2
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -100,7 +100,7 @@ executable yesod
, attoparsec-text >= 0.8.5 && < 0.9
, http-types >= 0.6.1 && < 0.7
, blaze-builder >= 0.2 && < 0.4
, filepath >= 1.2 && < 1.3
, filepath >= 1.1 && < 1.3
, process
ghc-options: -Wall -threaded
main-is: main.hs