Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 232 lines (178 sloc) 6.246 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}


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

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 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.List (isInfixOf, sort, (\\))
import Text.HTML.Moe2 hiding ((/), select, br)
import System.Directory (doesFileExist, getDirectoryContents, doesDirectoryExist)
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, catMaybes)
import System.FilePath (takeExtension)
import System.Process (readProcess)
import Control.Arrow ((***))


import Hack2.Handler.SnapServer
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.IO as TextIO
import Web.Maid.ApacheMimeTypes (apache_mime_types)
import Web.Maid.DefaultCSSStyle (default_css_style)



b2u :: String -> String
b2u = B.pack > E.decodeUtf8 > T.unpack

strip :: String -> String
strip = T.pack > T.strip > T.unpack

main :: IO ()
main = do
  args <- getArgs
  let { _port =
    if length args == (0 :: Int)
      then 3000
      else read - first args .fromMaybe ""
    }

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

  let { app =
    dir_serve - \env -> do
      let static_app = static (Just ".") [""] (const - return not_found)

      r <- static_app env

      -- let 'file' guess the file type
      if env.pathInfo.B.unpack.unescape_uri.takeExtension.T.pack.belongs_to (parse_user_mimes mime_types.map fst)
        then
          return r
        else
          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
    }




  let version = "2013.9.13"
      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 mime_types) app
  runWithConfig def {port = _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 :: T.Text -> [Middleware]
middleware_stack mime_types =
  [
    no_favicon
  , content_length
  , x_forwarded_for_to_remote_host
  , simple_access_logger - Nothing
  , user_mime - map (E.encodeUtf8 *** E.encodeUtf8) - parse_user_mimes mime_types
  ]

parse_user_mimes :: T.Text -> [(T.Text, T.Text)]
parse_user_mimes =
    T.unpack
  > lines
  > map strip
  > reject null
  > reject (starts_with "#")
  > map parse_line
  > catMaybes
  > map expand_line
  > concat
  > map (T.pack *** T.pack)

  where
    parse_line :: String -> Maybe (String, [String])
    parse_line line =
      case line.words of
        (x:y:ys) -> Just (x, y:ys)
        _ -> Nothing

    expand_line :: (String, [String]) -> [(String, String)]
    expand_line (mime, extensions) = extensions.map (,mime)

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 }

list_dir :: Application
list_dir env = do
  let _path = "." + env.pathInfo .B.unpack.unescape_uri.b2u

  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 <- doesDirectoryExist _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 doesDirectoryExist

              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 (E.encodeUtf8 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_mime_types :: T.Text
default_mime_types = apache_mime_types
Something went wrong with that request. Please try again.