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