scotty-0.30: examples/upload.hs

{-# LANGUAGE OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
module Main (main) where

import Web.Scotty

import Control.Exception (SomeException)
import Data.Foldable (for_)
import qualified Data.Text.Lazy as TL

import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Network.Wai.Parse (fileName, fileContent, defaultParseRequestBodyOptions)

import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes
import Text.Blaze.Html.Renderer.Text (renderHtml)

import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Char8 as BS
import System.FilePath ((</>))

{-| NB : the file paths where files are saved and looked up are relative, so make sure
to run this program from the root directory of the 'scotty' repo, or adjust the paths
accordingly.
-}

main :: IO ()
main = scotty 3000 $ do
    middleware logStdoutDev
    middleware $ staticPolicy (noDots >-> addBase "examples/uploads")

    get "/" $ do
        html $ renderHtml
             $ H.html $ do
                H.body $ do
                    H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do
                        H.input H.! type_ "file" H.! name "file_1"
                        H.br
                        H.input H.! type_ "file" H.! name "file_2"
                        H.br
                        H.input H.! type_ "submit"

    post "/upload" $ do
      filesOpts defaultParseRequestBodyOptions $ \_ fs -> do
        let
          fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs]
        -- write the files to disk, so they can be served by the static middleware
        for_ fs' $ \(_, fnam, fpath) -> do
          -- copy temp file to local dir
          liftIO (do
                     fc <- B.readFile fpath
                     B.writeFile ("examples" </> "uploads" </> fnam) fc
                 ) `catch` (\(e :: SomeException) -> do
                               liftIO $ putStrLn $ unwords ["upload: something went wrong while saving temp files :", show e]
                           )
          -- generate list of links to the files just uploaded
          html $ mconcat [ mconcat [ TL.fromStrict fName
                                   , ": "
                                   , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br
                                   ]
                         | (fName,fn,_) <- fs' ]