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 -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes three -- 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. -- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application 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 -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares. -- 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 where
corrected = filter (not . TS.null) s corrected = filter (not . TS.null) s
-- | Join the pieces of a path together into an absolute URL. This should -- | Builds an absolute URL by concatenating the application root with the
-- be the inverse of 'splitPath'. -- 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 joinPath :: a
-> TS.Text -- ^ application root -> TS.Text -- ^ application root
-> [TS.Text] -- ^ path pieces -> [TS.Text] -- ^ path pieces
@ -259,6 +260,10 @@ class RenderRoute (Route a) => Yesod a where
formatLogMessage loc level msg >>= formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn Data.Text.Lazy.IO.putStrLn
-- | Apply gzip compression to files. Default is false.
gzipCompressFiles :: a -> Bool
gzipCompressFiles _ = False
messageLoggerHandler :: (Yesod m, MonadIO mo) messageLoggerHandler :: (Yesod m, MonadIO mo)
=> Loc -> LogLevel -> Text -> GGHandler s m mo () => Loc -> LogLevel -> Text -> GGHandler s m mo ()
messageLoggerHandler loc level msg = do 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" getBarR = return $ RepPlain "bar"
getPlainR = return $ RepPlain "plain" getPlainR = return $ RepPlain "plain"
cleanPathTest :: IO [IO Spec] cleanPathTest :: [Spec]
cleanPathTest = cleanPathTest =
describe "Test.CleanPath" describe "Test.CleanPath"
[ it "remove trailing slash" removeTrailingSlash [ 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 :: Handler ()
getRootR = error "FOOBAR" >> return () getRootR = error "FOOBAR" >> return ()
exceptionsTest :: IO [IO Spec] exceptionsTest :: [Spec]
exceptionsTest = describe "Test.Exceptions" exceptionsTest = describe "Test.Exceptions"
[ it "500" case500 [ it "500" case500
] ]

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

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

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

@ -52,7 +52,7 @@ caseMediaLink = runner $ do
assertStatus 200 res 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>" 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" mediaTest = describe "Test.Media"
[ it "media" caseMedia [ it "media" caseMedia
, it "media link" caseMediaLink , it "media link" caseMediaLink

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

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

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

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

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

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

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

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

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

@ -1,5 +1,5 @@
name: yesod-form name: yesod-form
version: 0.3.2.1 version: 0.3.3
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -15,6 +15,7 @@ description: Form handling support for Yesod Web Framework
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 0.9 && < 0.10 , yesod-core >= 0.9 && < 0.10
, yesod-persistent >= 0.2 && < 0.3
, time >= 1.1.4 && < 1.3 , time >= 1.1.4 && < 1.3
, hamlet >= 0.10 && < 0.11 , hamlet >= 0.10 && < 0.11
, shakespeare-css >= 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) -- import Test.Hspec.QuickCheck (prop)
main :: IO () main :: IO ()
main = hspecX $ return [] {- FIXME specs main = return () -- hspecX $ return []
{- FIXME specs
specs :: IO [Spec] specs :: IO [Spec]
specs = runSpecM $ do 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 type: exitcode-stdio-1.0
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, hspec >= 0.6.1 && < 0.7 , hspec >= 0.8 && < 0.9
, HUnit , HUnit
, unix-compat >= 0.2 && < 0.3 , unix-compat >= 0.2 && < 0.3
, time >= 1.1.4 && < 1.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 cpp-options: -DTEST
build-depends: yesod-static build-depends: yesod-static
, base >= 4 && < 5 , base >= 4 && < 5
, hspec >= 0.6.1 && < 0.7 , hspec >= 0.8 && < 0.9
, HUnit , HUnit
ghc-options: -Wall ghc-options: -Wall
main-is: runtests.hs main-is: runtests.hs

9
yesod/Devel.hs
View File

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

4
yesod/yesod.cabal
View File

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