@@ -0,0 +1,105 @@
1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
2+-- | Command line version of wai-app-static, used for the warp-static server.
3+module WaiAppStatic.CmdLine
4+ ( runCommandLine
5+ , Args (..)
6+ ) where
7+
8+import Network.Wai (Middleware)
9+import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
10+import Network.Wai.Handler.Warp
11+ ( runSettings, defaultSettings, settingsHost, settingsPort
12+ )
13+import Options.Applicative
14+import Text.Printf (printf)
15+import System.Directory (canonicalizePath)
16+import Control.Monad (unless)
17+import Network.Wai.Middleware.Autohead
18+import Network.Wai.Middleware.RequestLogger (logStdout)
19+import Network.Wai.Middleware.Gzip
20+import qualified Data.Map as Map
21+import qualified Data.ByteString.Char8 as S8
22+import Control.Arrow ((***))
23+import Data.Text (pack)
24+import Data.String (fromString)
25+import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
26+import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
27+import Data.Maybe (mapMaybe)
28+import Control.Arrow (second)
29+
30+data Args = Args
31+ { docroot :: FilePath
32+ , index :: [FilePath]
33+ , port :: Int
34+ , noindex :: Bool
35+ , quiet :: Bool
36+ , verbose :: Bool
37+ , mime :: [(String, String)]
38+ , host :: String
39+ }
40+
41+args :: Parser Args
42+args = Args
43+ <$> strOption
44+ ( long "docroot"
45+ <> short 'd'
46+ <> metavar "DOCROOT"
47+ <> value "."
48+ <> help "directory containing files to serve")
49+ <*> (defIndex <$> many (strOption
50+ ( long "index"
51+ <> short 'i'
52+ <> metavar "INDEX"
53+ <> help "index files to serve when a directory is required"
54+ )))
55+ <*> option
56+ ( long "port"
57+ <> short 'p'
58+ <> metavar "PORT"
59+ <> value 3000)
60+ <*> switch
61+ ( long "noindex"
62+ <> short 'n')
63+ <*> switch
64+ ( long "quiet"
65+ <> short 'q')
66+ <*> switch
67+ ( long "verbose"
68+ <> short 'v')
69+ <*> many (toPair <$> strOption
70+ ( long "mime"
71+ <> short 'm'
72+ <> metavar "MIME"
73+ <> help "extra file extension/mime type mappings"))
74+ <*> strOption
75+ ( long "host"
76+ <> short 'h'
77+ <> metavar "HOST"
78+ <> value "*"
79+ <> help "interface to bind to, special values: *, *4, *6")
80+ where
81+ toPair = second (drop 1) . break (== '=')
82+ defIndex [] = ["index.html", "index.htm"]
83+ defIndex x = x
84+
85+-- | Run with the given middleware and parsing options from the command line.
86+--
87+-- Since 2.0.1
88+runCommandLine :: (Args -> Middleware) -> IO ()
89+runCommandLine middleware = do
90+ args@Args {..} <- execParser $ info (helper <*> args) fullDesc
91+ let mime' = map (pack *** S8.pack) mime
92+ let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
93+ docroot' <- canonicalizePath docroot
94+ unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
95+ let middle = gzip def { gzipFiles = GzipCompress }
96+ . (if verbose then logStdout else id)
97+ . autohead
98+ . (middleware args)
99+ runSettings defaultSettings
100+ { settingsPort = port
101+ , settingsHost = fromString host
102+ } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
103+ { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
104+ , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
105+ }