maid-2010.9.9: src/maid.hs

{-# LANGUAGE NamedFieldPuns, QuasiQuotes #-}


import Hack.Handler.Hyena
import System (getArgs)
import MPS.Env hiding (div, log)
import MPS.TH
import MPS.Extra (u2b, b2u, strip, purify)
import MPSUTF8 (ls)
import Prelude ()
import Data.Default (def)
import Hack.Contrib.Middleware.Config
import Hack.Contrib.Middleware.ContentLength
import Hack.Contrib.Middleware.Static
-- import Hack.Contrib.Middleware.SimpleAccessLogger
import Hack.Contrib.Middleware.UserMime
import Hack.Contrib.Mime
import Hack.Contrib.Utils (use, unescape_uri)
import Hack.Contrib.Response (set_content_type)
import Hack
import Data.Map (toAscList)
import Data.ByteString.Lazy.Char8 (pack)
import System.Posix.Files
import Data.List (isInfixOf, sort)
import Text.HTML.Moe hiding ((/), body, head, select)
import Control.Monad ((>=>))
import System.Process
import Control.Concurrent



main :: IO ()
main = do
  args <- getArgs
  let { port = 
    if length args == 0
      then 3000
      else read - head 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-type", "." + env.pathInfo.unescape_uri] ""
          return - r.set_content_type (_content_type.strip)
        else
          return r          
    }

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

{-
log :: String -> IO ()
log x = jailed - putStrLn x
  where
    
    sync_lock :: MVar ()
    sync_lock = purify - newMVar ()

    jailed :: IO a -> IO a
    jailed io = do
      withMVar sync_lock (const io)
-}

middleware_stack :: [Middleware]
middleware_stack =
  [
    no_favicon
  , content_length
--  , simple_access_logger - Just log
  , user_mime - mime_types.toAscList.map_fst (drop 1)
  -- , \app env -> do
  --   r <- app env
  --   print - r.headers
  --   return r
  ]

cascade :: [Application] -> Application
cascade [] = const - return def {status = 404}
cascade (x:xs) = \env -> do
  r <- x env
  if r.status == 404
    then
      cascade xs env
    else
      return r


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 .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
          _paths <- ls _path

          -- 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
              
          return - def
            {
              status = 200
            , body = pack - dir_template sorted
            }
            .set_content_type "text/html; charset=utf-8"
    

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


css_style :: String
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;
}


|]