sws 0.1.0.1 → 0.2.0.0
raw patch · 2 files changed
+48/−15 lines, 2 filesdep +resourcetdep +transformers
Dependencies added: resourcet, transformers
Files
Main.hs view
@@ -1,31 +1,39 @@ module Main where import Control.Applicative ( liftA2 ) -- base import Control.Monad ( when ) -- base+import Control.Monad.IO.Class ( liftIO ) -- transformers+import Control.Monad.Trans.Resource ( withInternalState, runResourceT ) -- resourcet 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.Foldable ( forM_ ) -- base 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.Directory ( getDirectoryContents, doesDirectoryExist, getModificationTime, copyFile ) -- 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 Network.HTTP.Types.Method ( methodPost ) -- http-types+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 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+import Network.Wai.Middleware.Static ( staticPolicy, addBase, isNotAbsolute, noDots, Policy, tryPolicy ) -- wai-middleware-static+import Network.Wai.Parse ( tempFileBackEnd, parseRequestBody, fileName, fileContent ) -- wai-extra -- Maybe future things: virtual hosts, caching, PUT/POST/DELETE support, dropping permissions, client certificates -- Not future things: CGI etc of any sort +vERSION :: String+vERSION = "0.2.0.0"+ data Options = Options { optPort :: Int, @@ -47,7 +55,8 @@ optHTTPS :: Bool, optCertificate :: FilePath, optKeyFile :: FilePath,- optAllowHTTP :: Bool }+ optAllowHTTP :: Bool,+ optAllowUploads :: Bool } defOptions :: Options defOptions = Options {@@ -63,13 +72,14 @@ optHTTPS = False, optCertificate = "", optKeyFile = "",- optAllowHTTP = False } -- TODO: AllowHTTP doesn't work. A bug in warp-tls?+ optAllowHTTP = False, -- TODO: AllowHTTP doesn't work. A bug in warp-tls?+ optAllowUploads = False } 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 })) + Option "h?" ["help", "version"] (NoArg (\opt -> opt { optHelp = True })) "Print usage.", Option "V" ["verbose"] (NoArg (\opt -> opt { optVerbose = True })) "Print diagnostic output.",@@ -96,7 +106,9 @@ 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)"+ "Disallow HTTP access when HTTPS is enabled. (Default)",+ Option "w" ["allow-uploads", "writable"] (NoArg (\opt -> opt { optAllowUploads = True }))+ "Allow files to be uploaded." ] validateOptions :: Options -> Maybe String@@ -107,7 +119,7 @@ | otherwise = Nothing usageHeader :: String-usageHeader = "Usage: sws [OPTIONS...] [DIRECTORY]"+usageHeader = "Usage: sws [OPTIONS...] [DIRECTORY]\nVersion: " ++ vERSION basePolicy :: Policy basePolicy = noDots <> isNotAbsolute@@ -116,6 +128,22 @@ enableIf True f = f enableIf _ _ = id +update :: Options -> Policy -> Middleware+update opts policy app req k = do+ when (requestMethod req == methodPost) $ do+ runResourceT $ do+ (_, fs) <- withInternalState (\s -> parseRequestBody (tempFileBackEnd s) req)+ let fs' = map (tryPolicy policy . CBS.unpack . BS.tail . ((rawPathInfo req <> fromString "/") <>) . fileName . snd) fs+ let prefix = CBS.unpack (BS.tail (rawPathInfo req))+ liftIO $ forM_ fs $ \(_, f) ->+ case tryPolicy policy (prefix </> CBS.unpack (fileName f)) of+ Nothing -> return ()+ Just tgt -> do+ let src = fileContent f+ when (optVerbose opts) $ putStrLn ("Saving " ++ src ++ " to " ++ tgt)+ copyFile src tgt+ app req k+ -- 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@@ -125,14 +153,15 @@ 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)+ where allowWrites = optAllowUploads opts+ fileDetails label f = liftA2 (renderFile label f) (doesDirectoryExist f) (getModificationTime f) renderFile label path isDirectory modTime = LBS.concat $ map fromString [ "<tr><td>", if isDirectory then "d" else "f", "</td><td><a href=\"/", path, "\">", label, "</a></td><td>", show modTime, "</td></tr>" ] container xs- = fromString "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\"><html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\"><head><title>sws</title><style type=\"text/css\">a, a:active {text-decoration: none; color: blue;}a:visited {color: #48468F;}a:hover, a:focus {text-decoration: underline; color: red;}body {background-color: #F5F5F5;}h2 {margin-bottom: 12px;}table {margin-left: 12px;}th, td { font: 90% monospace; text-align: left;}th { font-weight: bold; padding-right: 14px; padding-bottom: 3px;}td {padding-right: 14px;}td.s, th.s {text-align: right;}div.list { background-color: white; border-top: 1px solid #646464; border-bottom: 1px solid #646464; padding-top: 10px; padding-bottom: 14px;}div.foot { font: 90% monospace; color: #787878; padding-top: 4px;}</style></head><body><div class=\"list\"><table><tr><td></td><td>Name</td><td>Last Modified</td></tr>"- <> LBS.concat xs- <> fromString "</table></div><div class=\"foot\">sws 0.1.0.0</div></body></html>"+ = fromString ("<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\"><html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\"><head><meta charset=\"utf-8\"><title>sws</title><style type=\"text/css\">a, a:active {text-decoration: none; color: blue;}a:visited {color: #48468F;}a:hover, a:focus {text-decoration: underline; color: red;}body {background-color: #F5F5F5;}h2 {margin-bottom: 12px;}table {margin-left: 12px;}th, td { font: 90% monospace; text-align: left;}th { font-weight: bold; padding-right: 14px; padding-bottom: 3px;}td {padding-right: 14px;}td.s, th.s {text-align: right;}div.list { background-color: white; border-top: 1px solid #646464; border-bottom: 1px solid #646464; padding-top: 10px; padding-bottom: 14px;}div.foot { font: 90% monospace; color: #787878; padding-top: 4px;}form { display: " ++ (if allowWrites then "inherit" else "none") ++ ";}</style></head><body><div class=\"list\"><table><tr><td></td><td>Name</td><td>Last Modified</td></tr>")+ <> LBS.concat xs+ <> fromString ("</table></div><form enctype=\"multipart/form-data\" method=\"post\" action=\"\">File: <input type=\"file\" name=\"file\" required=\"required\" multiple=\"multiple\"><input type=\"submit\" value=\"Upload\"></form><div class=\"foot\">sws" ++ vERSION ++ "</div></body></html>") app404 :: Application app404 req k = k (responseLBS status404 [] (fromString "File Not Found"))@@ -151,13 +180,15 @@ (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 (optAllowUploads opts) (update opts policy)+ $ staticPolicy policy $ 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") } + policy = basePolicy <> addBase dir main :: IO () main = do
sws.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.1+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: A simple web server for serving directories, similar to weborf.@@ -66,10 +66,12 @@ -- Other library packages from which modules are imported. build-depends: base >=4.6 && <4.8, + bytestring(==0.10.*), directory(==1.2.*), filepath(==1.3.*), - bytestring(==0.10.*), http-types(==0.8.*), + resourcet(==1.1.*),+ transformers(==0.4.*), warp(==3.0.*), warp-tls(==3.0.*), wai(==3.0.*),