diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs
index a4146d33..7f24431a 100644
--- a/yesod-form/Yesod/Form/Fields.hs
+++ b/yesod-form/Yesod/Form/Fields.hs
@@ -4,8 +4,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Form.Fields
- ( FormMessage (..)
+ ( -- * i18n
+ FormMessage (..)
, defaultFormMessage
+ -- * Fields
, textField
, passwordField
, textareaField
@@ -26,11 +28,14 @@ module Yesod.Form.Fields
, Textarea (..)
, radioField
, boolField
+ -- * File 'AForm's
+ , fileAFormReq
+ , fileAFormOpt
) where
import Yesod.Form.Types
import Yesod.Widget
-import Yesod.Message (RenderMessage, SomeMessage (..))
+import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))
import Text.Hamlet
import Text.Blaze (ToHtml (..), preEscapedText, unsafeByteString)
import Text.Cassius
@@ -54,6 +59,12 @@ import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read
import Data.Monoid (mappend)
+import Control.Monad.IO.Class (liftIO)
+
+import Control.Applicative ((<$>))
+import qualified Data.Map as Map
+import Yesod.Handler (newIdent)
+import Yesod.Request (FileInfo)
#if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet
@@ -420,3 +431,66 @@ selectFieldHelper outside onOpt inside opts = Field
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
+ let (name, ints') =
+ case fsName fs of
+ Just x -> (x, ints)
+ Nothing ->
+ let i' = incrInts ints
+ in (pack $ 'f' : show i', i')
+ id' <- maybe (pack <$> newIdent) return $ fsId fs
+ let (res, errs) =
+ case menvs of
+ Nothing -> (FormMissing, Nothing)
+ Just (_, fenv) ->
+ case Map.lookup name fenv of
+ Nothing ->
+ let t = renderMessage master langs MsgValueRequired
+ in (FormFailure [t], Just $ toHtml t)
+ Just fi -> (FormSuccess fi, Nothing)
+ let fv = FieldView
+ { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
+ , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
+ , fvId = id'
+ , fvInput = [whamlet|
+
+|]
+ , fvErrors = errs
+ , fvRequired = True
+ }
+ return (res, (fv :), ints', Multipart)
+
+fileAFormOpt :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master (Maybe FileInfo)
+fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
+ liftIO $ print menvs
+ let (name, ints') =
+ case fsName fs of
+ Just x -> (x, ints)
+ Nothing ->
+ let i' = incrInts ints
+ in (pack $ 'f' : show i', i')
+ id' <- maybe (pack <$> newIdent) return $ fsId fs
+ let (res, errs) =
+ case menvs of
+ Nothing -> (FormMissing, Nothing)
+ Just (_, fenv) ->
+ case Map.lookup name fenv of
+ Nothing -> (FormSuccess Nothing, Nothing)
+ Just fi -> (FormSuccess $ Just fi, Nothing)
+ let fv = FieldView
+ { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
+ , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
+ , fvId = id'
+ , fvInput = [whamlet|
+
+|]
+ , fvErrors = errs
+ , fvRequired = False
+ }
+ return (res, (fv :), ints', Multipart)
+
+incrInts :: Ints -> Ints
+incrInts (IntSingle i) = IntSingle $ i + 1
+incrInts (IntCons i is) = (i + 1) `IntCons` is
diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs
index f1904f92..bc352c6d 100644
--- a/yesod-form/Yesod/Form/Functions.hs
+++ b/yesod-form/Yesod/Form/Functions.hs
@@ -43,7 +43,7 @@ import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, liftIOHandler, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet)
-import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
+import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))
import Network.Wai (requestMethod)
import Text.Hamlet (shamlet)
import Data.Monoid (mempty)
@@ -51,6 +51,7 @@ import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Message (RenderMessage (..))
import Control.Monad.IO.Class (MonadIO)
import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as L
#if __GLASGOW_HASKELL__ >= 700
#define WHAMLET whamlet
@@ -215,7 +216,9 @@ postEnv = do
else do
(p, f) <- runRequestBody
let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
- return $ Just (p', Map.fromList f)
+ return $ Just (p', Map.fromList $ filter (notEmpty . snd) f)
+ where
+ notEmpty = not . L.null . fileContent
runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoNonce form = do
diff --git a/yesod-form/hello-forms.hs b/yesod-form/hello-forms.hs
index 06fadaf9..ff7b94a1 100644
--- a/yesod-form/hello-forms.hs
+++ b/yesod-form/hello-forms.hs
@@ -16,6 +16,13 @@ data Fruit = Apple | Banana | Pear
fruits :: [(Text, Fruit)]
fruits = map (\x -> (pack $ show x, x)) [minBound..maxBound]
+mkYesod "HelloForms" [parseRoutes|
+/ RootR GET
+/mass MassR GET
+/valid ValidR GET
+/file FileR GET POST
+|]
+
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
<*> areq boolField "Bool field" Nothing
<*> aopt boolField "Opt bool field" Nothing
@@ -28,10 +35,6 @@ myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
<*> aopt (radioField fruits) "Opt radio" Nothing
data HelloForms = HelloForms
-type Handler = GHandler HelloForms HelloForms
-
-fixType :: Handler a -> Handler a
-fixType = id
instance RenderMessage HelloForms FormMessage where
renderMessage _ _ = defaultFormMessage
@@ -39,11 +42,8 @@ instance RenderMessage HelloForms FormMessage where
instance Yesod HelloForms where
approot _ = ""
-mkYesod "HelloForms" [parseRoutes|
-/ RootR GET
-/mass MassR GET
-/valid ValidR GET
-|]
+fixType :: Handler a -> Handler a
+fixType = id
getRootR = do
((res, form), enctype) <- myForm
@@ -57,6 +57,8 @@ getRootR = do
See the mass form
Validation form
+
+ File form
|]
myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable
@@ -108,3 +110,23 @@ getValidR = do
|]
main = toWaiApp HelloForms >>= run 3000
+
+fileForm = renderTable $ pure (,)
+ <*> fileAFormReq "Required file"
+ <*> fileAFormOpt "Optional file"
+
+getFileR = do
+ ((res, form), enctype) <- runFormPost fileForm
+ defaultLayout [whamlet|
+Result: #{show res}
+