examples/Multipart.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 import qualified Data.ByteString.Lazy.Char8 as Lazy
   6 import Control.Applicative
   7 import qualified Data.Collections as C
   8 import Control.Monad.Unicode
   9 import Data.Maybe
  10 import Data.Monoid.Unicode
  11 import Network.HTTP.Lucu
  12
  13 main ∷ IO ()
  14 main = let config = defaultConfig { cnfServerPort = "9999" }
  15            tree   ∷ ResourceTree
  16            tree   = C.fromList [ ([], nonGreedy resMain) ]
  17        in
  18          do putStrLn "Access http://localhost:9999/ with your browser."
  19             runHttpd config $ resourceMap tree
  20
  21 resMain ∷ Resource
  22 resMain = C.fromList
  23           [ ( GET
  24             , do setContentType $ parseMIMEType "text/html"
  25                  putChunks $ "<title>Multipart Form Test</title>\n"
  26                            ⊕ "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">\n"
  27                            ⊕ "  Upload some file:\n"
  28                            ⊕ "  <input type=\"text\" name=\"text\">\n"
  29                            ⊕ "  <input type=\"file\" name=\"file\">\n"
  30                            ⊕ "  <input type=\"submit\" value=\"Submit\">\n"
  31                            ⊕ "</form>\n"
  32             )
  33           , ( POST
  34             , do form ← getForm Nothing
  35                  let text     = fromMaybe (∅) $ fdContent <$> lookup "text" form
  36                      file     = fromMaybe (∅) $ fdContent <$> lookup "file" form
  37                      fileName = fdFileName =≪ lookup "file" form
  38                  setContentType $ parseMIMEType "text/plain"
  39                  putChunks $ "You entered \"" ⊕ text ⊕ "\".\n"
  40                  putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n"
  41                  putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n"
  42             )
  43           ]