Digestive functors: multiple file upload field? - haskell

Question

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