From 82bab0c08498b29b8b26548b670b81c23a7a62f5 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 5 Nov 2010 09:25:59 +0200
Subject: [PATCH] fileField and maybeFileField

---
 Yesod/Form/Fields.hs | 58 ++++++++++++++++++++++++++++++++++++++++++++
 hellowidget.hs       | 13 ++++++----
 2 files changed, 66 insertions(+), 5 deletions(-)

diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
index b59898b5..82e0a9ba 100644
--- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs
@@ -16,6 +16,7 @@ module Yesod.Form.Fields
     , boolField
     , emailField
     , urlField
+    , fileField
       -- ** Optional
     , maybeStringField
     , maybeTextareaField
@@ -28,6 +29,7 @@ module Yesod.Form.Fields
     , maybeSelectField
     , maybeEmailField
     , maybeUrlField
+    , maybeFileField
       -- * Inputs
       -- ** Required
     , stringInput
@@ -44,6 +46,10 @@ module Yesod.Form.Fields
 
 import Yesod.Form.Core
 import Yesod.Form.Profiles
+import Yesod.Request (FileInfo)
+import Yesod.Widget (GWidget)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ask)
 import Data.Time (Day, TimeOfDay)
 import Text.Hamlet
 import Data.Monoid
@@ -301,3 +307,55 @@ hiddenField = requiredFieldHelper hiddenFieldProfile
 maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)
                  => FormFieldSettings -> Maybe (Maybe String) -> f
 maybeHiddenField = optionalFieldHelper hiddenFieldProfile
+
+fileField :: (IsForm f, FormType f ~ FileInfo)
+          => FormFieldSettings -> f
+fileField ffs = toForm $ do
+    env <- lift ask
+    fenv <- lift $ lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let res =
+            if null env && null fenv
+                then FormMissing
+                else case lookup name fenv of
+                        Nothing -> FormFailure ["File is required"]
+                        Just x -> FormSuccess x
+    let fi = FieldInfo
+            { fiLabel = string label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = fileWidget theId name True
+            , fiErrors = case res of
+                            FormFailure [x] -> Just $ string x
+                            _ -> Nothing
+            , fiRequired = True
+            }
+    let res' = case res of
+                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
+                _ -> res
+    return (res', fi, Multipart)
+
+maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)
+               => FormFieldSettings -> f
+maybeFileField ffs = toForm $ do
+    fenv <- lift $ lift ask
+    let (FormFieldSettings label tooltip theId' name') = ffs
+    name <- maybe newFormIdent return name'
+    theId <- maybe newFormIdent return theId'
+    let res = FormSuccess $ lookup name fenv
+    let fi = FieldInfo
+            { fiLabel = string label
+            , fiTooltip = tooltip
+            , fiIdent = theId
+            , fiInput = fileWidget theId name False
+            , fiErrors = Nothing
+            , fiRequired = True
+            }
+    return (res, fi, Multipart)
+
+fileWidget :: String -> String -> Bool -> GWidget s m ()
+fileWidget theId name isReq = [$hamlet|
+%input#$theId$!type=file!name=$name$!:isReq:required
+|]
diff --git a/hellowidget.hs b/hellowidget.hs
index b70e6603..038768f0 100644
--- a/hellowidget.hs
+++ b/hellowidget.hs
@@ -61,7 +61,7 @@ getRootR = defaultLayout $ wrapper $ do
     addHtmlHead [$hamlet|%meta!keywords=haskell|]
 
 handleFormR = do
-    (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,)
+    (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,)
         <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing
         <*> stringField ("Another field") (Just "some default text")
         <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5)
@@ -84,11 +84,12 @@ handleFormR = do
                 (Just $ string "You can put rich text here")
         <*> maybeEmailField ("An e-mail addres") Nothing
         <*> maybeTextareaField "A text area" Nothing
-    let mhtml = case res of
-                    FormSuccess (_, _, _, _, _, _, _, x, _, _) -> Just x
-                    _ -> Nothing
+        <*> maybeFileField "Any file"
+    let (mhtml, mfile) = case res of
+                    FormSuccess (_, _, _, _, _, _, _, x, _, _, y) -> (Just x, y)
+                    _ -> (Nothing, Nothing)
     let txt = case res of
-                    FormSuccess (_, _, _, _, _, _, _, _, _, Just x) -> Just x
+                    FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _) -> Just x
                     _ -> Nothing
     defaultLayout $ do
         addCassius [$cassius|
@@ -117,6 +118,8 @@ $maybe formFailures.res failures
         $html$
     $maybe txt t
         $t$
+    $maybe mfile f
+        $show.f$
 |]
         setTitle $ string "Form"