maid-2011.6.20: src/maid.hs

{-# LANGUAGE NamedFieldPuns, QuasiQuotes, OverloadedStrings #-}


import Hack2.Handler.Warp
import System (getArgs)
import Air.Env hiding (div, log, head, def)


import Air.TH
import Air.Extra (u2b, b2u, strip)

import Prelude ()
import Data.Default (def)
import Hack2.Contrib.Middleware.Config
import Hack2.Contrib.Middleware.ContentLength
import Hack2.Contrib.Middleware.Static
import Hack2.Contrib.Middleware.SimpleAccessLogger
import Hack2.Contrib.Middleware.UserMime
import Hack2.Contrib.Middleware.Cascade
import qualified Hack2 as Hack2

-- import Hack.Contrib.Mime
-- import Data.Map (toAscList)
import Hack2.Contrib.Utils (use, unescape_uri)
import Hack2.Contrib.Response (set_content_type, set_body_bytestring)
import Hack2.Contrib.Request (path)
import Hack2 hiding (body)
import Data.ByteString.Lazy.Char8 (pack)
import System.Posix.Files
import Data.List (isInfixOf, sort, (\\))
import Text.HTML.Moe2 hiding ((/), select)
import Control.Monad ((>=>))
import System.Process
import System.Directory (doesFileExist, getDirectoryContents)
import Control.Concurrent
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as B


main :: IO ()
main = do
  args <- getArgs
  let { port = 
    if length args == 0
      then 3000
      else read - first args
    }
  
  let { app =
    dir_serve - \env -> do
      let static_app = static (Just ".") [""] (const - return not_found)
      
      r <- static_app env
      if r.status == 200
        then do
          _content_type <- readProcess "file" ["-b", "--mime", "." + env.pathInfo.B.unpack.unescape_uri] ""
          -- putStrLn _content_type
          return - r.set_content_type (_content_type.strip.B.pack)
        else
          return r          
    }

  maid_mime_exist <- doesFileExist "mime.types"
    
  mime_types <- if maid_mime_exist then B.readFile "mime.types" else return default_mime_types

  putStrLn ""
  putStrLn - " ❂ Maid serving on port: " ++ show port
  putStrLn ""
  
  runWithConfig def {port} - use (middleware_stack - B.unpack mime_types) app
  -- run port - use middleware_stack app
  
  where
    dir_serve app = cascade
      [
        app
      , config (\env -> env {pathInfo = B.pack - pathInfo env.B.unpack / "index.htm"}) app
      , config (\env -> env {pathInfo = B.pack - pathInfo env.B.unpack / "index.html"}) app
      , list_dir
      ]


middleware_stack :: String -> [Middleware]
middleware_stack mime_types =
  [
    no_favicon
--  , content_length
  , simple_access_logger - Nothing
  , user_mime - map (\(x,y) -> (B.pack x, B.pack y)) - parse_user_mimes - mime_types
  -- , user_mime - mime_types.toAscList.map_fst (drop 1)
  -- , \app env -> do
  --   r <- app env
  --   print - r.headers
  --   return r
  ]
  
  where
    parse_user_mimes :: String -> [(String, String)]
    parse_user_mimes = lines > reject null > map (words > first &&& words > tail > unwords)


no_favicon :: Middleware
no_favicon app = \env -> do
  -- putStrLn - "pathInfo is: " + env.pathInfo
  if env.pathInfo.is "/favicon.ico"
    then
      return not_found
    else
      app env

not_found :: Response
not_found = def { status = 404 }

is_directory :: String -> IO Bool
is_directory = u2b > getFileStatus >=> isDirectory > return

list_dir :: Application
list_dir env = do
  let _path = "." + env.pathInfo .B.unpack.unescape_uri .b2u
  
  -- print _path
  
  -- no hack please
  if ".." `isInfixOf` _path
    then
      return not_found
    else do
      is_dir <- is_directory _path
      
      if not is_dir
        then
          return not_found
        else do
          let ls :: String -> IO [String]
              ls s = getDirectoryContents s ^ (\\ [".", ".."])
              
          _paths <- ls (u2b _path) ^ map b2u

          -- print _paths
        
          let _full_paths = _paths.map (_path.drop 2 /)
          
          dir_tags <- _full_paths.mapM is_directory

          let tagged = zip _paths dir_tags
          
              dirs = tagged.select snd.sort .map_fst (+ "/")
              files =  tagged.reject snd.sort 

              sorted = dirs + files
          
          maid_css_exist <- doesFileExist "maid.css"
          
          _css <- if maid_css_exist then B.readFile "maid.css" else return default_css_style
            
          
          return - def
            {
              status = 200
            }
            .set_body_bytestring (pack - dir_template sorted (B.unpack _css) (env.path.B.unpack.unescape_uri.b2u))
            .set_content_type "text/html; charset=utf-8"


dir_template :: [(String, Bool)] -> String -> String -> String
dir_template xs _css current_path = render -
  html - do
    head - do
      meta ! [http_equiv "Content-Type", content "text/html; charset=utf-8"] - return ()
      style - str _css
      
    body - do
      div ! [_class "container"] - do
        ul - do
          xs.mapM_ (\(_path, dir_tag) ->
            li - do
              
              let path_dom = a ![href - "/" / current_path / _path] - str - _path
                
              if dir_tag
                then
                  div ! [_class "directory"] -
                    path_dom
                else
                  path_dom
            )
          


default_css_style :: B.ByteString
default_css_style = [here|

body {
line-height: 1.5em;
font-size: 1.3em;
}

  .directory a
, .directory a:visited {
color: grey;
}

  a
, a:visited {
text-decoration: none;
color: #222;
display: block;
background: #eee;
padding: 3px;
padding-left: 20px;
}

a:hover {
background: #ccc;
}

li {
list-style-type: none;

width: 80%;
margin: 5px;
}


|]


default_mime_types :: B.ByteString
default_mime_types = [here|

hs text/plain; charset=utf-8
lhs text/plain; charset=utf-8

|] .B.pack