From 2ea1bcb5c8a1e07d2fe4cbdd8c8d5ed566ac0ae6 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 9 Nov 2012 08:58:01 +0200
Subject: [PATCH] fileField unabled

Boils down to two changes:

* fieldParse takes a list of FileInfos
* fieldEnctype added
---
 yesod-form/Yesod/Form/Fields.hs    | 40 +++++++++++++++++++++++++-----
 yesod-form/Yesod/Form/Functions.hs | 22 +++++++++-------
 yesod-form/Yesod/Form/Input.hs     | 29 ++++++++++++----------
 yesod-form/Yesod/Form/Jquery.hs    |  2 ++
 yesod-form/Yesod/Form/Nic.hs       |  3 ++-
 yesod-form/Yesod/Form/Types.hs     |  3 ++-
 yesod-form/hello-forms.hs          |  9 +++++--
 7 files changed, 76 insertions(+), 32 deletions(-)

diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs
index e56db56a..275cb4c3 100644
--- a/yesod-form/Yesod/Form/Fields.hs
+++ b/yesod-form/Yesod/Form/Fields.hs
@@ -27,6 +27,7 @@ module Yesod.Form.Fields
     , Textarea (..)
     , boolField
     , checkBoxField
+    , fileField
       -- * File 'AForm's
     , fileAFormReq
     , fileAFormOpt
@@ -104,6 +105,7 @@ intField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
   where
     showVal = either id (pack . showI)
@@ -120,6 +122,7 @@ doubleField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
   where showVal = either id (pack . show)
 
@@ -130,6 +133,7 @@ dayField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
   where showVal = either id (pack . show)
 
@@ -140,6 +144,7 @@ timeField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
   where
     showVal = either id (pack . show . roundFullSeconds)
@@ -156,6 +161,7 @@ $newline never
 $# FIXME: There was a class="html" attribute, for what purpose?
 <textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
 |]
+    , fieldEnctype = UrlEncoded
     }
   where showVal = either id (pack . renderHtml)
 
@@ -184,6 +190,7 @@ textareaField = Field
 $newline never
 <textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 hiddenField :: (PathPiece p, RenderMessage master FormMessage)
@@ -194,6 +201,7 @@ hiddenField = Field
 $newline never
 <input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 textField :: RenderMessage master FormMessage => Field sub master Text
@@ -204,6 +212,7 @@ textField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 passwordField :: RenderMessage master FormMessage => Field sub master Text
@@ -213,6 +222,7 @@ passwordField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 readMay :: Read a => String -> Maybe a
@@ -286,6 +296,7 @@ emailField = Field
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 type AutoFocus = Bool
@@ -307,6 +318,7 @@ $newline never
             #{theId}
               -webkit-appearance: textfield
             |]
+    , fieldEnctype = UrlEncoded
     }
 
 urlField :: RenderMessage master FormMessage => Field sub master Text
@@ -320,6 +332,7 @@ urlField = Field
 $newline never
 <input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
@@ -347,10 +360,10 @@ multiSelectField :: (Eq a, RenderMessage master FormMessage)
                  => GHandler sub master (OptionList a)
                  -> Field sub master [a]
 multiSelectField ioptlist =
-    Field parse view
+    Field parse view UrlEncoded
   where
-    parse [] = return $ Right Nothing
-    parse optlist = do
+    parse [] _ = return $ Right Nothing
+    parse optlist _ = do
         mapopt <- olReadExternal <$> ioptlist
         case mapM mapopt optlist of
              Nothing -> return $ Left "Error parsing values"
@@ -395,7 +408,7 @@ $newline never
 
 boolField :: RenderMessage master FormMessage => Field sub master Bool
 boolField = Field
