diff --git a/servant-multipart/servant-multipart.cabal b/servant-multipart/servant-multipart.cabal index 8114e34..f27e943 100644 --- a/servant-multipart/servant-multipart.cabal +++ b/servant-multipart/servant-multipart.cabal @@ -63,6 +63,7 @@ test-suite servant-multipart-test , string-conversions , tasty , tasty-wai + , tasty-hunit , text source-repository head diff --git a/servant-multipart/src/Servant/Multipart.hs b/servant-multipart/src/Servant/Multipart.hs index 7a2826f..b1fe33a 100644 --- a/servant-multipart/src/Servant/Multipart.hs +++ b/servant-multipart/src/Servant/Multipart.hs @@ -21,8 +21,13 @@ module Servant.Multipart , MultipartForm' , MultipartData(..) , FromMultipart(..) + , FromText (..) , lookupInput , lookupFile + , lookupAllInputs + , lookupAllFiles + , lookupInputAs + , lookupAllInputsAs , MultipartOptions(..) , defaultMultipartOptions , MultipartBackend(..) @@ -75,6 +80,115 @@ lookupFile iname = . find ((==iname) . fdInputName) . files +-- | Lookup all textual inputs with the given @name@ attribute. +-- +-- This function returns a list of all values for inputs with the specified name. +-- It is useful when handling forms that allow multiple inputs with the same name, +-- such as multiple select inputs or checkboxes. If no inputs are found, Left is returned +-- +-- Example: +-- +-- >>> let mpd = MultipartData [Input "color" "red", Input "color" "blue"] [] +-- >>> lookupAllInputs "color" mpd +-- ["red", "blue"] +-- >>> lookupAllInputs "size" mpd +-- [] +lookupAllInputs :: Text -> MultipartData tag -> Either String [Text] +lookupAllInputs iname mpd = + let lst = [ val | (Input name val) <- inputs mpd, name == iname ] + in if null lst then Left $ "Field " <> cs iname <> " not found" + else Right lst + +-- | Lookup all file inputs with the given @name@ attribute. +-- +-- This function returns a list of all files uploaded under the specified name. +-- It is useful when handling forms that allow multiple file uploads with the same +-- name, such as file inputs with the @multiple@ attribute. If no files are found, +-- Left Missing field error message is returned. +-- +-- Example: +-- +-- >>> let mpd = MultipartData [] [FileData "file" "doc1.pdf" "application/pdf" "/tmp/doc1", +-- FileData "file" "doc2.pdf" "application/pdf" "/tmp/doc2"] +-- >>> lookupAllFiles "file" mpd +-- [FileData "file" "doc1.pdf" "application/pdf" "/tmp/doc1", +-- FileData "file" "doc2.pdf" "application/pdf" "/tmp/doc2"] +-- >>> lookupAllFiles "image" mpd +-- [] +lookupAllFiles :: Text -> MultipartData tag -> Either String [FileData tag] +lookupAllFiles iname mpd = + let lst = [ f | f <- files mpd, fdInputName f == iname ] + in if null lst then Left $ "File " <> cs iname <> " not found" + else Right lst + +-- | A type class for types that can be parsed from 'Text'. +class FromText a where + fromText :: Text -> Either String a + +-- Instance for Text (no parsing needed) +instance FromText Text where + fromText = Right + +-- Instance for Int +instance FromText Int where + fromText t = case reads (unpack t) of + [(val, "")] -> Right val + _ -> Left $ "Could not parse as Int: " <> unpack t + +-- Instance for Bool +instance FromText Bool where + fromText t + | t == "true" || t == "1" = Right True + | t == "false" || t == "0" = Right False + | otherwise = Left $ "Could not parse as Bool: " <> unpack t + +-- Instance for Double +instance FromText Double where + fromText t = case reads (unpack t) of + [(val, "")] -> Right val + _ -> Left $ "Could not parse as Double: " <> unpack t + +-- Instance for Integer +instance FromText Integer where + fromText t = + case reads (unpack t) of + [(val, "")] -> Right val + _ -> Left $ "Could not parse as Integer: " <> unpack t + +-- Instance for Float +instance FromText Float where + fromText t = + case reads (unpack t) of + [(val, "")] -> Right val + _ -> Left $ "Could not parse as Float: " <> unpack t + +-- Instance for Maybe a. +-- This implementation assumes that if the text is "null" or empty, +-- then we interpret it as Nothing; otherwise we try to parse it. +instance FromText a => FromText (Maybe a) where + fromText t = + if t == "null" || t == "" + then Right Nothing + else fmap Just (fromText t) + +-- | Lookup a textual input with the given @name@ attribute and parse it into the desired type. +-- +-- This function returns the parsed value if the input exists and can be parsed successfully. +-- If the input is not found or parsing fails, it returns an error message. +-- +-- Example: +-- +-- >>> let mpd = MultipartData [Input "age" "30"] [] +-- >>> lookupInputAs @Int "age" mpd +-- Right 30 +-- >>> lookupInputAs @Bool "isAdmin" mpd +-- Left "Field isAdmin not found" +lookupInputAs :: FromText a => Text -> MultipartData tag -> Either String a +lookupInputAs iname mpd = + case lookupInput iname mpd of + Left err -> Left err + Right val -> fromText val + fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)]) -> MultipartData tag fromRaw (inputs, files) = MultipartData is fs @@ -91,6 +205,14 @@ fromRaw (inputs, files) = MultipartData is fs dec = decodeUtf8 +-- | Lookup all textual inputs with the given @name@ attribute and parse them into the desired type. +lookupAllInputsAs :: FromText a => Text -> MultipartData tag -> Either String [a] +lookupAllInputsAs iname mpd = do + let eVals = lookupAllInputs iname mpd + case eVals of + Left err -> Left err + Right vals -> mapM fromText vals + class MultipartBackend tag where type MultipartBackendOptions tag :: * diff --git a/servant-multipart/test/Test.hs b/servant-multipart/test/Test.hs index 91e096a..616ac5a 100644 --- a/servant-multipart/test/Test.hs +++ b/servant-multipart/test/Test.hs @@ -14,6 +14,7 @@ import Network.HTTP.Types.Header (HeaderName, hContentType) import Test.Tasty import Test.Tasty.Wai +import Test.Tasty.HUnit import Servant import Servant.Multipart @@ -32,6 +33,57 @@ main = defaultMain $ testGroup "servant-multipart" , testGroup "strict handler with raw MultipartData" [ testWai testApp "correct body" testBlogPostRawHandler ] + , lookupTests + ] + +sampleFileData :: FileData Tmp +sampleFileData = FileData "file" "doc1.pdf" "application/pdf" "payload1" + +lookupTests :: TestTree +lookupTests = testGroup "Lookup function tests" + [ testCase "lookupAllInputs - found" $ do + let md = MultipartData [ Input "color" "red" + , Input "color" "blue" + ] [] + lookupAllInputs "color" md @?= Right ["red", "blue"] + + , testCase "lookupAllInputs - missing field" $ do + let md = MultipartData [ Input "color" "red" + , Input "color" "blue" + ] [] + case lookupAllInputs "size" md of + Left err -> err @?= "Field size not found" + Right _ -> assertFailure "Expected a Left error for missing field" + + , testCase "lookupAllFiles - found" $ do + let file1 = sampleFileData + file2 = FileData "file" "doc2.pdf" "application/pdf" "/tmp/doc2.buf" :: FileData Tmp + md = MultipartData [] [file1, file2] + lookupAllFiles "file" md @?= Right [file1, file2] + + , testCase "lookupAllFiles - missing file" $ do + let file1 = sampleFileData + md = MultipartData [] [file1] + case lookupAllFiles "image" md of + Left err -> err @?= "File image not found" + Right _ -> assertFailure "Expected a Left error for missing file" + + , testCase "lookupInputAs - parsed successfully" $ do + let md = MultipartData [ Input "age" "30" ] [] + lookupInputAs @Int "age" md @?= Right 30 + + , testCase "lookupInputAs - missing input" $ do + let md = MultipartData [ Input "age" "30" ] [] + case lookupInputAs @Bool "isAdmin" md of + Left err -> err @?= "Field isAdmin not found" + Right _ -> assertFailure "Expected failure on missing input" + + , testCase "lookupAllInputsAs - parsing list of numbers" $ do + let md = MultipartData [ Input "nums" "1" + , Input "nums" "2" + , Input "nums" "3" + ] [] + lookupAllInputsAs @Int "nums" md @?= Right [1,2,3] ] data BlogPost