Add an UploadFile constructor

jaspervdj · Feb 18, 2012 · 22cef57 · 22cef57
1 parent 96de62e
commit 22cef57
Show file tree

Hide file tree

Showing 6 changed files with 31 additions and 20 deletions.
diff --git a/digestive-functors/src/Text/Digestive/Field.hs b/digestive-functors/src/Text/Digestive/Field.hs
@@ -19,28 +19,32 @@ data Field v a where
     Text      :: Text -> Field v Text
     Choice    :: Eq a => [(a, v)] -> Int -> Field v a
     Bool      :: Bool -> Field v Bool
+    Upload    :: Field v (Maybe FilePath)
 
 instance Show (Field v a) where
     show (Singleton _) = "Singleton _"
     show (Text t)      = "Text " ++ show t
     show (Choice _ _)  = "Choice _ _"
     show (Bool b)      = "Bool " ++ show b
+    show (Upload)      = "Upload"
 
 data SomeField v = forall a. SomeField (Field v a)
 
-evalField :: Method      -- ^ Get/Post
-          -> [Text]      -- ^ Given input
-          -> Field v a   -- ^ Field
-          -> a           -- ^ Result
-evalField _    _       (Singleton x) = x
-evalField _    []      (Text x)      = x
-evalField _    (x : _) (Text _)      = x
-evalField _    []      (Choice ls x) = fst $ ls !! x
-evalField _    (x : _) (Choice ls y) = fromMaybe (fst $ ls !! y) $ do
+evalField :: Method       -- ^ Get/Post
+          -> [FormInput]  -- ^ Given input
+          -> Field v a    -- ^ Field
+          -> a            -- ^ Result
+evalField _    _                  (Singleton x) = x
+evalField _    (TextInput x : _)  (Text _)      = x
+evalField _    _                  (Text x)      = x
+evalField _    (TextInput x : _)  (Choice ls y) = fromMaybe (fst $ ls !! y) $ do
     -- Expects input in the form of @foo.bar.2@
     t <- listToMaybe $ reverse $ toPath x
     i <- readMaybe $ T.unpack t
     return $ fst $ ls !! i
-evalField Get  _       (Bool x)      = x
-evalField Post []      (Bool _)      = False
-evalField Post (x : _) (Bool _)      = x == "on"
+evalField _    _                  (Choice ls x) = fst $ ls !! x
+evalField Get  _                  (Bool x)      = x
+evalField Post (TextInput x : _)  (Bool _)      = x == "on"
+evalField Post _                  (Bool _)      = False
+evalField Post (FileUpload x : _) Upload        = Just x
+evalField _    _                  Upload        = Nothing
diff --git a/digestive-functors/src/Text/Digestive/Form/Internal.hs b/digestive-functors/src/Text/Digestive/Form/Internal.hs
@@ -127,11 +127,11 @@ ann _    (Success x) = Success x
 ann path (Error x)   = Error [(path, x)]
 
 eval :: Monad m => Method -> Env m -> Form m v a
-     -> m (Result [(Path, v)] a, [(Path, Text)])
+     -> m (Result [(Path, v)] a, [(Path, FormInput)])
 eval = eval' []
 
 eval' :: Monad m => Path -> Method -> Env m -> Form m v a
-      -> m (Result [(Path, v)] a, [(Path, Text)])
+      -> m (Result [(Path, v)] a, [(Path, FormInput)])
 
 eval' context method env form = case form of
 

diff --git a/digestive-functors/src/Text/Digestive/Types.hs b/digestive-functors/src/Text/Digestive/Types.hs
@@ -5,6 +5,7 @@ module Text.Digestive.Types
     , toPath
     , fromPath
     , Method (..)
+    , FormInput (..)
     , Env
     ) where
 
@@ -46,6 +47,11 @@ fromPath = T.intercalate "."
 data Method = Get | Post
     deriving (Eq, Ord, Show)
 
+data FormInput
+    = TextInput Text
+    | FileUpload FilePath
+    deriving (Show)
+
 -- | An environment (e.g. a server) from which we can read input parameters. A
 -- single key might be associated with multiple text values (multi-select).
-type Env m = Path -> m [Text]
+type Env m = Path -> m [FormInput]
diff --git a/digestive-functors/src/Text/Digestive/View.hs b/digestive-functors/src/Text/Digestive/View.hs
@@ -33,7 +33,7 @@ import Text.Digestive.Types
 
 data View m v = forall a. View
     { viewForm   :: Form m v a
-    , viewInput  :: [(Path, Text)]
+    , viewInput  :: [(Path, FormInput)]
     , viewErrors :: [(Path, v)]
     , viewMethod :: Method
     }
@@ -65,7 +65,7 @@ subView ref (View form input errs method) = case lookupForm (toPath ref) form of
         | path `isPrefixOf` xs = [drop (length path) xs]
         | otherwise            = []
 
-lookupInput :: Path -> [(Path, Text)] -> [Text]
+lookupInput :: Path -> [(Path, FormInput)] -> [FormInput]
 lookupInput path = map snd . filter ((== path) . fst)
 
 fieldInputText :: Text -> View m v -> Text

diff --git a/digestive-functors/tests/Text/Digestive/Field/Tests.hs b/digestive-functors/tests/Text/Digestive/Field/Tests.hs
@@ -19,10 +19,10 @@ tests = testGroup "Text.Digestive.Field.Tests"
         False @=? evalField Post [] (Bool True)
 
     , testCase "evalField bool post strange input" $
-        False @=? evalField Post ["herp"] (Bool True)
+        False @=? evalField Post [TextInput "herp"] (Bool True)
 
     , testCase "evalField bool post correct input" $
-        True @=? evalField Post ["on"] (Bool True)
+        True @=? evalField Post [TextInput "on"] (Bool True)
 
     , testCase "evalField bool get" $
         True @=? evalField Get [] (Bool True)

diff --git a/digestive-functors/tests/Text/Digestive/View/Tests.hs b/digestive-functors/tests/Text/Digestive/View/Tests.hs
@@ -59,7 +59,8 @@ tests = testGroup "Text.Digestive.View.Tests"
     ]
 
 testEnv :: Monad m => [(Text, Text)] -> Env m
-testEnv input key = return $ map snd $ filter ((== fromPath key) . fst) input
+testEnv input key = return $ map (TextInput . snd) $
+    filter ((== fromPath key) . fst) input
 
 fromLeft :: Either a b -> a
 fromLeft (Left x)  = x