{-# 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{..} <- 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' = ((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 = [(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
    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 =
            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
    runSettings
        ( setPort port $
            setHost
                (fromString host)
                defaultSettings
        )
        $ middle
        $ staticApp
            (defaultFileServerSettings $ fromString 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]