消化函子：多文件上传字段？

Question

我试图重新创建相当标准的图像/文件上传功能，其中给定字段允许上传一个或多个文件/图像，例如＆＃34;添加另一个文件＆＃34;按钮和/或替换现有文件的能力。

我有文件上传工作，我有多个子表单工作，但我不能使用文件输入多个子表单。

我已经基于examples/dynamic-list.hs大量创建了一个示例（如下所示），它强调了问题，似乎是postForm在视图中返回了一个合适的FilePath，但是没有在＆＃34;结果＆中返回它＃34 ;.

dynamic-list.hs的另一个问题是它只显示了使用静态数据的一个简单的用例。拥有一个实际的动态表单，其中数据响应用户输入而变化要复杂得多，所以我希望能够制作更全面的dynamic-list.hs版本，这对于（更多）更有帮助初学者。

到目前为止我的代码：

{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections, ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}

module Handler.Test where

import           Prelude hiding (div, span)
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Trans

import           Data.Maybe
import           Data.Text hiding (unlines, intercalate, concat)
import           Data.Text.Encoding

import           Snap.Core hiding (method)
import           Snap.Snaplet

------------------------------------------------------------------------------
import           Heist.Splices.Html
import           Text.Digestive
import           Text.Digestive.Snap 
import           Text.Digestive.Heist
import           Text.Blaze.Html5 as H
import           Text.Digestive.Blaze.Html5 as DH
import qualified Text.Blaze.Html5.Attributes as A
import           Text.Digestive.Form
import           Text.Digestive.Util

import           Text.Blaze.Renderer.XmlHtml

import Data.List as L
------------------------------------------------------------------------------
import Application

import Helpers.Forms
import Helpers.Theme
import Debug.Trace
------------------------------------------------------------------------------

handleEntityTest :: Handler App App ()
handleEntityTest = undefined

type Product = Text
type Quantity = Int
--------------------------------------------------------------------------------
data Order = Order {
    orderName  :: Text
  , orderItems :: [OrderItem]
} deriving (Show)

data OrderItem = OrderItem
  { orderProduct :: Text
  , orderQuantity :: Quantity
  , orderFile :: Maybe FilePath
  } deriving (Show)
--------------------------------------------------------------------------------

orderForm :: Monad m => Order -> Form Html m Order
orderForm order = Order 
  <$> "orderName" .: text (Just $ orderName order)
  <*> "orderItems" .: listOf orderItemForm (Just $ orderItems order)

orderItemForm :: Monad m => Formlet Html m OrderItem
orderItemForm def = OrderItem
  <$> "product" .: text (orderProduct <$> def)
  <*> "quantity" .: stringRead "Can't parse quantity" (orderQuantity <$> def)
  <*> "file" .: file
--------------------------------------------------------------------------------
orderView :: View H.Html -> H.Html
orderView view = do
  DH.form view "" $ do
    DH.label "name" view "Order name: "
    DH.inputText "orderName" view
    H.br    
    DH.label "orderItems.indices" view "(Usually hidden) Indices: "
    DH.inputText "orderItems.indices" view
    H.br
    mapM_ orderItemView $ listSubViews "orderItems" view
    H.br
    DH.inputSubmit "Submit"     

orderItemView :: View H.Html -> H.Html
orderItemView view = do
  childErrorList "" view
  DH.label "product" view "Product: "
  DH.inputText "product" view
  H.br
  DH.label "quantity" view "Quantity: "
  DH.inputText "quantity" view
  H.br
  DH.label "file" view "file"
  DH.inputFile "file" view  
  H.br
-------------------------------------------------------

handleTest :: Handler App App ()
handleTest = do
  r <- runFormWith defaultFormConfig "test" $ orderForm $ Order "test form" [(OrderItem "" 0 Nothing)]
  case r of
    (view, Nothing) -> do
      -- GET
      renderPageHtml "Initial form view" $ toHtml $ orderView $ debugForm view
      -- POST  
    (view, Just order) -> do
      s <- runFormWith (defaultFormConfig { method = Just Get }) "test" $ orderForm $ order {orderItems = ((orderItems order) ++ [(OrderItem "" 0 Nothing)]) }
      case s of 
        (view', Nothing) -> do
          renderPageHtml "Subsequent form view" $ html 
            where 
              html = do
                p $ do 
                  mapM_ div [ br, br, br
                     , orderView $ debugForm view'
                     , toHtml $ show order
                    ]
        (view', Just order) -> do
          renderPageHtml "Subsequent form view" $ p "This shouldn't ever happen"

------------------------------------------------------------
debugForm :: View Html -> View Html
debugForm v = trace (t) v
  where 
    showTuple (path,input) = ("path : " ++ (show path) ++ "=" ++ (show input))
    t = unlines $ [
          (""), ("")
        , ("viewName : " ++ (unpack $ viewName v)  )
        , ("viewMethod : " ++ (show $ viewMethod v)  )
        , ("viewContext : " ++ (show $ viewContext v)  )
        --, ("viewInput : " ++ (unlines $ fmap (\(path, input) -> (show path) ++ "=" ++ (show input) ) $ viewInput v  ))
        , ("viewInput : " ++ (unlines $ fmap showTuple $ viewInput v  ))
        , ("debugViews : " ++ (unlines $ fmap show $ debugViewPaths v) )
      ]