Multipart.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , QuasiQuotes
   4   , UnicodeSyntax
   5   #-}
   6 import qualified Data.ByteString.Lazy.Char8 as Lazy
   7 import Control.Applicative
   8 import qualified Data.Collections as C
   9 import Control.Monad.Unicode
  10 import Data.Default
  11 import Data.Maybe
  12 import Data.Monoid.Unicode
  13 import Network
  14 import Network.HTTP.Lucu
  15 import Prelude hiding (head)
  16 import Prelude.Unicode
  17 import Text.Blaze hiding (text)
  18 import Text.Blaze.Html5 hiding (text)
  19 import Text.Blaze.Html5.Attributes hiding (form, title)
  20 import Text.Blaze.Renderer.Utf8
  21
  22 main ∷ IO ()
  23 main = let config = def { cnfServerPort = "9999" }
  24            tree   ∷ ResourceTree
  25            tree   = C.fromList [ ([], nonGreedy resMain) ]
  26        in
  27          do putStrLn "Access http://localhost:9999/ with your browser."
  28             withSocketsDo ∘ runHttpd config $ resourceMap tree
  29
  30 resMain ∷ Resource
  31 resMain = C.fromList
  32           [ ( GET
  33             , do setContentType [mimeType| text/html; charset="UTF-8" |]
  34                  putBuilder
  35                      $ renderHtmlBuilder
  36                      $ docTypeHtml ! lang "en"
  37                      $ do head $ do meta ! charset "UTF-8"
  38                                     title "Multipart Form Test"
  39                           body $ form ! action  "/"
  40                                       ! method  "post"
  41                                       ! enctype "multipart/form-data"
  42                                $ do toHtml ("Upload some file:" ∷ String)
  43                                     input ! type_ "text"   ! name  "text"
  44                                     input ! type_ "file"   ! name  "file"
  45                                     input ! type_ "submit" ! value "Submit"
  46             )
  47           , ( POST
  48             , do f ← getForm Nothing
  49                  let text     = fromMaybe (∅) $ fdContent <$> lookup "text" f
  50                      file     = fromMaybe (∅) $ fdContent <$> lookup "file" f
  51                      fileName = fdFileName =≪ lookup "file" f
  52                  setContentType [mimeType| text/plain |]
  53                  putChunks $ "You entered \"" ⊕ text ⊕ "\".\n"
  54                  putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n"
  55                  putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n"
  56             )
  57           ]