{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP #-}
module WaiAppStatic.CmdLine
( runCommandLine
, Args (..)
) where
import Network.Wai (Middleware)
import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
import Network.Wai.Handler.Warp
( runSettings, defaultSettings, setHost, setPort
)
import Options.Applicative
import Text.Printf (printf)
import System.Directory (canonicalizePath)
import Control.Monad (unless)
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)
import Data.Monoid ((<>))
data Args = Args
{ Args -> FilePath
docroot :: FilePath
, Args -> [FilePath]
index :: [FilePath]
, Args -> Int
port :: Int
, Args -> Bool
noindex :: Bool
, Args -> Bool
quiet :: Bool
, Args -> Bool
verbose :: Bool
, Args -> [(FilePath, FilePath)]
mime :: [(String, String)]
, Args -> FilePath
host :: String
}
#if MIN_VERSION_optparse_applicative(0, 10, 0)
option' :: Mod OptionFields Int -> Parser Int
option' :: Mod OptionFields Int -> Parser Int
option' = forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
#else
option' = option
#endif
args :: Parser Args
args :: Parser Args
args = FilePath
-> [FilePath]
-> Int
-> Bool
-> Bool
-> Bool
-> [(FilePath, FilePath)]
-> FilePath
-> Args
Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"docroot"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DOCROOT"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"."
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"directory containing files to serve")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([FilePath] -> [FilePath]
defIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"index"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INDEX"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"index files to serve when a directory is required"
)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields Int -> Parser Int
option'
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"port"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p'
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PORT"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
3000)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"noindex"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"quiet"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'q')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"verbose"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (FilePath -> (FilePath, FilePath)
toPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"mime"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MIME"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"extra file extension/mime type mappings"))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
( forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"host"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"HOST"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"*"
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"interface to bind to, special values: *, *4, *6")
where
toPair :: FilePath -> (FilePath, FilePath)
toPair = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. Int -> [a] -> [a]
drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=')
defIndex :: [FilePath] -> [FilePath]
defIndex [] = [FilePath
"index.html", FilePath
"index.htm"]
defIndex [FilePath]
x = [FilePath]
x
runCommandLine :: (Args -> Middleware) -> IO ()
runCommandLine :: (Args -> Middleware) -> IO ()
runCommandLine Args -> Middleware
middleware = do
args :: Args
args@Args {Bool
Int
FilePath
[FilePath]
[(FilePath, FilePath)]
host :: FilePath
mime :: [(FilePath, FilePath)]
verbose :: Bool
quiet :: Bool
noindex :: Bool
port :: Int
index :: [FilePath]
docroot :: FilePath
host :: Args -> FilePath
mime :: Args -> [(FilePath, FilePath)]
verbose :: Args -> Bool
quiet :: Args -> Bool
noindex :: Args -> Bool
port :: Args -> Int
index :: Args -> [FilePath]
docroot :: Args -> FilePath
..} <- forall a. ParserInfo a -> IO a
execParser forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall a. Parser (a -> a)
helperOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Args
args) forall a. InfoMod a
fullDesc
let mime' :: [(Text, ByteString)]
mime' = forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
pack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FilePath -> ByteString
S8.pack) [(FilePath, FilePath)]
mime
let mimeMap :: Map Text ByteString
mimeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, ByteString)]
mime' forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Text ByteString
defaultMimeMap
FilePath
docroot' <- FilePath -> IO FilePath
canonicalizePath FilePath
docroot
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => FilePath -> r
printf FilePath
"Serving directory %s on port %d with %s index files.\n" FilePath
docroot' Int
port (if Bool
noindex then FilePath
"no" else forall a. Show a => a -> FilePath
show [FilePath]
index)
let middle :: Middleware
middle = GzipSettings -> Middleware
gzip forall a. Default a => a
def { gzipFiles :: GzipFiles
gzipFiles = GzipFiles
GzipCompress }
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
verbose then Middleware
logStdout else forall a. a -> a
id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Args -> Middleware
middleware Args
args)
Settings -> Application -> IO ()
runSettings
( Int -> Settings -> Settings
setPort Int
port
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (forall a. IsString a => FilePath -> a
fromString FilePath
host)
Settings
defaultSettings
)
forall a b. (a -> b) -> a -> b
$ Middleware
middle forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (FilePath -> StaticSettings
defaultFileServerSettings forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
docroot)
{ ssIndices :: [Piece]
ssIndices = if Bool
noindex then [] else forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Maybe Piece
toPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack) [FilePath]
index
, ssGetMimeType :: File -> IO ByteString
ssGetMimeType = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text ByteString -> ByteString -> Text -> ByteString
mimeByExt Map Text ByteString
mimeMap ByteString
defaultMimeType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
}
where
helperOption :: Parser (a -> a)
helperOption :: forall a. Parser (a -> a)
helperOption =
#if MIN_VERSION_optparse_applicative(0,16,0)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption (Maybe FilePath -> ParseError
ShowHelpText forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
#else
abortOption ShowHelpText $
#endif
forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"help", forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Show this help text", forall (f :: * -> *) a. Mod f a
hidden]