|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 3 | +{-# LANGUAGE DataKinds #-} |
| 4 | +{-# LANGUAGE TypeFamilies #-} |
| 5 | +{-# LANGUAGE InstanceSigs #-} |
| 6 | +{-# LANGUAGE TypeOperators #-} |
| 7 | +{-# LANGUAGE RecordWildCards #-} |
| 8 | +{-# LANGUAGE FlexibleContexts #-} |
| 9 | +{-# LANGUAGE FlexibleInstances #-} |
| 10 | +{-# LANGUAGE OverloadedStrings #-} |
| 11 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 12 | +{-# LANGUAGE TypeSynonymInstances #-} |
| 13 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 14 | +{-# LANGUAGE StandaloneDeriving #-} |
| 15 | +{-# LANGUAGE UndecidableInstances #-} |
| 16 | +{-# LANGUAGE TypeApplications #-} |
| 17 | +-- | @multipart/form-data@ support for servant. |
| 18 | +-- |
| 19 | +-- This is mostly useful for adding file upload support to |
| 20 | +-- an API. See haddocks of 'MultipartForm' for an introduction. |
| 21 | +module Servant.Multipart.API |
| 22 | + ( MultipartForm |
| 23 | + , MultipartForm' |
| 24 | + , MultipartData(..) |
| 25 | + , ToMultipart(..) |
| 26 | + , FromMultipart(..) |
| 27 | + , MultipartBackend(..) |
| 28 | + , Tmp |
| 29 | + , Mem |
| 30 | + , Input(..) |
| 31 | + , FileData(..) |
| 32 | + ) where |
| 33 | + |
| 34 | +import Control.Monad.Trans.Resource |
| 35 | +import Data.Text (Text) |
| 36 | +import Data.Typeable |
| 37 | +import Servant.API |
| 38 | + |
| 39 | +import qualified Data.ByteString as SBS |
| 40 | +import qualified Data.ByteString.Lazy as LBS |
| 41 | + |
| 42 | +-- | Combinator for specifying a @multipart/form-data@ request |
| 43 | +-- body, typically (but not always) issued from an HTML @\<form\>@. |
| 44 | +-- |
| 45 | +-- @multipart/form-data@ can't be made into an ordinary content |
| 46 | +-- type for now in servant because it doesn't just decode the |
| 47 | +-- request body from some format but also performs IO in the case |
| 48 | +-- of writing the uploaded files to disk, e.g in @/tmp@, which is |
| 49 | +-- not compatible with servant's vision of a content type as things |
| 50 | +-- stand now. This also means that 'MultipartForm' can't be used in |
| 51 | +-- conjunction with 'ReqBody' in an endpoint. |
| 52 | +-- |
| 53 | +-- The 'tag' type parameter instructs the function to handle data |
| 54 | +-- either as data to be saved to temporary storage ('Tmp') or saved to |
| 55 | +-- memory ('Mem'). |
| 56 | +-- |
| 57 | +-- The 'a' type parameter represents the Haskell type to which |
| 58 | +-- you are going to decode the multipart data to, where the |
| 59 | +-- multipart data consists in all the usual form inputs along |
| 60 | +-- with the files sent along through @\<input type="file"\>@ |
| 61 | +-- fields in the form. |
| 62 | +-- |
| 63 | +-- One option provided out of the box by this library is to decode |
| 64 | +-- to 'MultipartData'. |
| 65 | +-- |
| 66 | +-- Example: |
| 67 | +-- |
| 68 | +-- @ |
| 69 | +-- type API = MultipartForm Tmp (MultipartData Tmp) :> Post '[PlainText] String |
| 70 | +-- |
| 71 | +-- api :: Proxy API |
| 72 | +-- api = Proxy |
| 73 | +-- |
| 74 | +-- server :: MultipartData Tmp -> Handler String |
| 75 | +-- server multipartData = return str |
| 76 | +-- |
| 77 | +-- where str = "The form was submitted with " |
| 78 | +-- ++ show nInputs ++ " textual inputs and " |
| 79 | +-- ++ show nFiles ++ " files." |
| 80 | +-- nInputs = length (inputs multipartData) |
| 81 | +-- nFiles = length (files multipartData) |
| 82 | +-- @ |
| 83 | +-- |
| 84 | +-- You can alternatively provide a 'FromMultipart' instance |
| 85 | +-- for some type of yours, allowing you to regroup data |
| 86 | +-- into a structured form and potentially selecting |
| 87 | +-- a subset of the entire form data that was submitted. |
| 88 | +-- |
| 89 | +-- Example, where we only look extract one input, /username/, |
| 90 | +-- and one file, where the corresponding input field's /name/ |
| 91 | +-- attribute was set to /pic/: |
| 92 | +-- |
| 93 | +-- @ |
| 94 | +-- data User = User { username :: Text, pic :: FilePath } |
| 95 | +-- |
| 96 | +-- instance FromMultipart Tmp User where |
| 97 | +-- fromMultipart multipartData = |
| 98 | +-- User \<$\> lookupInput "username" multipartData |
| 99 | +-- \<*\> fmap fdPayload (lookupFile "pic" multipartData) |
| 100 | +-- |
| 101 | +-- type API = MultipartForm Tmp User :> Post '[PlainText] String |
| 102 | +-- |
| 103 | +-- server :: User -> Handler String |
| 104 | +-- server usr = return str |
| 105 | +-- |
| 106 | +-- where str = username usr ++ "'s profile picture" |
| 107 | +-- ++ " got temporarily uploaded to " |
| 108 | +-- ++ pic usr ++ " and will be removed from there " |
| 109 | +-- ++ " after this handler has run." |
| 110 | +-- @ |
| 111 | +-- |
| 112 | +-- Note that the behavior of this combinator is configurable, |
| 113 | +-- by using 'serveWith' from servant-server instead of 'serve', |
| 114 | +-- which takes an additional 'Context' argument. It simply is an |
| 115 | +-- heterogeneous list where you can for example store |
| 116 | +-- a value of type 'MultipartOptions' that has the configuration that |
| 117 | +-- you want, which would then get picked up by servant-multipart. |
| 118 | +-- |
| 119 | +-- __Important__: as mentionned in the example above, |
| 120 | +-- the file paths point to temporary files which get removed |
| 121 | +-- after your handler has run, if they are still there. It is |
| 122 | +-- therefore recommended to move or copy them somewhere in your |
| 123 | +-- handler code if you need to keep the content around. |
| 124 | +type MultipartForm tag a = MultipartForm' '[] tag a |
| 125 | + |
| 126 | +-- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'. |
| 127 | +data MultipartForm' (mods :: [*]) tag a |
| 128 | + |
| 129 | +-- | What servant gets out of a @multipart/form-data@ form submission. |
| 130 | +-- |
| 131 | +-- The type parameter 'tag' tells if 'MultipartData' is stored as a |
| 132 | +-- temporary file or stored in memory. 'tag' is type of either 'Mem' |
| 133 | +-- or 'Tmp'. |
| 134 | +-- |
| 135 | +-- The 'inputs' field contains a list of textual 'Input's, where |
| 136 | +-- each input for which a value is provided gets to be in this list, |
| 137 | +-- represented by the input name and the input value. See haddocks for |
| 138 | +-- 'Input'. |
| 139 | +-- |
| 140 | +-- The 'files' field contains a list of files that were sent along with the |
| 141 | +-- other inputs in the form. Each file is represented by a value of type |
| 142 | +-- 'FileData' which among other things contains the path to the temporary file |
| 143 | +-- (to be removed when your handler is done running) with a given uploaded |
| 144 | +-- file's content. See haddocks for 'FileData'. |
| 145 | +data MultipartData tag = MultipartData |
| 146 | + { inputs :: [Input] |
| 147 | + , files :: [FileData tag] |
| 148 | + } |
| 149 | + |
| 150 | +-- | Representation for an uploaded file, usually resulting from |
| 151 | +-- picking a local file for an HTML input that looks like |
| 152 | +-- @\<input type="file" name="somefile" /\>@. |
| 153 | +data FileData tag = FileData |
| 154 | + { fdInputName :: Text -- ^ @name@ attribute of the corresponding |
| 155 | + -- HTML @\<input\>@ |
| 156 | + , fdFileName :: Text -- ^ name of the file on the client's disk |
| 157 | + , fdFileCType :: Text -- ^ MIME type for the file |
| 158 | + , fdPayload :: MultipartResult tag |
| 159 | + -- ^ path to the temporary file that has the |
| 160 | + -- content of the user's original file. Only |
| 161 | + -- valid during the execution of your handler as |
| 162 | + -- it gets removed right after, which means you |
| 163 | + -- really want to move or copy it in your handler. |
| 164 | + } |
| 165 | + |
| 166 | +deriving instance Eq (MultipartResult tag) => Eq (FileData tag) |
| 167 | +deriving instance Show (MultipartResult tag) => Show (FileData tag) |
| 168 | + |
| 169 | +-- | Representation for a textual input (any @\<input\>@ type but @file@). |
| 170 | +-- |
| 171 | +-- @\<input name="foo" value="bar"\ />@ would appear as @'Input' "foo" "bar"@. |
| 172 | +data Input = Input |
| 173 | + { iName :: Text -- ^ @name@ attribute of the input |
| 174 | + , iValue :: Text -- ^ value given for that input |
| 175 | + } deriving (Eq, Show) |
| 176 | + |
| 177 | +-- | 'MultipartData' is the type representing |
| 178 | +-- @multipart/form-data@ form inputs. Sometimes |
| 179 | +-- you may instead want to work with a more structured type |
| 180 | +-- of yours that potentially selects only a fraction of |
| 181 | +-- the data that was submitted, or just reshapes it to make |
| 182 | +-- it easier to work with. The 'FromMultipart' class is exactly |
| 183 | +-- what allows you to tell servant how to turn "raw" multipart |
| 184 | +-- data into a value of your nicer type. |
| 185 | +-- |
| 186 | +-- @ |
| 187 | +-- data User = User { username :: Text, pic :: FilePath } |
| 188 | +-- |
| 189 | +-- instance FromMultipart Tmp User where |
| 190 | +-- fromMultipart form = |
| 191 | +-- User \<$\> lookupInput "username" (inputs form) |
| 192 | +-- \<*\> fmap fdPayload (lookupFile "pic" $ files form) |
| 193 | +-- @ |
| 194 | +class FromMultipart tag a where |
| 195 | + -- | Given a value of type 'MultipartData', which consists |
| 196 | + -- in a list of textual inputs and another list for |
| 197 | + -- files, try to extract a value of type @a@. When |
| 198 | + -- extraction fails, servant errors out with status code 400. |
| 199 | + fromMultipart :: MultipartData tag -> Either String a |
| 200 | + |
| 201 | +instance FromMultipart tag (MultipartData tag) where |
| 202 | + fromMultipart = Right |
| 203 | + |
| 204 | +-- | Allows you to tell servant how to turn a more structured type |
| 205 | +-- into a 'MultipartData', which is what is actually sent by the |
| 206 | +-- client. |
| 207 | +-- |
| 208 | +-- @ |
| 209 | +-- data User = User { username :: Text, pic :: FilePath } |
| 210 | +-- |
| 211 | +-- instance toMultipart Tmp User where |
| 212 | +-- toMultipart user = MultipartData [Input "username" $ username user] |
| 213 | +-- [FileData "pic" |
| 214 | +-- (pic user) |
| 215 | +-- "image/png" |
| 216 | +-- (pic user) |
| 217 | +-- ] |
| 218 | +-- @ |
| 219 | +class ToMultipart tag a where |
| 220 | + -- | Given a value of type 'a', convert it to a |
| 221 | + -- 'MultipartData'. |
| 222 | + toMultipart :: a -> MultipartData tag |
| 223 | + |
| 224 | +instance ToMultipart tag (MultipartData tag) where |
| 225 | + toMultipart = id |
| 226 | + |
| 227 | +class MultipartBackend tag where |
| 228 | + type MultipartResult tag :: * |
| 229 | + type MultipartBackendOptions tag :: * |
| 230 | + |
| 231 | + backend :: Proxy tag |
| 232 | + -> MultipartBackendOptions tag |
| 233 | + -> InternalState |
| 234 | + -> ignored1 |
| 235 | + -> ignored2 |
| 236 | + -> IO SBS.ByteString |
| 237 | + -> IO (MultipartResult tag) |
| 238 | + |
| 239 | + loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString |
| 240 | + |
| 241 | + defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag |
| 242 | + |
| 243 | +-- | Tag for data stored as a temporary file |
| 244 | +data Tmp |
| 245 | + |
| 246 | +-- | Tag for data stored in memory |
| 247 | +data Mem |
| 248 | + |
| 249 | +instance HasLink sub => HasLink (MultipartForm tag a :> sub) where |
| 250 | +#if MIN_VERSION_servant(0,14,0) |
| 251 | + type MkLink (MultipartForm tag a :> sub) r = MkLink sub r |
| 252 | + toLink toA _ = toLink toA (Proxy :: Proxy sub) |
| 253 | +#else |
| 254 | + type MkLink (MultipartForm tag a :> sub) = MkLink sub |
| 255 | + toLink _ = toLink (Proxy :: Proxy sub) |
| 256 | +#endif |
0 commit comments