diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ # Change Log All notable changes to this project will be documented in this file. +## 0.4.5.0 - 2019-10-14 +### Added +- `--content-type` option to override content types for a given file extension. + +## 0.4.4.0 - 2019-02-04 +### Changed +- Unescape URIs before generating directory listings. + ## 0.4.3.0 - 2018-09-15 ### Changed - Upper bound bumps. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -8,20 +8,23 @@ import qualified Data.ByteString.Char8 as CBS -- bytestring import qualified Data.ByteString.Lazy as LBS -- bytestring import Data.Bits ( (.&.), unsafeShiftR, xor ) -- base +import Data.Char ( toLower ) -- base import Data.Foldable ( forM_ ) -- base import Data.Int ( Int64 ) -- base import Data.Word ( Word8 ) -- base import Data.List ( sort ) -- base +import qualified Data.Map as M -- containers import Data.Monoid ( (<>) ) -- base import Data.String ( fromString ) -- base import System.Console.GetOpt ( getOpt, usageInfo, OptDescr(..), ArgDescr(..), ArgOrder(..) ) -- base import System.Directory ( getDirectoryContents, doesDirectoryExist, getModificationTime, renameFile, doesFileExist ) -- directory import System.Environment ( getArgs ) -- base -import System.FilePath ( makeRelative, (), takeDirectory, takeFileName ) -- filepath +import System.FilePath ( makeRelative, (), takeDirectory, takeExtension, takeFileName ) -- filepath import System.IO ( putStrLn, hPutStrLn, hPutStr, stderr, hClose, openBinaryTempFileWithDefaultPermissions ) -- base import System.IO.Error ( userError, ioError, catchIOError, isUserError, ioeGetErrorString ) -- base import Network.HTTP.Types.Status ( status200, status403, status404, status409 ) -- http-types import Network.HTTP.Types.Method ( methodPost ) -- http-types +import Network.URI ( unEscapeString ) -- network-uri import Network.Wai ( Application, Middleware, requestMethod, rawPathInfo, responseLBS ) -- wai import qualified Network.Wai.Handler.Warp as Warp -- warp import qualified Network.Wai.Handler.WarpTLS as Warp -- warp-tls @@ -30,7 +33,8 @@ import Network.Wai.Middleware.HttpAuth ( basicAuth, AuthSettings ) -- wai-extra import Network.Wai.Middleware.Local ( local ) -- wai-extra import Network.Wai.Middleware.RequestLogger ( logStdout ) -- wai-extra -import Network.Wai.Middleware.Static ( staticPolicy, addBase, isNotAbsolute, noDots, Policy, tryPolicy ) -- wai-middleware-static +import Network.Wai.Middleware.Static ( staticPolicyWithOptions, addBase, getMimeType, isNotAbsolute, noDots, Policy, tryPolicy) -- wai-middleware-static +import qualified Network.Wai.Middleware.Static as Static ( Options(mimeTypes), defaultOptions ) -- wai-middleware-static import Network.Wai.Middleware.StripHeaders ( stripHeadersIf ) -- wai-extra import Network.Wai.Parse ( tempFileBackEndOpts, parseRequestBody, fileName, fileContent ) -- wai-extra @@ -65,7 +69,7 @@ -- Not future things: CGI etc of any sort, "extensibility" -- vERSION :: String -vERSION = "0.4.3.0" +vERSION = "0.4.4.0" -- STUN code @@ -209,7 +213,7 @@ -- TODO: Make this less fugly. directoryListing :: Options -> FilePath -> Middleware -- TODO: Handle exceptions. Note, this isn't critical. It will carry on. directoryListing opts baseDir app req k = do - let path = baseDir CBS.unpack (BS.tail $ rawPathInfo req) -- TODO: This unpack is ugly. + let path = baseDir unEscapeString (CBS.unpack (BS.tail $ rawPathInfo req)) -- TODO: This unpack is ugly. b <- doesDirectoryExist path if not b then app req k else do when (optVerbose opts) $ putStrLn $ "Rendering listing for " ++ path @@ -270,6 +274,7 @@ optStunPort :: !Net.PortNumber, optHeaders :: ![String], + optContentTypeOverrides :: ![(String, String)], -- Basic authentication options optAuthentication :: !Bool, @@ -285,7 +290,7 @@ optAllowUploads :: !Bool, optUploadOnly :: !Bool, - optOverwriteOption :: !OverwriteOption} + optOverwriteOption :: !OverwriteOption } defOptions :: Options defOptions = Options { @@ -300,6 +305,7 @@ optStunHost = "stun.l.google.com", optStunPort = 19302 , optHeaders = [], + optContentTypeOverrides = [], optAuthentication = True, optRealm = "", optUserName = fromString "guest", @@ -336,6 +342,10 @@ "Equivalent to --no-auth --no-https.", Option "X" [] (ReqArg (\h opt -> opt { optHeaders = h : optHeaders opt }) "HEADER") "Add HEADER to all server responses.", + Option "" ["content-type"] (ReqArg (\h opt -> opt { + optContentTypeOverrides = (takeWhile ('='/=) h, drop 1 (dropWhile ('='/=) h)) + : optContentTypeOverrides opt }) "CONTENT-TYPE-OVERRIDE") + "With argument EXT=MIME, use MIME type MIME for files with extension EXT.", Option "z" ["gzip", "compress"] (NoArg (\opt -> opt { optCompress = True })) "Enable compression. (Default)", Option "" ["no-compress"] (NoArg (\opt -> opt { optCompress = False })) @@ -451,7 +461,7 @@ $ enableIf (optCompress opts) (gzip def { gzipFiles = GzipCompress }) $ enableIf (not (null headers)) (addHeaders headers . stripHeadersIf (map fst headers) (const True)) $ enableIf (optAllowUploads opts || optUploadOnly opts) (update opts policy (overwritePolicy (optOverwriteOption opts))) - $ (if optUploadOnly opts then uploadForm opts policy else staticPolicy policy) + $ (if optUploadOnly opts then uploadForm opts policy else staticPolicyWithOptions staticOpts policy) $ enableIf (optDirectoryListings opts) (directoryListing opts dir) $ app404 where runner now g | optHTTPS opts && certProvided @@ -468,6 +478,9 @@ certProvided = not (null (optCertificate opts)) && not (null (optKeyFile opts)) policy = basePolicy <> addBase dir + contentTypeOverrides = M.fromList (map (\(e, m) -> (map toLower e, CBS.pack m)) $ optContentTypeOverrides opts) + getMimeTypes f = maybe (getMimeType f) id $ M.lookup (map toLower $ drop 1 $ takeExtension f) contentTypeOverrides + staticOpts = Static.defaultOptions { Static.mimeTypes = getMimeTypes } main :: IO () main = do diff --git a/sws.cabal b/sws.cabal --- a/sws.cabal +++ b/sws.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.3.0 +version: 0.4.5.0 -- A short (one-line) description of the package. synopsis: A simple web server for serving directories. @@ -63,36 +63,22 @@ -- other-extensions: -- Other library packages from which modules are imported. - --build-depends: - -- base >= 4.9.1 && < 4.11, - -- bytestring >= 0.10.8 && < 0.11, - -- cryptonite >= 0.24 && < 0.26, - -- directory >= 1.3.0 && < 1.4, - -- filepath >= 1.4.1 && < 1.5, - -- hourglass >= 0.2.10 && < 0.3, - -- http-types >= 0.9.1 && < 0.13, - -- network >= 2.6.3 && < 2.7, - -- resourcet >= 1.1.9 && < 1.3, - -- transformers >= 0.5.2 && < 0.6, - -- wai >= 3.2.1 && < 3.3, - -- wai-extra >= 3.0.20 && < 3.1, - -- wai-middleware-static >= 0.8.1 && < 0.9, - -- warp >= 3.2.13 && < 3.3, - -- warp-tls >= 3.2.4 && < 3.3 build-depends: base >= 4.11.1 && < 4.13, bytestring >= 0.10.8 && < 0.11, + containers >= 0.6.0 && < 0.7, cryptonite >= 0.25 && < 0.26, directory >= 1.3.1 && < 1.4, filepath >= 1.4.2 && < 1.5, hourglass >= 0.2.11 && < 0.3, http-types >= 0.12.1 && < 0.13, network >= 2.7.0 && < 2.9, + network-uri >= 2.6.0 && < 2.7, resourcet >= 1.2.1 && < 1.3, transformers >= 0.5.5 && < 0.6, wai >= 3.2.1 && < 3.3, wai-extra >= 3.0.22 && < 3.1, - wai-middleware-static >= 0.8.2 && < 0.9, + wai-middleware-static >= 0.8.3 && < 0.9, warp >= 3.2.22 && < 3.3, warp-tls >= 3.2.4 && < 3.3