{-# LANGUAGE CPP, RecordWildCards #-}
-- | 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 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

-- | 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)]
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]