{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP #-}
-- | 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, 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' = 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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (FilePath, FilePath) -> Parser [(FilePath, FilePath)]
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 (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 (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
    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
..} <- 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 (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 (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 :: GzipFiles
gzipFiles = 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
args)
    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 :: [Piece]
ssIndices = if Bool
noindex then [] else (FilePath -> Maybe Piece) -> [FilePath] -> [Piece]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Maybe Piece
toPiece (Text -> Maybe Piece)
-> (FilePath -> Text) -> FilePath -> Maybe Piece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack) [FilePath]
index
        , ssGetMimeType :: File -> IO ByteString
ssGetMimeType = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> (File -> ByteString) -> File -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text ByteString -> ByteString -> Text -> ByteString
mimeByExt Map Text ByteString
mimeMap ByteString
defaultMimeType (Text -> ByteString) -> (File -> Text) -> File -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece (Piece -> Text) -> (File -> Piece) -> File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Piece
fileName
        }
    where
      helperOption :: Parser (a -> a)
      helperOption :: 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]