diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Derek Elkins + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Derek Elkins nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,169 @@ +module Main where +import Control.Applicative ( liftA2 ) -- base +import Control.Monad ( when ) -- base +import qualified Data.ByteString as BS -- bytestring +import qualified Data.ByteString.Char8 as CBS -- bytestring +import qualified Data.ByteString.Lazy as LBS -- bytestring +import Data.List ( sort ) -- base +import Data.Maybe ( fromMaybe, maybe ) -- base +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 ) -- directory +import System.Environment ( getArgs ) -- base +import System.FilePath ( () ) -- filepath +import System.IO ( putStrLn ) -- base +import Network.HTTP.Types.Status ( status200, status403, status404 ) -- http-types +import Network.Wai ( Application, Middleware, rawPathInfo, responseLBS ) -- wai +import qualified Network.Wai.Handler.Warp as Warp -- warp +import qualified Network.Wai.Handler.WarpTLS as Warp -- warp-tls +import Network.Wai.Middleware.Gzip ( gzip, gzipFiles, def, GzipFiles(GzipIgnore, GzipCompress) ) -- wai-extra +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 ) -- wai-middleware-static + +-- Maybe future things: virtual hosts, caching, PUT/POST/DELETE support, dropping permissions, client certificates +-- Not future things: CGI etc of any sort + +data Options = Options { + optPort :: Int, + + optHelp :: Bool, + optVerbose :: Bool, + + optCompress :: Bool, + + optDirectoryListings :: Bool, + + optLocalOnly :: Bool, + + -- Basic authentication options + optRealm :: String, + optUserName :: BS.ByteString, -- some default could be chosen + optPassword :: BS.ByteString, -- maybe we could generate and display one rather than requiring this + + -- HTTPS options + optHTTPS :: Bool, + optCertificate :: FilePath, + optKeyFile :: FilePath, + optAllowHTTP :: Bool } + +defOptions :: Options +defOptions = Options { + optPort = 3000, + optHelp = False, + optVerbose = False, -- TODO: Set the logging settings for the various middlewares. + optCompress = True, + optDirectoryListings = True, + optLocalOnly = False, + optRealm = "", + optUserName = BS.empty, + optPassword = BS.empty, + optHTTPS = False, + optCertificate = "", + optKeyFile = "", + optAllowHTTP = False } -- TODO: AllowHTTP doesn't work. A bug in warp-tls? + +options :: [OptDescr (Options -> Options)] +options = [ + Option "p" ["port"] (OptArg (\p opt -> opt { optPort = maybe (optPort defOptions) read p }) "NUM") + ("Port to listen on. (Default: " ++ (show $ optPort defOptions) ++ ")"), + Option "h?" ["help"] (NoArg (\opt -> opt { optHelp = True })) + "Print usage.", + Option "V" ["verbose"] (NoArg (\opt -> opt { optVerbose = True })) + "Print diagnostic output.", + Option "l" ["local"] (NoArg (\opt -> opt { optLocalOnly = True })) + "Only accept connections from localhost.", + Option "z" ["gzip", "compress"] (NoArg (\opt -> opt { optCompress = True })) + "Enable compression. (Default)", + Option "" ["no-compress"] (NoArg (\opt -> opt { optCompress = False })) + "Disable compression.", + Option "" ["no-listings"] (NoArg (\opt -> opt { optDirectoryListings = False })) + "Don't list directory contents.", + Option "r" ["realm"] (OptArg (\r opt -> opt { optRealm = fromMaybe "" r }) "REALM") + "Set the authentication realm. It's recommended to use this with HTTPS. (Default: \"\")", + Option "" ["password"] (OptArg (\pw opt -> opt { optPassword = fromString $ fromMaybe "" pw }) "PASSWORD") + "Require the given password. It's recommended to use this with HTTPS.", + Option "u" ["username"] (OptArg (\u opt -> opt { optUserName = fromString $ fromMaybe "" u }) "USERNAME") + "Require the given username. It's recommended to use this with HTTPS.", + Option "s" ["secure"] (NoArg (\opt -> opt { optHTTPS = True })) + "Enable HTTPS.", + Option "" ["certificate"] (OptArg (\f opt -> opt { optCertificate = fromMaybe "" f }) "FILE") + "Require the given username. It's recommended to use this with HTTPS.", + Option "" ["key-file"] (OptArg (\f opt -> opt { optKeyFile = fromMaybe "" f }) "FILE") + "Require the given username. It's recommended to use this with HTTPS.", + Option "" ["allow-http"] (NoArg (\opt -> opt { optAllowHTTP = True })) + "Allow HTTP access when HTTPS is enabled. (Not working.)", + Option "" ["disallow-http"] (NoArg (\opt -> opt { optAllowHTTP = False })) + "Disallow HTTP access when HTTPS is enabled. (Default)" + ] + +validateOptions :: Options -> Maybe String +validateOptions opts + | BS.null (optPassword opts) && not (BS.null $ optUserName opts) = Just "Password is required to enable Basic Authentication." + | not (BS.null $ optPassword opts) && BS.null (optUserName opts) = Just "Username is required to enable Basic Authentication." + | optHTTPS opts && (null (optCertificate opts) || null (optKeyFile opts)) = Just "Certificate and key are required to enable HTTPS" + | otherwise = Nothing + +usageHeader :: String +usageHeader = "Usage: sws [OPTIONS...] [DIRECTORY]" + +basePolicy :: Policy +basePolicy = noDots <> isNotAbsolute + +enableIf :: Bool -> (a -> a) -> a -> a +enableIf True f = f +enableIf _ _ = id + +-- 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. + b <- doesDirectoryExist path + if not b then app req k else do + when (optVerbose opts) $ putStrLn $ "Rendering listing for " ++ path + html <- fmap container (mapM (\p -> fileDetails p (path p)) =<< fmap sort (getDirectoryContents path)) + k (responseLBS status200 [] html) + where fileDetails label f = liftA2 (renderFile label f) (doesDirectoryExist f) (getModificationTime f) + renderFile label path isDirectory modTime = LBS.concat $ map fromString [ + "", if isDirectory then "d" else "f", "", label, "", show modTime, "" + ] + container xs + = fromString "sws
" + <> LBS.concat xs + <> fromString "
NameLast Modified
sws 0.1.0.0
" + +app404 :: Application +app404 req k = k (responseLBS status404 [] (fromString "File Not Found")) + +serve :: Options -> String -> IO () +serve (Options { optHelp = True }) _ = putStrLn $ usageInfo usageHeader options +serve opts dir = + case validateOptions opts of + Just err -> putStrLn err + Nothing -> do + putStrLn $ "Listening on port " ++ show (optPort opts) + runner + $ enableIf (optVerbose opts) logStdout + $ enableIf (optLocalOnly opts) (local (responseLBS status403 [] LBS.empty)) + $ enableIf (not $ BS.null $ optPassword opts) + (basicAuth (\u p -> return $ optUserName opts == u && optPassword opts == p) + (fromString $ optRealm opts)) + $ enableIf (optCompress opts) (gzip def { gzipFiles = GzipCompress }) + $ staticPolicy (basePolicy <> addBase dir) + $ enableIf (optDirectoryListings opts) (directoryListing opts dir) + $ app404 + where runner | optHTTPS opts = Warp.runTLS tlsSettings (Warp.setPort (optPort opts) Warp.defaultSettings) + | otherwise = Warp.run (optPort opts) + where tlsSettings = (Warp.tlsSettings (optCertificate opts) (optKeyFile opts)) { + Warp.onInsecure = if optAllowHTTP opts then Warp.AllowInsecure else Warp.DenyInsecure (fromString "Use HTTPS") } + +main :: IO () +main = do + args <- getArgs + case getOpt Permute options args of + (os, [], []) -> serve (combine os) "." + (os, [dir], []) -> serve (combine os) dir + (_,_,errs) -> putStrLn (concat errs ++ usageInfo usageHeader options) + where combine = foldr ($) defOptions diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sws.cabal b/sws.cabal new file mode 100644 --- /dev/null +++ b/sws.cabal @@ -0,0 +1,81 @@ +-- Initial sws.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: sws + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: A simple web server for serving directories, similar to weborf. + +-- A longer description of the package. +description: + The main drivers for this application were Windows (and Linux) support and + security, and to a lesser extent performance. Security is improved over + weborf by using Haskell, supporting TLS, and explicitly NOT supporting CGIs + of any kind. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Derek Elkins + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: derek.a.elkins@gmail.com + +-- A copyright notice. +copyright: Copyright (c) 2014 Derek Elkins + +category: Web + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +executable sws + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: + base >=4.6 && <4.8, + directory(==1.2.*), + filepath(==1.3.*), + bytestring(==0.10.*), + http-types(==0.8.*), + warp(==3.0.*), + warp-tls(==3.0.*), + wai(==3.0.*), + wai-middleware-static(==0.6.*), + wai-extra(==3.0.*) + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 +