import Control.Monad          (msum)
import Control.Monad.IO.Class (liftIO)
import Happstack.Server
  ( simpleHTTP, nullConf, ServerPart, Response, decodeBody, defaultBodyPolicy
  , dir, ok, toResponse, lookFile, serveFile, asContentType, anyPath )
import Text.XHtml.Strict ((!), (<<))
import qualified Text.XHtml.Strict as X
import System.Directory (renameFile)

main :: IO ()
main = simpleHTTP nullConf upload

upload :: ServerPart Response
upload = do
  decodeBody $ defaultBodyPolicy "/tmp/" (10*10^6) 1000 1000
  msum [ dir "file" file
       , uploadForm
       ]

permFile = "foo"

uploadForm :: ServerPart Response
uploadForm = do
  res <- ok . toResponse $ X.toHtmlFromList
    [ X.header $ X.thetitle << "Upload a file"
    , X.body $ X.form ! [ X.enctype "multipart/form-data"
                        , X.method "POST"
                        , X.action "/file"
                        ] << [ X.input ! [X.thetype "file", X.name "file_upload", X.size "20"]
                             , X.input ! [X.thetype "submit", X.value "Upload"]
                             ]
    ]
  (tmpFile, _, _) <- lookFile "file_upload"
  liftIO $ renameFile tmpFile permFile
  return res

file :: ServerPart Response
file = serveFile (asContentType "text/plain") permFile