upload a file to http server

upload.hs

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import Web.Scotty

import Control.Monad.IO.Class

import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Network.Wai.Parse

import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes hiding (id)
import Text.Blaze.Html.Renderer.Text (renderHtml)

import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Char8 as BS
import System.FilePath ((</>))
import System.Environment
import Prelude
-- import Prelude.Compat

import System.Process
import Data.List

main :: IO ()
main = do
 port <- read . head <$> getArgs
 scotty port $ do
  middleware logStdoutDev
  middleware $ staticPolicy (noDots >-> addBase "uploads")

  get "/" $ myhtml ("" :: String)
  get "/upload" $ myhtml ("" :: String)

  post "/upload" $ do
      fs <- files
      let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ]
      -- write the files to disk, so they will be served by the static middleware
      liftIO $ sequence_ [ B.writeFile ("/home/celery/Desktop/uploads" </> fn) fc | (_,fn,fc) <- fs' ]
      -- generate list of links to the files just uploaded
      myhtml ("uploaded succesfully." :: String) -- mconcat
--        [ mconcat 
--          [ fName
--          , ": "
--          , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br
--          ]
--        | (fName,fn,_) <- fs'
--        ]

myhtml extra = do
  [total, used, free, precent] <- liftIO $ take 4 . drop 1 . words . unlines . filter (isInfixOf "/dev/sda2") . lines <$> readProcess "df" ["-h"] ""
  html $ renderHtml $ H.html $ do
    H.style $ "body { font-size: 32px; width: 600px; margin: auto; } input { font-size: 26px }"
    H.body $ do
      H.p $ H.toHtml extra
      H.br
      H.p $ H.toHtml ("Used: " <> used <> " / " <> total <> " (" <> precent <> "), Free: " <> free)
      H.br
      H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do
        H.input H.! type_ "file" H.! name "uploaded"
        H.input H.! type_ "submit" H.! value "Upload"