maid-2012.1.19: src/maid.hs

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


import System.Environment (getArgs)
import Air.Env hiding (div, log, head, def)


import Air.TH
import Air.Extra (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 Hack2.Contrib.Middleware.XForwardedForToRemoteHost
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 System.Posix.Files
import Data.List (isInfixOf, sort, (\\))
import Text.HTML.Moe2 hiding ((/), select, br)
import Control.Monad ((>=>))
import System.Process
import System.Directory (doesFileExist, getDirectoryContents, doesDirectoryExist)
import Control.Arrow ((&&&))
import qualified Data.ByteString.Char8 as B

-- import qualified Hack2.Handler.Mongrel2HTTP as Mongrel2
-- import Hack2.Handler.Warp
import Hack2.Handler.SnapServer


-- test_handler = Mongrel2.Handler
--   {
--     Mongrel2.handlerPullFrom = "tcp://127.0.0.1:6666"
--   , Mongrel2.handlerPublishTo = "tcp://127.0.0.1:6667"
--   , Mongrel2.handlerId = Just "bcc1453e-9cc0-11e0-af11-6cf049b16ec3"
--   }





main :: IO ()
main = do
  args <- getArgs
  let { port = 
    if length args == (0 :: Int)
      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
  

  let version = "2011.10.12"
      -- moe = "Moe MAX"
      
      br = puts ""
  
  br
  
  puts - " ❂ Maid Version:    " + version
  br
  
  puts - "   Usage:           maid port"
  puts - "   Example:         maid 3000"
  br
  
  puts - "   Serving on port: " ++ show port
  br
  
  let maid_app = use (middleware_stack - B.unpack mime_types) app
  -- Mongrel2.runWithConfig def { Mongrel2.handler = test_handler } maid_app
  
  runWithConfig def {port} - maid_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
  , x_forwarded_for_to_remote_host
  , 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 = 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
      directory_exist <- doesDirectoryExist _path
      if not directory_exist
        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 _path

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

              let flagged = zip _paths is_path_dir_flag
          
                  dirs = flagged.select snd.sort .map_fst (+ "/")
                  files =  flagged.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
            
              
              let _html = B.pack - dir_template sorted (B.unpack _css) (env.path.B.unpack.unescape_uri)
              
              return - def
                {
                  status = 200
                }
                .set_body_bytestring _html
                .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.b2u / _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