@@ -0,0 +1,51 @@
1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2+import Network.Wai.Application.Static
3+ ( StaticSettings (..), staticApp, defaultMimeType, defaultListing
4+ , defaultMimeTypes, mimeTypeByExt
5+ , defaultFileServerSettings, fileSystemLookup
6+ , fileName, toFilePath
7+ )
8+import Network.Wai.Handler.Warp (run)
9+import System.Environment (getArgs)
10+import System.Console.CmdArgs
11+import Text.Printf (printf)
12+import System.Directory (canonicalizePath)
13+import Control.Monad (unless)
14+import Network.Wai.Middleware.Autohead
15+import Network.Wai.Middleware.Debug
16+import Network.Wai.Middleware.Gzip
17+import qualified Data.Map as Map
18+import qualified Data.ByteString.Char8 as S8
19+import Control.Arrow ((***))
20+import Data.Text (pack, unpack)
21+
22+data Args = Args
23+ { docroot :: FilePath
24+ , index :: [FilePath]
25+ , port :: Int
26+ , noindex :: Bool
27+ , quiet :: Bool
28+ , verbose :: Bool
29+ , mime :: [(String, String)]
30+ }
31+ deriving (Show, Data, Typeable)
32+
33+defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False []
34+
35+main :: IO ()
36+main = do
37+ Args {..} <- cmdArgs defaultArgs
38+ let mime' = map (toFilePath *** S8.pack) mime
39+ let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes
40+ docroot' <- canonicalizePath docroot
41+ args <- getArgs
42+ unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
43+ let middle = gzip False
44+ . (if verbose then debug else id)
45+ . autohead
46+ run port $ middle $ staticApp defaultFileServerSettings
47+ { ssFolder = fileSystemLookup $ toFilePath docroot
48+ , ssIndices = if noindex then [] else map pack index
49+ , ssListing = Just defaultListing
50+ , ssGetMimeType = return . mimeTypeByExt mimeMap defaultMimeType . fileName
51+ }