diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 [ "", if isDirectory then "d" else "f", "", label, "", show modTime, "" ] container xs - = fromString "sws
" - <> LBS.concat xs - <> fromString "
NameLast Modified
sws 0.1.0.0
" + = fromString ("sws
") + <> LBS.concat xs + <> fromString ("
NameLast Modified
File:
sws" ++ vERSION ++ "
") 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 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.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.*),