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

yesod-core/Yesod/Dispatch.hs

@@ -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.

yesod-core/Yesod/Internal/Core.hs

@@ -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
+    -- | 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
              -> 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

yesod-core/yesod-core.cabal

@@ -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>

yesod-form/Yesod/Form/Fields.hs

@@ -31,6 +31,15 @@ module Yesod.Form.Fields
       -- * File 'AForm's
     , fileAFormReq
     , fileAFormOpt
+      -- * Options
+    , selectField'
+    , radioField'
+    , Option (..)
+    , OptionList (..)
+    , mkOptionList
+    , optionsPersist
+    , optionsPairs
+    , optionsEnum
     ) where
 
 import Yesod.Form.Types
@@ -48,7 +57,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 +69,17 @@ 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)
+import Control.Arrow ((&&&))
+
 #if __GLASGOW_HASKELL__ >= 700
 #define WHAMLET whamlet
 #define HAMLET hamlet
@@ -290,10 +304,13 @@ urlField = Field
     }
 
 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 (OptionList 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 = multiSelectFieldHelper
@@ -301,7 +318,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 (OptionList a) -> Field sub master a
+radioField' = selectFieldHelper
     (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
     (\theId name isSel -> [WHAMLET|
 <div>
@@ -363,39 +383,76 @@ 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 OptionList a = OptionList
+    { olOptions :: [Option a]
+    , olReadExternal :: Text -> Maybe a
+    }
+
+mkOptionList :: [Option a] -> OptionList a
+mkOptionList os = OptionList
+    { olOptions = os
+    , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os
+    }
+
+data Option a = Option
+    { optionDisplay :: Text
+    , optionInternalValue :: a
+    , optionExternalValue :: Text
+    }
+
+optionsPairs :: [(Text, a)] -> GGHandler sub master IO (OptionList a)
+optionsPairs = return . mkOptionList . 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 (OptionList 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 (OptionList (Key (YesodPersistBackend master) a, a))
+optionsPersist filts ords toDisplay = fmap mkOptionList $ 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
+        -> GGHandler sub master IO (OptionList 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 <- fmap olOptions $ lift $ liftIOHandler opts'
         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
                 name
-                (pack $ show $ fst pair)
+                (optionExternalValue opt)
-                ((render val) == pack (show $ fst pair))
+                ((render opts val) == optionExternalValue opt)
-                (fst $ snd pair)
+                (optionDisplay opt)
     }
   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
             "none" -> Right Nothing
-            x -> case Data.Text.Read.decimal x of
+            x -> case olReadExternal opts x of
-                    Right (a, "") ->
+                    Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-                        case lookup a pairs of
+                    Just y -> Right $ Just 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 fs = AForm $ \(master, langs) menvs ints -> do

yesod-form/yesod-form.cabal

@@ -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