diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +0.13.0 +------ + +- Add `lookupInput` and `lookupFile`, moved from `servant-multipart`. +- Add `lookupAllInputs`, `lookupAllFiles`, `lookupInputAs` and + `lookupAllInputsAs` + [#75](https://github.com/haskell-servant/servant-multipart/pull/75). +- Add `Eq`, `Show`, `Semigroup` and `Monoid` instances for + `MultipartData`, and `NFData` instances for `MultipartData`, + `FileData` and `Input`. +- **Breaking:** the `HasLink` instance now covers `MultipartForm'` with any + modifiers, not only `MultipartForm`. Remove any instances you wrote for + `MultipartForm' '[Lenient]`, since they now overlap. +- Drop the `transformers` dependency. +- Require GHC >= 9.4 and servant >= 0.20.3; support up to GHC 9.12 + [#81](https://github.com/haskell-servant/servant-multipart/pull/81). + 0.12.1 ------ diff --git a/servant-multipart-api.cabal b/servant-multipart-api.cabal --- a/servant-multipart-api.cabal +++ b/servant-multipart-api.cabal @@ -1,5 +1,5 @@ name: servant-multipart-api -version: 0.12.1 +version: 0.13.0 synopsis: multipart/form-data (e.g file upload) support for servant description: This package contains servant API types that support multiform upload, used by @@ -15,7 +15,12 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 +tested-with: + GHC ==9.4.8 + || ==9.6.3 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 library default-language: Haskell2010 @@ -24,14 +29,26 @@ -- ghc boot libs build-depends: - base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 - , text >=1.2.3.0 && <1.3 - , transformers >=0.5.2.0 && <0.6 + base >=4.17 && <5 + , bytestring >=0.11 && <0.13 + , deepseq >=1.4.8 && <1.6 + , text >=2.0 && <2.2 -- other dependencies build-depends: - servant >=0.16 && <0.19 + servant >=0.20.3 && <0.21 + +test-suite servant-multipart-api-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + default-language: Haskell2010 + build-depends: + base + , servant-multipart-api + , tasty + , tasty-hunit + , text source-repository head type: git diff --git a/src/Servant/Multipart/API.hs b/src/Servant/Multipart/API.hs --- a/src/Servant/Multipart/API.hs +++ b/src/Servant/Multipart/API.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -31,9 +30,18 @@ , Mem , Input(..) , FileData(..) + , lookupInput + , lookupFile + , lookupAllInputs + , lookupAllFiles + , lookupInputAs + , lookupAllInputsAs ) where -import Data.Text (Text) +import Control.DeepSeq (NFData (rnf)) +import Data.Bifunctor (first) +import Data.List (find) +import Data.Text (Text, unpack) import Data.Typeable import Servant.API @@ -50,11 +58,11 @@ -- stand now. This also means that 'MultipartForm' can't be used in -- conjunction with 'ReqBody' in an endpoint. -- --- The 'tag' type parameter instructs the function to handle data +-- The @tag@ type parameter instructs servant-multipart to handle data -- either as data to be saved to temporary storage ('Tmp') or saved to -- memory ('Mem'). -- --- The 'a' type parameter represents the Haskell type to which +-- The @a@ type parameter represents the Haskell type to which -- you are going to decode the multipart data to, where the -- multipart data consists in all the usual form inputs along -- with the files sent along through @\@ @@ -103,33 +111,47 @@ -- server :: User -> Handler String -- server usr = return str -- --- where str = username usr ++ "'s profile picture" +-- where str = unpack (username usr) ++ "'s profile picture" -- ++ " got temporarily uploaded to " -- ++ pic usr ++ " and will be removed from there " -- ++ " after this handler has run." -- @ -- -- Note that the behavior of this combinator is configurable, --- by using 'serveWith' from servant-server instead of 'serve', --- which takes an additional 'Context' argument. It simply is an --- heterogeneous list where you can for example store --- a value of type 'MultipartOptions' that has the configuration that --- you want, which would then get picked up by servant-multipart. +-- by using @serveWithContext@ from servant-server instead of @serve@, +-- which takes an additional @Context@ argument. @Context@ is a +-- heterogeneous list where you can for example store a value of type +-- @MultipartOptions@ from servant-multipart that has the configuration +-- that you want, which would then get picked up by servant-multipart. -- --- __Important__: as mentionned in the example above, +-- __Important__: as mentioned in the example above, -- the file paths point to temporary files which get removed -- after your handler has run, if they are still there. It is -- therefore recommended to move or copy them somewhere in your -- handler code if you need to keep the content around. +-- +-- __Important__: the input names, input values, file names and file +-- content types of the submitted form must all be valid UTF-8, including +-- those of the parts that your 'FromMultipart' instance ignores. A form +-- that carries any other encoding is rejected with a 400 response before +-- your handler runs, unless 'Servant.API.Modifiers.Lenient' is used. The +-- contents of the uploaded files are not decoded and may be arbitrary +-- bytes. type MultipartForm tag a = MultipartForm' '[] tag a -- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'. +-- +-- Under 'Servant.API.Modifiers.Lenient', the handler is passed an +-- @'Either' CheckError a@ from servant-multipart rather than the request +-- being rejected, so it is handed the message from a failed +-- 'fromMultipart' call, from a form whose text is not valid UTF-8, or +-- from a form that exceeds a body parsing limit. data MultipartForm' (mods :: [*]) tag a -- | What servant gets out of a @multipart/form-data@ form submission. -- --- The type parameter 'tag' tells if 'MultipartData' is stored as a --- temporary file or stored in memory. 'tag' is type of either 'Mem' +-- The type parameter @tag@ tells if 'MultipartData' is stored as a +-- temporary file or stored in memory. @tag@ is type of either 'Mem' -- or 'Tmp'. -- -- The 'inputs' field contains a list of textual 'Input's, where @@ -147,6 +169,130 @@ , files :: [FileData tag] } +deriving instance Eq (MultipartResult tag) => Eq (MultipartData tag) +deriving instance Show (MultipartResult tag) => Show (MultipartData tag) + +instance Semigroup (MultipartData tag) where + a <> b = + MultipartData + { inputs = inputs a <> inputs b + , files = files a <> files b + } + +instance Monoid (MultipartData tag) where + mempty = + MultipartData + { inputs = [] + , files = [] + } + +instance NFData (MultipartResult tag) => NFData (MultipartData tag) where + rnf (MultipartData is fs) = rnf is `seq` rnf fs + +-- | Lookup a textual input with the given @name@ attribute. +-- +-- Takes linear time with respect to the number of inputs. +lookupInput :: Text -> MultipartData tag -> Either String Text +lookupInput iname = + maybe (Left $ "Field " <> unpack iname <> " not found") (Right . iValue) + . find ((==iname) . iName) + . inputs + +-- | Lookup a file input with the given @name@ attribute. +-- +-- Takes linear time with respect to the number of files. +lookupFile :: Text -> MultipartData tag -> Either String (FileData tag) +lookupFile iname = + maybe (Left $ "File " <> unpack iname <> " not found") Right + . find ((==iname) . fdInputName) + . files + +-- | Lookup all textual inputs with the given @name@ attribute. +-- +-- Takes linear time with respect to the number of inputs. +-- +-- 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 checkbox groups with explicit values. +-- +-- Example: +-- +-- @ +-- let mpd = MultipartData [Input "color" "red", Input "color" "blue"] [] +-- lookupAllInputs "color" mpd == ["red", "blue"] +-- lookupAllInputs "size" mpd == [] +-- @ +lookupAllInputs :: Text -> MultipartData tag -> [Text] +lookupAllInputs iname mpd = [ val | (Input name val) <- inputs mpd, name == iname ] + +-- | Lookup all file inputs with the given @name@ attribute. +-- +-- Takes linear time with respect to the number of files. +-- +-- 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. +-- +-- Example: +-- +-- @ +-- let file1 = FileData "file" "doc1.pdf" "application/pdf" "/tmp/doc1" +-- file2 = FileData "file" "doc2.pdf" "application/pdf" "/tmp/doc2" +-- mpd = MultipartData [] [file1, file2] :: MultipartData Tmp +-- lookupAllFiles "file" mpd == [file1, file2] +-- lookupAllFiles "image" mpd == [] +-- @ +lookupAllFiles :: Text -> MultipartData tag -> [FileData tag] +lookupAllFiles iname mpd = [ f | f <- files mpd, fdInputName f == iname ] + +-- | Lookup a textual input with the given @name@ attribute and parse it into the desired type. +-- +-- Takes linear time with respect to the number of inputs. +-- +-- This function returns the parsed value if the input exists and can be parsed successfully +-- using its 'FromHttpApiData' instance. If the input is not found or parsing fails, it returns +-- an error message. +-- +-- Note: This function requires the field to be present in the request. Standalone HTML boolean +-- checkboxes (which submit @"on"@ when checked and are omitted by browsers when unchecked) are +-- not directly supported by 'FromHttpApiData Bool'; check for presence with 'lookupInput' or +-- 'lookupAllInputs' instead, or use a custom newtype with a 'FromHttpApiData' instance. +-- +-- Example: +-- +-- @ +-- let mpd = MultipartData [Input "age" "30"] [] +-- lookupInputAs "age" mpd == Right (30 :: Int) +-- lookupInputAs "isAdmin" mpd == (Left "Field isAdmin not found" :: Either String Int) +-- @ +lookupInputAs :: FromHttpApiData a => Text -> MultipartData tag -> Either String a +lookupInputAs iname mpd = do + val <- lookupInput iname mpd + first unpack $ parseQueryParam val + +-- | Lookup all textual inputs with the given @name@ attribute and parse them into the desired type. +-- +-- Takes linear time with respect to the number of inputs. +-- +-- This function returns a list of parsed values for inputs with the specified name using their +-- 'FromHttpApiData' instance. It is useful for forms with repeated fields, multiple select inputs, +-- or checkbox groups sharing the same name with explicit values. +-- +-- If no inputs are found, an empty list is returned. If parsing fails for any value, +-- an error message is returned. +-- +-- Example: +-- +-- @ +-- let mpd = MultipartData [Input "nums" "1", Input "nums" "2"] [] +-- lookupAllInputsAs "nums" mpd == Right [1, 2 :: Int] +-- lookupAllInputsAs "size" mpd == Right ([] :: [Int]) +-- @ +lookupAllInputsAs :: FromHttpApiData a => Text -> MultipartData tag -> Either String [a] +lookupAllInputsAs iname mpd = do + let vals = lookupAllInputs iname mpd + first unpack $ mapM parseQueryParam vals + -- | Representation for an uploaded file, usually resulting from -- picking a local file for an HTML input that looks like -- @\@. @@ -166,6 +312,13 @@ deriving instance Eq (MultipartResult tag) => Eq (FileData tag) deriving instance Show (MultipartResult tag) => Show (FileData tag) +-- | Note that at 'Tmp' this only forces the 'FilePath'. It makes no +-- guarantees about the temporary file it names, which is still removed +-- once the handler has run. +instance NFData (MultipartResult tag) => NFData (FileData tag) where + rnf (FileData iname fname ctype payload) = + rnf iname `seq` rnf fname `seq` rnf ctype `seq` rnf payload + -- | Representation for a textual input (any @\@ type but @file@). -- -- @\@ would appear as @'Input' "foo" "bar"@. @@ -174,6 +327,9 @@ , iValue :: Text -- ^ value given for that input } deriving (Eq, Show) +instance NFData Input where + rnf (Input name value) = rnf name `seq` rnf value + -- | 'MultipartData' is the type representing -- @multipart/form-data@ form inputs. Sometimes -- you may instead want to work with a more structured type @@ -188,8 +344,8 @@ -- -- instance FromMultipart Tmp User where -- fromMultipart form = --- User \<$\> lookupInput "username" (inputs form) --- \<*\> fmap fdPayload (lookupFile "pic" $ files form) +-- User \<$\> lookupInput "username" form +-- \<*\> fmap fdPayload (lookupFile "pic" form) -- @ class FromMultipart tag a where -- | Given a value of type 'MultipartData', which consists @@ -208,16 +364,16 @@ -- @ -- data User = User { username :: Text, pic :: FilePath } -- --- instance toMultipart Tmp User where +-- instance ToMultipart Tmp User where -- toMultipart user = MultipartData [Input "username" $ username user] -- [FileData "pic" --- (pic user) +-- (pack (takeFileName (pic user))) -- "image/png" -- (pic user) -- ] -- @ class ToMultipart tag a where - -- | Given a value of type 'a', convert it to a + -- | Given a value of type @a@, convert it to a -- 'MultipartData'. toMultipart :: a -> MultipartData tag @@ -234,11 +390,6 @@ type instance MultipartResult Tmp = FilePath type instance MultipartResult Mem = LBS.ByteString -instance HasLink sub => HasLink (MultipartForm tag a :> sub) where -#if MIN_VERSION_servant(0,14,0) - type MkLink (MultipartForm tag a :> sub) r = MkLink sub r +instance HasLink sub => HasLink (MultipartForm' mods tag a :> sub) where + type MkLink (MultipartForm' mods tag a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) -#else - type MkLink (MultipartForm tag a :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) -#endif diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Main (main) where + +import Data.Text (Text) +import Test.Tasty +import Test.Tasty.HUnit + +import Servant.Multipart.API + +main :: IO () +main = defaultMain lookupTests + +sampleFileData :: FileData Tmp +sampleFileData = FileData "file" "doc1.pdf" "application/pdf" "payload1" + +lookupTests :: TestTree +lookupTests = testGroup "Lookup function tests" + [ testCase "lookupInput - found" $ do + let md = MultipartData [ Input "title" "hello" ] [] + lookupInput "title" md @?= Right "hello" + + , testCase "lookupInput - missing" $ do + let md = MultipartData [ Input "title" "hello" ] [] + lookupInput "author" md @?= Left "Field author not found" + + , testCase "lookupFile - found" $ do + let md = MultipartData [] [ sampleFileData ] + lookupFile "file" md @?= Right sampleFileData + + , testCase "lookupFile - missing" $ do + let md = MultipartData [] [ sampleFileData ] + lookupFile "image" md @?= Left "File image not found" + + , testCase "lookupAllInputs - found" $ do + let md = MultipartData [ Input "color" "red" + , Input "color" "blue" + ] [] + lookupAllInputs "color" md @?= ["red", "blue"] + + , testCase "lookupAllInputs - missing field" $ do + let md = MultipartData [ Input "color" "red" + , Input "color" "blue" + ] [] + lookupAllInputs "size" md @?= [] + + , 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 @?= [file1, file2] + + , testCase "lookupAllFiles - missing file" $ do + let file1 = sampleFileData + md = MultipartData [] [file1] + lookupAllFiles "image" md @?= [] + + , 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] + + , testCase "lookupAllInputsAs - missing field returns empty list" $ do + let md = MultipartData [ Input "nums" "1" ] [] + lookupAllInputsAs @Int "other" md @?= Right [] + ]