diff --git a/WaiAppStatic/CmdLine.hs b/WaiAppStatic/CmdLine.hs new file mode 100644 --- /dev/null +++ b/WaiAppStatic/CmdLine.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} +-- | Command line version of wai-app-static, used for the warp-static server. +module WaiAppStatic.CmdLine + ( runCommandLine + , Args (..) + ) where + +import Network.Wai (Middleware) +import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) +import Network.Wai.Handler.Warp + ( runSettings, defaultSettings, settingsHost, settingsPort + ) +import Options.Applicative +import Text.Printf (printf) +import System.Directory (canonicalizePath) +import Control.Monad (unless) +import Network.Wai.Middleware.Autohead +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.Wai.Middleware.Gzip +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as S8 +import Control.Arrow ((***)) +import Data.Text (pack) +import Data.String (fromString) +import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType) +import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece) +import Data.Maybe (mapMaybe) +import Control.Arrow (second) + +data Args = Args + { docroot :: FilePath + , index :: [FilePath] + , port :: Int + , noindex :: Bool + , quiet :: Bool + , verbose :: Bool + , mime :: [(String, String)] + , host :: String + } + +args :: Parser Args +args = Args + <$> strOption + ( long "docroot" + <> short 'd' + <> metavar "DOCROOT" + <> value "." + <> help "directory containing files to serve") + <*> (defIndex <$> many (strOption + ( long "index" + <> short 'i' + <> metavar "INDEX" + <> help "index files to serve when a directory is required" + ))) + <*> option + ( long "port" + <> short 'p' + <> metavar "PORT" + <> value 3000) + <*> switch + ( long "noindex" + <> short 'n') + <*> switch + ( long "quiet" + <> short 'q') + <*> switch + ( long "verbose" + <> short 'v') + <*> many (toPair <$> strOption + ( long "mime" + <> short 'm' + <> metavar "MIME" + <> help "extra file extension/mime type mappings")) + <*> strOption + ( long "host" + <> short 'h' + <> metavar "HOST" + <> value "*" + <> help "interface to bind to, special values: *, *4, *6") + where + toPair = second (drop 1) . break (== '=') + defIndex [] = ["index.html", "index.htm"] + defIndex x = x + +-- | Run with the given middleware and parsing options from the command line. +-- +-- Since 2.0.1 +runCommandLine :: (Args -> Middleware) -> IO () +runCommandLine middleware = do + args@Args {..} <- execParser $ info (helper <*> args) fullDesc + let mime' = map (pack *** S8.pack) mime + let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap + docroot' <- canonicalizePath docroot + unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index) + let middle = gzip def { gzipFiles = GzipCompress } + . (if verbose then logStdout else id) + . autohead + . (middleware args) + runSettings defaultSettings + { settingsPort = port + , settingsHost = fromString host + } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot) + { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index + , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName + } diff --git a/app/warp-static.hs b/app/warp-static.hs --- a/app/warp-static.hs +++ b/app/warp-static.hs @@ -1,53 +1,7 @@ {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} -import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) -import Network.Wai.Handler.Warp - ( runSettings, defaultSettings, settingsHost, settingsPort - ) -import System.Console.CmdArgs hiding (def) -import Text.Printf (printf) -import System.Directory (canonicalizePath) -import Control.Monad (unless) -import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.RequestLogger (logStdout) -import Network.Wai.Middleware.Gzip -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as S8 -import Control.Arrow ((***)) -import Data.Text (pack) -import Data.String (fromString) -import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType) -import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece) -import Data.Maybe (mapMaybe) - -data Args = Args - { docroot :: FilePath - , index :: [FilePath] - , port :: Int - , noindex :: Bool - , quiet :: Bool - , verbose :: Bool - , mime :: [(String, String)] - , host :: String - } - deriving (Show, Data, Typeable) +module Main (main) where -defaultArgs :: Args -defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] "*" +import WaiAppStatic.CmdLine (runCommandLine) main :: IO () -main = do - Args {..} <- cmdArgs defaultArgs - let mime' = map (pack *** S8.pack) mime - let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap - docroot' <- canonicalizePath docroot - unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index) - let middle = gzip def { gzipFiles = GzipCompress } - . (if verbose then logStdout else id) - . autohead - runSettings defaultSettings - { settingsPort = port - , settingsHost = fromString host - } $ middle $ staticApp (defaultFileServerSettings $ fromString docroot) - { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index - , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName - } +main = runCommandLine (const id) diff --git a/wai-app-static.cabal b/wai-app-static.cabal --- a/wai-app-static.cabal +++ b/wai-app-static.cabal @@ -1,5 +1,5 @@ name: wai-app-static -version: 2.0.0.5 +version: 2.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -50,12 +50,16 @@ , template-haskell >= 2.7 , zlib >= 0.5 , filepath + , wai-extra >= 2.0 && < 2.2 + , optparse-applicative >= 0.7 + , warp >= 2.0 && < 2.2 exposed-modules: Network.Wai.Application.Static WaiAppStatic.Storage.Filesystem WaiAppStatic.Storage.Embedded WaiAppStatic.Listing WaiAppStatic.Types + WaiAppStatic.CmdLine other-modules: Util WaiAppStatic.Storage.Embedded.Runtime WaiAppStatic.Storage.Embedded.TH @@ -69,10 +73,7 @@ Main-is: warp-static.hs hs-source-dirs: app Build-depends: base >= 4 && < 5 - , warp >= 2.0 && < 2.2 , wai-app-static >= 2.0 && < 2.1 - , wai-extra >= 2.0 && < 2.2 - , cmdargs >= 0.6.7 , directory >= 1.0 , containers >= 0.2 , bytestring >= 0.9.1.4