git.iko.soy/typeable/wai
on wai-websockets/1.2.0.3 help sign in
typeable/wai/warp-static/warp.hs
59 lines 2.1 kB history raw
1{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2import Network.Wai.Application.Static
3 ( StaticSettings (..), staticApp, defaultMimeType, defaultListing
4 , defaultMimeTypes, mimeTypeByExt
5 , defaultFileServerSettings, fileSystemLookup
6 , fileName, toFilePath
7 , ssRedirectToIndex
8 )
9import Network.Wai.Handler.Warp
10 ( runSettings, defaultSettings, settingsHost, settingsPort
11 )
12import System.Console.CmdArgs hiding (def)
13import Text.Printf (printf)
14import System.Directory (canonicalizePath)
15import Control.Monad (unless)
16import Network.Wai.Middleware.Autohead
17import Network.Wai.Middleware.RequestLogger (logStdout)
18import Network.Wai.Middleware.Gzip
19import qualified Data.Map as Map
20import qualified Data.ByteString.Char8 as S8
21import Control.Arrow ((***))
22import Data.Text (pack)
23import Data.String (fromString)
25data Args = Args
26 { docroot :: FilePath
27 , index :: [FilePath]
28 , port :: Int
29 , noindex :: Bool
30 , quiet :: Bool
31 , verbose :: Bool
32 , mime :: [(String, String)]
33 , host :: String
34 }
35 deriving (Show, Data, Typeable)
37defaultArgs :: Args
38defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] "*"
40main :: IO ()
41main = do
42 Args {..} <- cmdArgs defaultArgs
43 let mime' = map (toFilePath *** S8.pack) mime
44 let mimeMap = Map.fromList mime' `Map.union` defaultMimeTypes
45 docroot' <- canonicalizePath docroot
46 unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
47 let middle = gzip def
48 . (if verbose then logStdout else id)
49 . autohead
50 runSettings defaultSettings
51 { settingsPort = port
52 , settingsHost = fromString host
53 } $ middle $ staticApp defaultFileServerSettings
54 { ssFolder = fileSystemLookup $ toFilePath docroot
55 , ssIndices = if noindex then [] else map pack index
56 , ssRedirectToIndex = False
57 , ssListing = Just defaultListing
58 , ssGetMimeType = return . mimeTypeByExt mimeMap defaultMimeType . fileName
59 }