fileAForm*

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|
+<input type=file name=#{name} ##{id'}>
+|]
+            , 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|
+<input type=file name=#{name} ##{id'}>
+|]
+            , 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

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

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
     <a href=@{MassR}>See the mass form
 <p>
     <a href=@{ValidR}>Validation form
+<p>
+    <a href=@{FileR}>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|
+<p>Result: #{show res}
+<form method=post enctype=#{enctype}>
+    <table>
+        ^{form}
+    <tr>
+        <td>
+            <input type=submit>
+<p>
+    <a href=@{RootR}>See the regular form
+|]
+
+postFileR = getFileR

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         0.3.1
+version:         0.3.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>