diff --git a/Nemesis b/Nemesis --- a/Nemesis +++ b/Nemesis @@ -23,10 +23,6 @@ task "stat" - do sh "cloc -match-f=hs$ --quiet src --no3" - bin "run" "maid" - - where - bin n x = task n - do - sh - "ghc --make -Wall -isrc src/" ++ x ++ ".hs -o .bin/" ++ n - sh - "echo done.." - sh - ".bin/" ++ n + desc "run" + task "run" - do + sh "runghc src/maid.hs" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +2010.9.9 +-------- + +### Feature + +* add simple dir listing + 2009.11.16 ---------- diff --git a/maid.cabal b/maid.cabal --- a/maid.cabal +++ b/maid.cabal @@ -1,5 +1,5 @@ Name: maid -Version: 2010.4.24 +Version: 2010.9.9 Build-type: Simple Synopsis: A simple static web server Description: @@ -20,12 +20,15 @@ ghc-options: -Wall -threaded build-depends: base >= 4 && < 5 , mps >= 2010.1.26 - , loli >= 2009.8.18 , haskell98 , hack-contrib >= 2010.1.26 , data-default - , hack-handler-hyena >= 2009.12.20 + , hack-handler-hyena , hack , containers + , moe + , unix + , bytestring + , process hs-source-dirs: src/ main-is: maid.hs diff --git a/src/maid.hs b/src/maid.hs --- a/src/maid.hs +++ b/src/maid.hs @@ -1,16 +1,34 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns, QuasiQuotes #-} -import Network.Loli (loli, public, mime) + import Hack.Handler.Hyena import System (getArgs) -import MPS (splash, (/), (-)) +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 Prelude hiding ((/), (-), (>)) 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 @@ -21,31 +39,183 @@ } let { app = - try_index - loli - do - public (Just ".") [""] - mapM_ (splash mime) (toAscList mime_types) + 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 - "\226\157\130 Maid serving on port: " ++ show port + putStrLn - " ❂ Maid serving on port: " ++ show port putStrLn "" - runWithConfig def {port} - app + runWithConfig def {port} - use middleware_stack app + -- run port - use middleware_stack app where - try_index app = \env -> do - r <- app env - if status r == 404 - then do - r' <- app (env {pathInfo = pathInfo env / "index.html"}) - if status r' == 404 - then do - r'' <- app (env {pathInfo = pathInfo env / "index.htm"}) - if status r'' == 404 - then return r - else return r'' - else - return r' - else - return r + 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; +} + + +|]