maid 2010.4.24 → 2010.9.9
raw patch · 4 files changed
+211/−35 lines, 4 filesdep +bytestringdep +moedep +processdep −lolidep ~hack-handler-hyena
Dependencies added: bytestring, moe, process, unix
Dependencies removed: loli
Dependency ranges changed: hack-handler-hyena
Files
- Nemesis +3/−7
- changelog.md +7/−0
- maid.cabal +6/−3
- src/maid.hs +195/−25
Nemesis view
@@ -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"
changelog.md view
@@ -1,3 +1,10 @@+2010.9.9+--------++### Feature++* add simple dir listing+ 2009.11.16 ----------
maid.cabal view
@@ -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
src/maid.hs view
@@ -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;+}+++|]