{-# LANGUAGE CPP, RecordWildCards #-}
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 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, (***))
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
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
clArgs :: Args
clArgs@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
clArgs
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]