From f49c16c3bae2b03fb889c6b4785f9be57c35df20 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 1 Jul 2010 08:41:14 +0300 Subject: [PATCH] Support for files in forms --- Yesod/Dispatch.hs | 8 +++++--- Yesod/Form.hs | 38 ++++++++++++++++++++------------------ Yesod/Request.hs | 14 ++++++++++---- 3 files changed, 35 insertions(+), 25 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index b006ec2b..fb8d340a 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -61,7 +61,8 @@ import Data.Char (isLower, isUpper) import Data.Serialize import qualified Data.Serialize as Ser -import Network.Wai.Parse +import Network.Wai.Parse hiding (FileInfo) +import qualified Network.Wai.Parse as NWP #if TEST import Test.Framework (testGroup, Test) @@ -122,6 +123,7 @@ typeHelper = go s@(x:_) | isLower x = VarT $ mkName s | otherwise = ConT $ mkName s + go [] = error "typeHelper: empty string to go" mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument @@ -336,8 +338,8 @@ parseWaiRequest env session' = do rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where fix1 = map (S.toString *** S.toString) - fix2 (x, FileInfo a b c) = - (S.toString x, FileInfo a b c) + fix2 (x, NWP.FileInfo a b c) = + (S.toString x, FileInfo (S.toString a) (S.toString b) c) -- | Produces a \"compute on demand\" value. The computation will be run once -- it is requested, and then the result will be stored. This will happen only diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 780636a2..aa231410 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -71,34 +71,36 @@ instance Applicative FormResult where _ <*> _ = FormMissing newtype Form sub y a = Form - { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) + { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) } type Formlet sub y a = Maybe a -> Form sub y a type Env = [(String, String)] +type FileEnv = [(String, FileInfo)] instance Functor (Form sub url) where - fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) + fmap f (Form g) = Form $ \env fe -> liftM (first $ fmap f) (g env fe) instance Applicative (Form sub url) where - pure a = Form $ const $ return (pure a, mempty) - (Form f) <*> (Form g) = Form $ \env -> do - (f1, f2) <- f env - (g1, g2) <- g env + pure a = Form $ const $ const $ return (pure a, mempty) + (Form f) <*> (Form g) = Form $ \env fe -> do + (f1, f2) <- f env fe + (g1, g2) <- g env fe return (f1 <*> g1, f2 `mappend` g2) runFormGeneric :: Env + -> FileEnv -> Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) -runFormGeneric env f = evalStateT (deform f env) 1 +runFormGeneric env fe f = evalStateT (deform f env fe) 1 -- | Run a form against POST parameters. runFormPost :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormPost f = do rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - runFormGeneric pp f + (pp, files) <- liftIO $ reqRequestBody rr + runFormGeneric pp files f -- | Run a form against POST parameters, disregarding the resulting HTML and -- returning an error response on invalid input. @@ -120,7 +122,7 @@ runFormGet :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormGet f = do gs <- reqGetParams `fmap` getRequest - runFormGeneric gs f + runFormGeneric gs [] f type Incr = StateT Int @@ -134,7 +136,7 @@ incr = do input :: (String -> String -> Hamlet (Routes y)) -> Maybe String -> Form sub y String -input mkXml val = Form $ \env -> do +input mkXml val = Form $ \env _ -> do i <- incr let i' = show i let param = lookup i' env @@ -142,7 +144,7 @@ input mkXml val = Form $ \env -> do return (maybe FormMissing FormSuccess param, xml) check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b -check (Form form) f = Form $ \env -> liftM (first go) (form env) +check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe) where go FormMissing = FormMissing go (FormFailure x) = FormFailure x @@ -169,7 +171,7 @@ sealRow label getVal val = sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) +sealForm wrapper (Form form) = Form $ \env fe -> liftM go (form env fe) where go (res, xml) = (res, wrapper (toList res) xml) toList (FormFailure errs) = errs @@ -181,22 +183,22 @@ sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal -------- Prebuilt optionalField :: String -> Form sub master (Maybe String) -optionalField n = Form $ \env -> +optionalField n = Form $ \env _ -> return (FormSuccess $ lookup n env, mempty) -- FIXME requiredField :: String -> Form sub master String -requiredField n = Form $ \env -> +requiredField n = Form $ \env _ -> return (maybe FormMissing FormSuccess $ lookup n env, mempty) -- FIXME notEmptyField :: String -> Form sub master String -notEmptyField n = Form $ \env -> return +notEmptyField n = Form $ \env _ -> return (case lookup n env of Nothing -> FormMissing Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] Just x -> FormSuccess x, mempty) -- FIXME boolField :: String -> Form sub master Bool -boolField n = Form $ \env -> return +boolField n = Form $ \env _ -> return (FormSuccess $ isJust $ lookup n env, mempty) -- FIXME class Formable a where @@ -299,7 +301,7 @@ instance Formable (Maybe Int64) where [] -> Left ["Invalid integer"] instance Formable Bool where - formable x = Form $ \env -> do + formable x = Form $ \env _ -> do i <- incr let i' = show i let param = lookup i' env diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 6171289c..f89bc67b 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -46,7 +46,6 @@ import qualified Network.Wai as W import qualified Data.ByteString.Lazy as BL import "transformers" Control.Monad.IO.Class import Control.Monad (liftM) -import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) @@ -85,9 +84,16 @@ waiRequest = reqWaiRequest `liftM` getRequest -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo BL.ByteString)] + , [(ParamName, FileInfo)] ) +data FileInfo = FileInfo + { fileName :: String + , fileContentType :: String + , fileContent :: BL.ByteString + } + deriving (Eq, Show) + -- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] @@ -134,13 +140,13 @@ lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. lookupFile :: (MonadIO m, RequestReader m) => ParamName - -> m (Maybe (FileInfo BL.ByteString)) + -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: (MonadIO m, RequestReader m) => ParamName - -> m [FileInfo BL.ByteString] + -> m [FileInfo] lookupFiles pn = do rr <- getRequest (_, files) <- liftIO $ reqRequestBody rr