haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fileField unabled

Browse Source 
Boils down to two changes:

* fieldParse takes a list of FileInfos
* fieldEnctype added
This commit is contained in:
Michael Snoyman 2012-11-09 08:58:01 +02:00
parent b15faa3cf8
commit 2ea1bcb5c8
7 changed files with 76 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
yesod-form/Yesod/Form/Fields.hs
View File

@ -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') =

22
yesod-form/Yesod/Form/Functions.hs
View File

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

29
yesod-form/Yesod/Form/Input.hs
View File

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

2
yesod-form/Yesod/Form/Jquery.hs
View File

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

3
yesod-form/Yesod/Form/Nic.hs
View File

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

3
yesod-form/Yesod/Form/Types.hs
View File

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

9
yesod-form/hello-forms.hs
View File

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