{-# 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 -> String
docroot :: FilePath
    , Args -> [String]
index :: [FilePath]
    , Args -> Int
port :: Int
    , Args -> Bool
noindex :: Bool
    , Args -> Bool
quiet :: Bool
    , Args -> Bool
verbose :: Bool
    , Args -> [(String, String)]
mime :: [(String, String)]
    , Args -> String
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 = String
-> [String]
-> Int
-> Bool
-> Bool
-> Bool
-> [(String, String)]
-> String
-> Args
Args
    (String
 -> [String]
 -> Int
 -> Bool
 -> Bool
 -> Bool
 -> [(String, String)]
 -> String
 -> Args)
-> Parser String
-> Parser
     ([String]
      -> Int
      -> Bool
      -> Bool
      -> Bool
      -> [(String, String)]
      -> String
      -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"docroot"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DOCROOT"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"."
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"directory containing files to serve")
    Parser
  ([String]
   -> Int
   -> Bool
   -> Bool
   -> Bool
   -> [(String, String)]
   -> String
   -> Args)
-> Parser [String]
-> Parser
     (Int
      -> Bool -> Bool -> Bool -> [(String, String)] -> String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([String] -> [String]
defIndex ([String] -> [String]) -> Parser [String] -> Parser [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"index"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INDEX"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"index files to serve when a directory is required"
            )))
    Parser
  (Int
   -> Bool -> Bool -> Bool -> [(String, String)] -> String -> Args)
-> Parser Int
-> Parser
     (Bool -> Bool -> Bool -> [(String, String)] -> String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields Int -> Parser Int
option'
            ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"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
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"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 -> [(String, String)] -> String -> Args)
-> Parser Bool
-> Parser (Bool -> Bool -> [(String, String)] -> String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"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 -> [(String, String)] -> String -> Args)
-> Parser Bool
-> Parser (Bool -> [(String, String)] -> String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"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 -> [(String, String)] -> String -> Args)
-> Parser Bool -> Parser ([(String, String)] -> String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
            ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"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 ([(String, String)] -> String -> Args)
-> Parser [(String, String)] -> Parser (String -> Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (String, String) -> Parser [(String, String)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (String -> (String, String)
toPair (String -> (String, String))
-> Parser String -> Parser (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mime"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"MIME"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"extra file extension/mime type mappings"))
    Parser (String -> Args) -> Parser String -> Parser Args
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"host"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"HOST"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"*"
           Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"interface to bind to, special values: *, *4, *6")
  where
    toPair :: String -> (String, String)
toPair = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
    defIndex :: [String] -> [String]
defIndex [] = [String
"index.html", String
"index.htm"]
    defIndex [String]
x = [String]
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
String
[String]
[(String, String)]
host :: String
mime :: [(String, String)]
verbose :: Bool
quiet :: Bool
noindex :: Bool
port :: Int
index :: [String]
docroot :: String
host :: Args -> String
mime :: Args -> [(String, String)]
verbose :: Args -> Bool
quiet :: Args -> Bool
noindex :: Args -> Bool
port :: Args -> Int
index :: Args -> [String]
docroot :: Args -> String
..} <- 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' = ((String, String) -> (Text, ByteString))
-> [(String, String)] -> [(Text, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text)
-> (String -> ByteString) -> (String, String) -> (Text, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> ByteString
S8.pack) [(String, String)]
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
    String
docroot' <- String -> IO String
canonicalizePath String
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
$ String -> String -> Int -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Serving directory %s on port %d with %s index files.\n" String
docroot' Int
port (if Bool
noindex then String
"no" else [String] -> String
forall a. Show a => a -> String
show [String]
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 (String -> HostPreference
forall a. IsString a => String -> a
fromString String
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 (String -> StaticSettings
defaultFileServerSettings (String -> StaticSettings) -> String -> StaticSettings
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
docroot)
        { ssIndices :: [Piece]
ssIndices = if Bool
noindex then [] else (String -> Maybe Piece) -> [String] -> [Piece]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Maybe Piece
toPiece (Text -> Maybe Piece) -> (String -> Text) -> String -> Maybe Piece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) [String]
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 :: 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 String -> ParseError
ShowHelpText Maybe String
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 [String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help", String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text", Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden]