{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- | Command line version of wai-app-static, used for the warp-static server.
module WaiAppStatic.CmdLine (
    runCommandLine,
    Args (..),
) where

import Control.Arrow (second, (***))
import Control.Monad (unless)
import qualified Data.ByteString.Char8 as S8
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.String (fromString)
import Data.Text (pack)
import Network.Mime (defaultMimeMap, defaultMimeType, mimeByExt)
import Network.Wai (Middleware)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import Network.Wai.Handler.Warp (
    defaultSettings,
    runSettings,
    setHost,
    setPort,
 )
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.RequestLogger (logStdout)
import Options.Applicative
import System.Directory (canonicalizePath)
import Text.Printf (printf)
import WaiAppStatic.Types (
    fileName,
    fromPiece,
    ssGetMimeType,
    ssIndices,
    toPiece,
 )
#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' = ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
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
        (FilePath
 -> [FilePath]
 -> Int
 -> Bool
 -> Bool
 -> Bool
 -> [(FilePath, FilePath)]
 -> FilePath
 -> Args)
-> Parser FilePath
-> Parser
     ([FilePath]
      -> Int
      -> Bool
      -> Bool
      -> Bool
      -> [(FilePath, FilePath)]
      -> FilePath
      -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"docroot"
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DOCROOT"
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"."
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"directory containing files to serve"
            )
        Parser
  ([FilePath]
   -> Int
   -> Bool
   -> Bool
   -> Bool
   -> [(FilePath, FilePath)]
   -> FilePath
   -> Args)
-> Parser [FilePath]
-> Parser
     (Int
      -> Bool
      -> Bool
      -> Bool
      -> [(FilePath, FilePath)]
      -> FilePath
      -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( [FilePath] -> [FilePath]
defIndex
                ([FilePath] -> [FilePath])
-> Parser [FilePath] -> Parser [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath -> Parser [FilePath]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
                    ( Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                        ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"index"
                            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
                            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INDEX"
                            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"index files to serve when a directory is required"
                        )
                    )
            )
        Parser
  (Int
   -> Bool
   -> Bool
   -> Bool
   -> [(FilePath, FilePath)]
   -> FilePath
   -> Args)
-> Parser Int
-> Parser
     (Bool
      -> Bool -> Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields Int -> Parser Int
option'
            ( FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"port"
                Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p'
                Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"PORT"
                Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
3000
            )
        Parser
  (Bool
   -> Bool -> Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
-> Parser Bool
-> Parser
     (Bool -> Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"noindex"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n'
            )
        Parser (Bool -> Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
-> Parser Bool
-> Parser (Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"quiet"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'q'
            )
        Parser (Bool -> [(FilePath, FilePath)] -> FilePath -> Args)
-> Parser Bool
-> Parser ([(FilePath, FilePath)] -> FilePath -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"verbose"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v'
            )
        Parser ([(FilePath, FilePath)] -> FilePath -> Args)
-> Parser [(FilePath, FilePath)] -> Parser (FilePath -> Args)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (FilePath, FilePath) -> Parser [(FilePath, FilePath)]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
            ( FilePath -> (FilePath, FilePath)
toPair
                (FilePath -> (FilePath, FilePath))
-> Parser FilePath -> Parser (FilePath, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
                    ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"mime"
                        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
                        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MIME"
                        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"extra file extension/mime type mappings"
                    )
            )
        Parser (FilePath -> Args) -> Parser FilePath -> Parser Args
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"host"
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"HOST"
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"*"
                Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"interface to bind to, special values: *, *4, *6"
            )
  where
    toPair :: FilePath -> (FilePath, FilePath)
toPair = (FilePath -> FilePath)
-> (FilePath, FilePath) -> (FilePath, FilePath)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1) ((FilePath, FilePath) -> (FilePath, FilePath))
-> (FilePath -> (FilePath, FilePath))
-> FilePath
-> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
    defIndex :: [FilePath] -> [FilePath]
defIndex [] = [FilePath
"index.html", FilePath
"index.htm"]
    defIndex [FilePath]
x = [FilePath]
x

-- | Run with the given middleware and parsing options from the command line.
--
-- Since 2.0.1
runCommandLine :: (Args -> Middleware) -> IO ()
runCommandLine :: (Args -> Middleware) -> IO ()
runCommandLine Args -> Middleware
middleware = do
    clArgs :: Args
clArgs@Args{Bool
Int
FilePath
[FilePath]
[(FilePath, FilePath)]
docroot :: Args -> FilePath
index :: Args -> [FilePath]
port :: Args -> Int
noindex :: Args -> Bool
quiet :: Args -> Bool
verbose :: Args -> Bool
mime :: Args -> [(FilePath, FilePath)]
host :: Args -> FilePath
docroot :: FilePath
index :: [FilePath]
port :: Int
noindex :: Bool
quiet :: Bool
verbose :: Bool
mime :: [(FilePath, FilePath)]
host :: FilePath
..} <- ParserInfo Args -> IO Args
forall a. ParserInfo a -> IO a
execParser (ParserInfo Args -> IO Args) -> ParserInfo Args -> IO Args
forall a b. (a -> b) -> a -> b
$ Parser Args -> InfoMod Args -> ParserInfo Args
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (Args -> Args)
forall a. Parser (a -> a)
helperOption Parser (Args -> Args) -> Parser Args -> Parser Args
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Args
args) InfoMod Args
forall a. InfoMod a
fullDesc
    let mime' :: [(Text, ByteString)]
mime' = ((FilePath, FilePath) -> (Text, ByteString))
-> [(FilePath, FilePath)] -> [(Text, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
pack (FilePath -> Text)
-> (FilePath -> ByteString)
-> (FilePath, FilePath)
-> (Text, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 = [(Text, ByteString)] -> Map Text ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, ByteString)]
mime' Map Text ByteString -> Map Text ByteString -> Map Text ByteString
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> FilePath -> Int -> FilePath -> IO ()
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 [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
index)
    let middle :: Middleware
middle =
            GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def{gzipFiles = GzipCompress}
                Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
verbose then Middleware
logStdout else Middleware
forall a. a -> a
id)
                Middleware -> Middleware -> Middleware
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 (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
            HostPreference -> Settings -> Settings
setHost
                (FilePath -> HostPreference
forall a. IsString a => FilePath -> a
fromString FilePath
host)
                Settings
defaultSettings
        )
        (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Middleware
middle
        Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp
            (FilePath -> StaticSettings
defaultFileServerSettings (FilePath -> StaticSettings) -> FilePath -> StaticSettings
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString FilePath
docroot)
                { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
                , ssGetMimeType =
                    return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
                }
  where
    helperOption :: Parser (a -> a)
    helperOption :: forall a. Parser (a -> a)
helperOption =
#if MIN_VERSION_optparse_applicative(0,16,0)
        ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption (Maybe FilePath -> ParseError
ShowHelpText Maybe FilePath
forall a. Maybe a
Nothing) (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
#else
        abortOption ShowHelpText $
#endif
            [Mod OptionFields (a -> a)] -> Mod OptionFields (a -> a)
forall a. Monoid a => [a] -> a
mconcat [FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"help", FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Show this help text", Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden]