FileUpload.hs

{-# LANGUAGE OverloadedStrings #-}
module Network.Wai.Middleware.FileUpload where

import           Control.Monad.Trans.Resource
import qualified Data.ByteString              as S
import qualified Data.Foldable                as F
import           Data.Monoid
import           Data.String                  (fromString)
import           Network.HTTP.Types.URI       (Query, QueryItem)
import           Network.Wai
import           Network.Wai.Parse

-- | Saves file uploads to temporary files. Never cleans anything up.
saveFileUploads :: Middleware
saveFileUploads app rq k =
  do newRequest <- saveFiles rq
     app newRequest k

saveFiles :: Request -> IO Request
saveFiles rq =
  do x <- createInternalState
     (_,files) <-
       parseRequestBody (tempFileBackEnd x)
                        rq
     -- TODO: Clean up files when?
     pure (F.foldl' addToQuery rq files)

addToQuery :: Request -> File FilePath -> Request
addToQuery rq fp =
  let qry = queryString rq
      newQueryString = fileToItem fp <> qry
  in rq {queryString = newQueryString}

-- | Construct query parameters to reflect the saved file
--   We end up with 3 query items:
--     * <name>_filepath -- where we wrote the file to
--     * <name>_filename -- the original file name
--     * <name>_content_type -- the content type of the uploaded file
fileToItem :: File FilePath -> [QueryItem]
fileToItem (pn,fileinfo) =
  [(pn <> "_filepath",Just (fromString $ fileContent fileinfo))
  ,(pn <> "_filename",Just (fileName fileinfo))
  ,(pn <> "_content_type",Just (fileContentType fileinfo))]