-      { fieldParse = return . boolParser
+      { fieldParse = \e _ -> return $ boolParser e
       , fieldView = \theId name attrs val isReq -> [whamlet|
 $newline never
   $if not isReq
@@ -409,6 +422,7 @@ $newline never
 <input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
 <label for=#{theId}-no>_{MsgBoolNo}
 |]
+    , fieldEnctype = UrlEncoded
     }
   where
     boolParser [] = Right Nothing
@@ -430,11 +444,12 @@ $newline never
 --
 checkBoxField :: RenderMessage m FormMessage => Field s m Bool
 checkBoxField = Field
-    { fieldParse = return . checkBoxParser
+    { fieldParse = \e _ -> return $ checkBoxParser e
     , fieldView  = \theId name attrs val _ -> [whamlet|
 $newline never
 <input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
 |]
+    , fieldEnctype = UrlEncoded
     }
 
     where
@@ -499,7 +514,7 @@ selectFieldHelper
         -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
         -> GHandler sub master (OptionList a) -> Field sub master a
 selectFieldHelper outside onOpt inside opts' = Field
-    { fieldParse = \x -> do
+    { fieldParse = \x _ -> do
         opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name attrs val isReq -> do
@@ -513,6 +528,7 @@ selectFieldHelper outside onOpt inside opts' = Field
                 (optionExternalValue opt)
                 ((render opts val) == optionExternalValue opt)
                 (optionDisplay opt)
+    , fieldEnctype = UrlEncoded
     }
   where
     render _ (Left _) = ""
@@ -525,6 +541,18 @@ selectFieldHelper outside onOpt inside opts' = Field
                     Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
                     Just y -> Right $ Just y
 
+fileField :: RenderMessage master FormMessage => Field sub master FileInfo
+fileField = Field
+    { fieldParse = \_ files -> return $
+        case files of
+            [] -> Right Nothing
+            file:_ -> Right $ Just file
+    , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|
+            <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>
+        |]
+    , fieldEnctype = Multipart
+    }
+
 fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo
 fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
     let (name, ints') =
diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs
index bce62479..ab3bd3c2 100644
--- a/yesod-form/Yesod/Form/Functions.hs
+++ b/yesod-form/Yesod/Form/Functions.hs
@@ -65,6 +65,7 @@ import qualified Data.Map as Map
 import qualified Data.Text.Encoding as TE
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
+import Yesod.Request (FileInfo)
 
 -- | Get a unique identifier.
 newFormIdent :: MForm sub master Text
@@ -119,6 +120,7 @@ mhelper :: Field sub master a
         -> MForm sub master (FormResult b, FieldView sub master)
 
 mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
+    tell fieldEnctype
     mp <- askParams
     name <- maybe newFormIdent return fsName
     theId <- lift $ maybe newIdent return fsId
@@ -128,8 +130,10 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         case mp of
             Nothing -> return (FormMissing, maybe (Left "") Right mdef)
             Just p -> do
+                mfs <- askFiles
                 let mvals = fromMaybe [] $ Map.lookup name p
-                emx <- lift $ fieldParse mvals
+                    files = fromMaybe [] $ mfs >>= Map.lookup name
+                emx <- lift $ fieldParse mvals files
                 return $ case emx of
                     Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
                     Right mx ->
@@ -371,8 +375,8 @@ checkMMap :: RenderMessage master msg
           -> Field sub master a
           -> Field sub master b
 checkMMap f inv field = field
-    { fieldParse = \ts -> do
-        e1 <- fieldParse field ts
+    { fieldParse = \ts fs -> do
+        e1 <- fieldParse field ts fs
         case e1 of
             Left msg -> return $ Left msg
             Right Nothing -> return $ Right Nothing
@@ -393,8 +397,8 @@ checkMMod = checkMMap
 
 -- | Allows you to overwrite the error message on parse error.
 customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a
-customErrorMessage msg field = field { fieldParse = \ts -> fmap (either
-(const $ Left msg) Right) $ fieldParse field ts }
+customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either
+(const $ Left msg) Right) $ fieldParse field ts fs }
 
 -- | Generate a 'FieldSettings' from the given label.
 fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master
@@ -414,7 +418,7 @@ aformM action = AForm $ \_ _ ints -> do
 -- Since 1.1
 parseHelper :: (Monad m, RenderMessage master FormMessage)
             => (Text -> Either FormMessage a)
-            -> [Text] -> m (Either (SomeMessage master) (Maybe a))
-parseHelper _ [] = return $ Right Nothing
-parseHelper _ ("":_) = return $ Right Nothing
-parseHelper f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
+            -> [Text] -> [FileInfo] -> m (Either (SomeMessage master) (Maybe a))
+parseHelper _ [] _ = return $ Right Nothing
+parseHelper _ ("":_) _ = return $ Right Nothing
+parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x
diff --git a/yesod-form/Yesod/Form/Input.hs b/yesod-form/Yesod/Form/Input.hs
index 289234a1..0c23677d 100644
--- a/yesod-form/Yesod/Form/Input.hs
+++ b/yesod-form/Yesod/Form/Input.hs
@@ -17,16 +17,17 @@ import Control.Monad (liftM)
 import Yesod.Message (RenderMessage (..), SomeMessage (..))
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
+import Control.Arrow ((***))
 
 type DText = [Text] -> [Text]
-newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandler sub master (Either DText a) }
+newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> FileEnv -> GHandler sub master (Either DText a) }
 instance Functor (FormInput sub master) where
-    fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
+    fmap a (FormInput f) = FormInput $ \c d e e' -> fmap (either Left (Right . a)) $ f c d e e'
 instance Applicative (FormInput sub master) where
-    pure = FormInput . const . const . const . return . Right
-    (FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
-        res1 <- f c d e
-        res2 <- x c d e
+    pure = FormInput . const . const . const . const . return . Right
+    (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do
+        res1 <- f c d e e'
+        res2 <- x c d e e'
         return $ case (res1, res2) of
             (Left a, Left b) -> Left $ a . b
             (Left a, _) -> Left a
@@ -34,18 +35,20 @@ instance Applicative (FormInput sub master) where
             (Right a, Right b) -> Right $ a b
 
 ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a
-ireq field name = FormInput $ \m l env -> do
+ireq field name = FormInput $ \m l env fenv -> do
       let filteredEnv = fromMaybe [] $ Map.lookup name env
-      emx <- fieldParse field $ filteredEnv
+          filteredFEnv = fromMaybe [] $ Map.lookup name fenv
+      emx <- fieldParse field filteredEnv filteredFEnv
       return $ case emx of
           Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
           Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
           Right (Just a) -> Right a
 
 iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)
-iopt field name = FormInput $ \m l env -> do
+iopt field name = FormInput $ \m l env fenv -> do
       let filteredEnv = fromMaybe [] $ Map.lookup name env
-      emx <- fieldParse field $ filteredEnv
+          filteredFEnv = fromMaybe [] $ Map.lookup name fenv
+      emx <- fieldParse field filteredEnv filteredFEnv
       return $ case emx of
         Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
         Right x -> Right x
@@ -55,7 +58,7 @@ runInputGet (FormInput f) = do
     env <- liftM (toMap . reqGetParams) getRequest
     m <- getYesod
     l <- languages
-    emx <- f m l env
+    emx <- f m l env Map.empty
     case emx of
         Left errs -> invalidArgs $ errs []
         Right x -> return x
@@ -65,10 +68,10 @@ toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
 
 runInputPost :: FormInput sub master a -> GHandler sub master a
 runInputPost (FormInput f) = do
-    env <- liftM (toMap . fst) runRequestBody
+    (env, fenv) <- liftM (toMap *** toMap) runRequestBody
     m <- getYesod
     l <- languages
-    emx <- f m l env
+    emx <- f m l env fenv
     case emx of
         Left errs -> invalidArgs $ errs []
         Right x -> return x
diff --git a/yesod-form/Yesod/Form/Jquery.hs b/yesod-form/Yesod/Form/Jquery.hs
index ec99c059..71719721 100644
--- a/yesod-form/Yesod/Form/Jquery.hs
+++ b/yesod-form/Yesod/Form/Jquery.hs
@@ -85,6 +85,7 @@ $(function(){
     }
 });
 |]
