Dynamically generated multiple file upload field?

[simg]

I'm trying to recreate fairly standard image / file upload functionality whereby a given field allows the uploading of one or more files / images with something like an "add another file" button and/or the ability to replace existing files.

I have file uploads working and I have multiple subforms working, but I can't get multiple subforms working with file input.

I have created an example (shown below) heavily based on examples/dynamic-list.hs which highlights the problem, which appears to be that postForm returns an appropriate FilePath in the view but does not return it in the "result".

Another problem with dynamic-list.hs is that it only shows a trivial use case using static data. Having an actual dynamic form where the data changes in response to user input is significantly more complicated, so I'm hoping that I can hammer out a more comprehensive version of dynamic-list.hs which would be (much) more helpful to beginners.

My code so far:

{-# 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) )
      ]
'''