@@ -0,0 +1,53 @@
1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2+import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
3+import Network.Wai.Handler.Warp
4+ ( runSettings, defaultSettings, settingsHost, settingsPort
5+ )
6+import System.Console.CmdArgs hiding (def)
7+import Text.Printf (printf)
8+import System.Directory (canonicalizePath)
9+import Control.Monad (unless)
10+import Network.Wai.Middleware.Autohead
11+import Network.Wai.Middleware.RequestLogger (logStdout)
12+import Network.Wai.Middleware.Gzip
13+import qualified Data.Map as Map
14+import qualified Data.ByteString.Char8 as S8
15+import Control.Arrow ((***))
16+import Data.Text (pack)
17+import Data.String (fromString)
18+import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
19+import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
20+import Data.Maybe (mapMaybe)
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+ , host :: String
31+ }
32+ deriving (Show, Data, Typeable)
33+
34+defaultArgs :: Args
35+defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] "*"
36+
37+main :: IO ()
38+main = do
39+ Args {..} <- cmdArgs defaultArgs
40+ let mime' = map (pack *** S8.pack) mime
41+ let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
42+ docroot' <- canonicalizePath docroot
43+ unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
44+ let middle = gzip def { gzipFiles = GzipCompress }
45+ . (if verbose then logStdout else id)
46+ . autohead
47+ runSettings defaultSettings
48+ { settingsPort = port
49+ , settingsHost = fromString host
50+ } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
51+ { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
52+ , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
53+ }