+    , fieldEnctype = UrlEncoded
     }
   where
     showVal = either id (pack . show)
@@ -114,6 +115,7 @@ $newline never
         toWidget [julius|
 $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
 |]
+    , fieldEnctype = UrlEncoded
     }
 
 addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()
diff --git a/yesod-form/Yesod/Form/Nic.hs b/yesod-form/Yesod/Form/Nic.hs
index 631d2a5f..4f89b8d0 100644
--- a/yesod-form/Yesod/Form/Nic.hs
+++ b/yesod-form/Yesod/Form/Nic.hs
@@ -35,7 +35,7 @@ class Yesod a => YesodNic a where
 
 nicHtmlField :: YesodNic master => Field sub master Html
 nicHtmlField = Field
-    { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
+    { fieldParse = \e _ -> return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe $ e
     , fieldView = \theId name attrs val _isReq -> do
         toWidget [shamlet|
 $newline never
@@ -51,6 +51,7 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{th
             _ -> [julius|
 (function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")})();
 |]
+    , fieldEnctype = UrlEncoded
     }
   where
     showVal = either id (pack . renderHtml)
diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs
index 2f591e27..dfe37a29 100644
--- a/yesod-form/Yesod/Form/Types.hs
+++ b/yesod-form/Yesod/Form/Types.hs
@@ -124,13 +124,14 @@ data FieldView sub master = FieldView
     }
 
 data Field sub master a = Field
-    { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))
+    { fieldParse :: [Text] -> [FileInfo] -> GHandler sub master (Either (SomeMessage master) (Maybe a))
     , fieldView :: Text -- ^ ID
                 -> Text -- ^ Name
                 -> [(Text, Text)] -- ^ Attributes
                 -> Either Text a -- ^ Either (invalid text) or (legitimate result)
                 -> Bool -- ^ Required?
                 -> GWidget sub master ()
+    , fieldEnctype :: Enctype
     }
 
 data FormMessage = MsgInvalidInteger Text
diff --git a/yesod-form/hello-forms.hs b/yesod-form/hello-forms.hs
index a82aa735..2fef48dd 100644
--- a/yesod-form/hello-forms.hs
+++ b/yesod-form/hello-forms.hs
@@ -111,8 +111,13 @@ getValidR = do
 main = toWaiApp HelloForms >>= run 3000
 
 fileForm = renderTable $ pure (,)
-    <*> fileAFormReq "Required file"
-    <*> fileAFormOpt "Optional file"
+    <*> (FileInfo' <$> areq fileField "Required file" Nothing)
+    <*> (fmap FileInfo' <$> aopt fileField "Optional file" Nothing)
+
+newtype FileInfo' = FileInfo' FileInfo
+
+instance Show FileInfo' where
+    show (FileInfo' f) = show (fileName f, fileContentType f)
 
 getFileR = do
     ((res, form), enctype) <- runFormPost fileForm