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)
import System.IO        (readFile)

main :: IO ()
main = simpleHTTP nullConf upload

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

permFileLoc = "foo"

uploadForm :: ServerPart Response
uploadForm =
  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"]
                             ]
    ]

showFile :: String -> ServerPart Response
showFile file =
  ok . toResponse $ X.toHtmlFromList
    [ X.header $ X.thetitle << "Your file"
    , X.body $ X.toHtmlFromList
      [ X.p << "Your file is shown below"
      , X.p $ X.toHtml file
      ]
    ]

tempFile :: ServerPart Response
tempFile = do
  (tmpFile, _, _) <- lookFile "file_upload"
  liftIO $ renameFile tmpFile permFileLoc
  file <- liftIO $ readFile permFileLoc
  showFile file


permFile :: ServerPart Response
permFile = do
  file <- liftIO $ readFile permFileLoc
  showFile file