sws 0.2.0.0 → 0.3.0.0
raw patch · 4 files changed
+355/−84 lines, 4 filesdep +asn1-encodingdep +asn1-typesdep +crypto-pubkeydep ~wai-extra
Dependencies added: asn1-encoding, asn1-types, crypto-pubkey, crypto-random, hourglass, network, pem, x509
Dependency ranges changed: wai-extra
Files
- CHANGELOG.md +27/−0
- Main.hs +277/−77
- README.md +35/−0
- sws.cabal +16/−7
+ CHANGELOG.md view
@@ -0,0 +1,27 @@+# Change Log+All notable changes to this project will be documented in this file.++## 0.3.0.0 - Unreleased+### Added+- CHANGELOG.md and README.md+- Support for generating throw-away TLS certificates.+- Support for generating password for Basic Authentication.+- Support for adding custom headers to all responses.+- Support getting public IP via Google STUN server.++### Changed+- Change defaults to use HTTPS and Basic Authentication.+- Change display of connection information to a copyable address.+- Requires a currently non-existent version of x509 to generate valid certificates. (Pull request outstanding.)++### Removed+- \-\-allow\-http is removed. It did not appear to work anyway.++## 0.2.0.0 - 2014-12-06+### Added+- Support for uploading files. This includes overwriting existing files.++## 0.1.0.0 - 2014-11-11+### Added+- This is intended to be fully usable for it's intended purpose, namely statically serving+a directory tree.
Main.hs view
@@ -6,21 +6,24 @@ 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.Bits ( (.&.), unsafeShiftR, xor ) -- base import Data.Foldable ( forM_ ) -- base+import Data.Int ( Int64 ) -- base+import Data.Word ( Word8 ) -- 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, copyFile ) -- directory import System.Environment ( getArgs ) -- base import System.FilePath ( (</>) ) -- filepath-import System.IO ( putStrLn ) -- base+import System.IO ( putStrLn, hPutStrLn, hPutStr, stderr ) -- base import Network.HTTP.Types.Status ( status200, status403, status404 ) -- http-types 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.AddHeaders ( addHeaders ) -- wai-extra 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@@ -28,17 +31,177 @@ 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+-- For certificate generation.+import Crypto.PubKey.RSA ( generate ) -- crypto-pubkey+import Crypto.PubKey.RSA.PKCS15 ( sign ) -- crypto-pubkey+import Crypto.PubKey.HashDescr ( hashDescrSHA256 ) -- crypto-pubkey+import Crypto.Random ( EntropyPool, createEntropyPool, cprgCreate, cprgGenerate, SystemRNG ) -- crypto-random+import Data.ASN1.OID ( getObjectID ) -- asn1-types+import Data.ASN1.Types ( toASN1, {- for work-around -} ASN1Object ) -- asn1-types+import Data.ASN1.BinaryEncoding ( DER(DER) ) -- asn1-encoding+import Data.ASN1.Encoding ( encodeASN1' ) -- asn1-encoding+import qualified Data.PEM as PEM -- pem+import qualified Data.X509 as X509 -- x509+import qualified Data.Hourglass as HG -- hourglass+import qualified System.Hourglass as HG -- hourglass+-- for work-around+import Data.ASN1.Types ( ASN1(..), ASN1ConstructionType(..), ASN1TimeType(..) )+import Data.ASN1.Types.Lowlevel ( ASN1Class(..) ) +-- For STUN+import Control.Concurrent ( forkIO, threadDelay ) -- base+import Control.Concurrent.MVar ( newEmptyMVar, putMVar, tryTakeMVar ) -- base+import qualified Network.Socket as Net hiding ( sendTo, recvFrom ) -- network+import qualified Network.Socket.ByteString as Net ( sendTo, recvFrom ) -- network+import Network.BSD ( hostAddresses, getHostName, getHostByName ) -- network++-- Future things: case insensitive matching, optionally add CORS headers+-- Maybe future things: virtual hosts, caching, DELETE support, dropping permissions, client certificates+-- Not future things: CGI etc of any sort, "extensibility"+-- vERSION :: String-vERSION = "0.2.0.0"+vERSION = "0.3.0.0" +-- STUN code++stunAddr :: Net.HostAddress+stunAddr = 0x7F4CC2AD --0xADC24C7F -- stun.l.google.com:19302 (173.194.76.127)++stunPort :: Net.PortNumber+stunPort = 19302 -- Usually 3478++sendStun :: Net.Socket -> IO ()+sendStun s = Net.sendTo s bytes (Net.SockAddrInet stunPort stunAddr) >> return ()+ where bytes = BS.pack [0x00, 0x01, 0x00, 0x00, -- Type Binding, Size 0+ 0x21, 0x12, 0xA4, 0x42, -- Magic Cookie+ 0x00, 0x00, 0x00, 0x00, -- Transaction ID (should be cryptographically random+ 0x00, 0x00, 0x00, 0x00, -- and unique, but who cares?)+ 0x00, 0x00, 0x00, 0x00]+ +recvStun :: Net.Socket -> IO [Word8]+recvStun s = do -- Assuming successful XOR-MAPPED-ADDRESS response. See RFC5389. TODO: Don't assume so much.+ (bytes, addr) <- Net.recvFrom s 576+ let [b0, b1, b2, b3] = BS.unpack $ BS.drop 28 bytes+ return [b0 `xor` 0x21, b1 `xor` 0x12, b2 `xor` 0xA4, b3 `xor` 0x42]+ +doStun :: IO (Maybe [Word8]) -- TODO: add bracket+doStun = do+ s <- Net.socket Net.AF_INET Net.Datagram Net.defaultProtocol+ v <- newEmptyMVar+ forkIO (recvStun s >>= putMVar v)+ sendStun s+ threadDelay 1000000 -- wait a second+ Net.close s+ tryTakeMVar v+ +-- Certificate generation code++rsaPublicExponent :: Integer+rsaPublicExponent = 65537++rsaSizeInBytes :: Int+rsaSizeInBytes = 256 -- Corresponds to 2048 bit encryption++certExpiryInDays :: Int64+certExpiryInDays = 30++-- Temporary work-around for bug in x509.+newtype CertificateWorkaround = CW X509.Certificate+ deriving ( Eq, Show )++encodeCertificateHeader :: X509.Certificate -> [ASN1]+encodeCertificateHeader cert =+ eVer ++ eSerial ++ eAlgId ++ eIssuer ++ eValidity ++ eSubject ++ epkinfo ++ eexts+ where eVer = asn1Container (Container Context 0) [IntVal (fromIntegral $ X509.certVersion cert)]+ eSerial = [IntVal $ X509.certSerial cert]+ eAlgId = toASN1 (X509.certSignatureAlg cert) []+ eIssuer = toASN1 (X509.certIssuerDN cert) []+ (t1, t2) = X509.certValidity cert+ eValidity = asn1Container Sequence [ASN1Time TimeGeneralized t1 (Just (HG.TimezoneOffset 0))+ ,ASN1Time TimeGeneralized t2 (Just (HG.TimezoneOffset 0))]+ eSubject = toASN1 (X509.certSubjectDN cert) []+ epkinfo = toASN1 (X509.certPubKey cert) []+ eexts = toASN1 (X509.certExtensions cert) []+ asn1Container ty l = [Start ty] ++ l ++ [End ty]++instance ASN1Object CertificateWorkaround where+ toASN1 (CW cert) = (encodeCertificateHeader cert ++)+-- End work-around code++generateCert :: Options -> HG.DateTime -> SystemRNG -> (Warp.TLSSettings, SystemRNG)+generateCert opts now g = ((Warp.tlsSettingsMemory (PEM.pemWriteBS pemCert) (PEM.pemWriteBS pemKey)) {+ Warp.onInsecure = Warp.DenyInsecure (fromString "Use HTTPS") }, g'')+ where later = HG.timeAdd now (HG.Hours (24*certExpiryInDays))+ (bs, g') = cprgGenerate 8 g -- generate 8 random bytes for the serial number+ ((pk, sk), g'') = generate g' rsaSizeInBytes rsaPublicExponent+ serialNum = BS.foldl' (\a w -> a*256 + fromIntegral w) 0 bs+ cn = getObjectID X509.DnCommonName+ o = getObjectID X509.DnOrganization+ dn = X509.DistinguishedName [(cn, fromString (optHost opts)), (o, fromString "sws generated")]+ sigAlg = X509.SignatureALG X509.HashSHA256 X509.PubKeyALG_RSA+ cert = X509.Certificate {+ X509.certVersion = 0, -- 0 means v1 ...+ X509.certSerial = serialNum,+ X509.certSignatureAlg = sigAlg,+ X509.certIssuerDN = dn,+ X509.certValidity = (HG.timeAdd now (HG.Hours (-24)), later), + X509.certSubjectDN = dn,+ X509.certPubKey = X509.PubKeyRSA pk,+ X509.certExtensions = X509.Extensions Nothing+ }+ signFunc xs = (either (error . show) id (sign Nothing hashDescrSHA256 sk xs), sigAlg, ())+ certBytes = X509.encodeSignedObject $ fst $ X509.objectToSignedExact signFunc (CW cert)+ keyBytes = encodeASN1' DER (toASN1 sk [])+ pemCert = PEM.PEM (fromString "CERTIFICATE") [] certBytes -- This is a mite silly. Wrap in PEM just to immediately unwrap...+ pemKey = PEM.PEM (fromString "RSA PRIVATE KEY") [] keyBytes++-- File upload++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 -- We execute the next Application regardless so that we return a listing after the POST completes.++-- Directory listing++-- 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 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><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>")++-- Option handling+ data Options = Options { optPort :: Int, optHelp :: Bool, optVerbose :: Bool,+ optQuiet :: Bool, optCompress :: Bool, @@ -46,16 +209,21 @@ optLocalOnly :: Bool, + optGetIP :: Bool,++ optHeaders :: [String], + -- Basic authentication options+ optAuthentication :: Bool, 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,+ optHost :: String, optCertificate :: FilePath, optKeyFile :: FilePath,- optAllowHTTP :: Bool, optAllowUploads :: Bool } defOptions :: Options@@ -63,60 +231,73 @@ optPort = 3000, optHelp = False, optVerbose = False, -- TODO: Set the logging settings for the various middlewares.+ optQuiet = False, optCompress = True, optDirectoryListings = True, optLocalOnly = False,+ optGetIP = True,+ optHeaders = [],+ optAuthentication = True, optRealm = "",- optUserName = BS.empty,+ optUserName = fromString "guest", optPassword = BS.empty,- optHTTPS = False,+ optHTTPS = True,+ optHost = "localhost", optCertificate = "", optKeyFile = "",- 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") + Option "p" ["port"] (ReqArg (\p opt -> opt { optPort = read p }) "NUM") ("Port to listen on. (Default: " ++ (show $ optPort defOptions) ++ ")"), Option "h?" ["help", "version"] (NoArg (\opt -> opt { optHelp = True })) "Print usage.", Option "V" ["verbose"] (NoArg (\opt -> opt { optVerbose = True })) "Print diagnostic output.",+ Option "q" ["quiet"] (NoArg (\opt -> opt { optQuiet = True })) + "Only output access log information.", Option "l" ["local"] (NoArg (\opt -> opt { optLocalOnly = True })) "Only accept connections from localhost.",+ Option "" ["no-stun"] (NoArg (\opt -> opt { optGetIP = False })) + "Don't attempt to get the public IP via STUN.",+ Option "d" ["dev-mode"] (NoArg (\opt -> opt { optGetIP = False, optLocalOnly = True, optAuthentication = False, optHTTPS = False })) + "Equivalent to --local --no-auth --no-https --no-stun.",+ Option "X" [] (ReqArg (\h opt -> opt { optHeaders = h : optHeaders opt }) "HEADER")+ "Add HEADER to all server responses.", 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 "" ["no-auth"] (NoArg (\opt -> opt { optAuthentication = False })) + "Don't require a password.",+ Option "r" ["realm"] (ReqArg (\r opt -> opt { optRealm = r }) "REALM") + "Set the authentication realm. (Default: \"\")",+ Option "" ["password"] (ReqArg (\pw opt -> opt { optPassword = fromString pw }) "PASSWORD") + "Require the given password. (Default: generated)",+ Option "u" ["username"] (ReqArg (\u opt -> opt { optUserName = fromString u }) "USERNAME") + ("Require the given username. (Default: " ++ show (optUserName defOptions) ++ ")"), Option "s" ["secure"] (NoArg (\opt -> opt { optHTTPS = True })) - "Enable HTTPS.", - Option "" ["certificate"] (OptArg (\f opt -> opt { optCertificate = fromMaybe "" f }) "FILE")- "The path to the server certificate. Required for HTTPS.",- Option "" ["key-file"] (OptArg (\f opt -> opt { optKeyFile = fromMaybe "" f }) "FILE")- "The path to the private key for the certificate. Required for 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)",+ "Enable HTTPS. (Default)", + Option "" ["no-https"] (NoArg (\opt -> opt { optHTTPS = False })) + "Disable HTTPS.", + Option "H" ["host"] (ReqArg (\host opt -> opt { optHost = host }) "HOST") + ("Host name to use for generated certificate. (Default: " ++ show (optHost defOptions) ++ ")"),+ Option "" ["certificate"] (ReqArg (\f opt -> opt { optCertificate = f }) "FILE")+ "The path to the server certificate.",+ Option "" ["key-file"] (ReqArg (\f opt -> opt { optKeyFile = f }) "FILE")+ "The path to the private key for the certificate.", Option "w" ["allow-uploads", "writable"] (NoArg (\opt -> opt { optAllowUploads = True })) "Allow files to be uploaded." ] +-- TODO: KeyFile w/o Certificate and vice-versa, KeyFile/Certificate without HTTPS,+-- --no-auth and any of user/password/realm, header lacks ": ",+-- and whatever others make sense. 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+validateOptions opts = Nothing usageHeader :: String usageHeader = "Usage: sws [OPTIONS...] [DIRECTORY]\nVersion: " ++ vERSION@@ -128,73 +309,92 @@ 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- 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 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><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")) +explodeHostAddress :: Net.HostAddress -> [Word8]+explodeHostAddress h = [fromIntegral h, + fromIntegral (h `unsafeShiftR` 8),+ fromIntegral (h `unsafeShiftR` 16),+ fromIntegral (h `unsafeShiftR` 24)]++prettyAddress :: Bool -> [Word8] -> Int -> String+prettyAddress isHTTPS [b0, b1, b2, b3] port+ = concat [if isHTTPS then "https://" else "http://", show b0, ".", show b1, ".", show b2, ".", show b3, ":", show port]++-- A "base 32" encode so we don't have differing case in the password.+base32Encode :: BS.ByteString -> BS.ByteString+base32Encode = let table = fromString "0123456789abcdefghijklmnopqrstuv"+ go i | i == 0 = Nothing+ | otherwise = Just (BS.index table (fromIntegral (i .&. 0x1F)), i `unsafeShiftR` 5)+ in \bs -> fst $ BS.unfoldrN 13 go $ BS.foldl' (\a w -> a*256 + fromIntegral w) (0 :: Integer) bs + serve :: Options -> String -> IO () serve (Options { optHelp = True }) _ = putStrLn $ usageInfo usageHeader options-serve opts dir =+serve opts dir = do+ now <- HG.dateCurrent+ g <- fmap cprgCreate createEntropyPool+ let (prePW, g') = cprgGenerate 8 g -- generate 8 random bytes for the password if needed+ pw = if not (BS.null (optPassword opts)) then optPassword opts else base32Encode prePW+ headers = map ((\(x,y) -> (x, BS.drop 2 y)) . BS.breakSubstring (fromString ": ") . fromString) (optHeaders opts) case validateOptions opts of- Just err -> putStrLn err+ Just err -> hPutStrLn stderr err Nothing -> do- putStrLn $ "Listening on port " ++ show (optPort opts)- runner+ when (not $ optQuiet opts) $ do+ putStr "Private Address: " + if optLocalOnly opts then do+ putStrLn (prettyAddress (optHTTPS opts) [127,0,0,1] (optPort opts))+ else do+ hn <- getHostName+ addrs <- fmap (take 1 . hostAddresses) (getHostByName hn) -- TODO: maybe have an option to list all addresses+ forM_ addrs $ \ip -> putStrLn (prettyAddress (optHTTPS opts) (explodeHostAddress ip) (optPort opts))++ when (optGetIP opts && not (optLocalOnly opts)) $ do+ mip <- doStun + case mip of+ Nothing -> hPutStrLn stderr "Finding public IP failed." + Just ip -> do + putStr "Public Address: " + putStrLn (prettyAddress (optHTTPS opts) ip (optPort opts))++ when (optAuthentication opts && not (BS.null (optUserName opts))) $+ putStrLn $ "Username is: " ++ CBS.unpack (optUserName opts)+ when (optAuthentication opts && BS.null (optPassword opts)) $ do+ putStrLn $ "Generated password is: " ++ CBS.unpack pw+ putStrLn "Use --no-auth if password protection is not desired."++ runner now g' $ 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) + $ enableIf (optAuthentication opts) + (basicAuth (\u p -> return $ optUserName opts == u && pw == p) (fromString $ optRealm opts)) $ enableIf (optCompress opts) (gzip def { gzipFiles = GzipCompress })+ $ enableIf (not (null headers)) (addHeaders headers) $ 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") } + where runner now g | optHTTPS opts && certProvided + = Warp.runTLS tlsFileSettings (Warp.setPort (optPort opts) Warp.defaultSettings)+ | optHTTPS opts = \app -> do+ when (not $ optQuiet opts) $ do+ putStrLn "Generating a self-signed certificate. Use --no-https to disable HTTPS."+ putStrLn "Users will get warnings and will be vulnerable to man-in-the-middle attacks."+ Warp.runTLS tlsMemSettings (Warp.setPort (optPort opts) Warp.defaultSettings) app+ | otherwise = Warp.run (optPort opts)+ where tlsFileSettings = (Warp.tlsSettings (optCertificate opts) (optKeyFile opts)) { + Warp.onInsecure = Warp.DenyInsecure (fromString "Use HTTPS") } + (tlsMemSettings, _) = generateCert opts now g+ certProvided = not (null (optCertificate opts)) && not (null (optKeyFile opts))+ policy = basePolicy <> addBase dir main :: IO ()-main = do+main = Net.withSocketsDo $ 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)+ (_,_,errs) -> hPutStrLn stderr (concat errs ++ usageInfo usageHeader options) where combine = foldr ($) defOptions
+ README.md view
@@ -0,0 +1,35 @@+Simple Web Server+=================++What it is+----------++`sws` is a self-contained web server that serves files which runs on Linux, Windows and (untested) Mac OS X. Once built, +the executable should have no dependencies, e.g., it does not require OpenSSL. Convenience and security are the+main goals. It has no config files, and only a few, if any, easily provided command line parameters should be necessary.+If convenience and security conflict, I'm willing to sacrifice a little convenience for security, but only a little.+Often such conflicts are largely resolvable. For example, requiring a password and using TLS improve security, but+making a password or a certificate are inconvenient, so `sws` can generate these.++### Use-case 1: xkcd scenario+ +You want to send a large file to someone. You browse to the directory containing it, type "`sws`", and give them+your public IP. They browse to it and download. Maybe they are the ones sending the file, but aren't "technical".+You browse to an empty directory, type "`sws -w`", and give them your public IP. They browse to it and upload.++In reality, you need to figure out what your public IP is and open a port in your firewall. `sws` will currently+use Google's STUN server to attempt to figure out your public IP.++### Use-case 2: Client-side code demo/development++You build an [unhosted](https://unhosted.org/) web application or you mock out AJAX responses. You can do some+simple testing by running "`sws -d`". (Admittedly, using a file URI will probably work pretty well too, though maybe+not so much for mocked POST requests...) You want to show a friend. Just make that "`sws`".++What it isn't+-------------++This is not an app server. It reads and writes files, and that's all it will ever do. There is no way to add+code to it. The Haskell ecosystem has plenty of good web frameworks. This is not one of them. It's an+application, not a framework. (Well... you *could* do something with named pipes and/or interesting file systems...+but you really shouldn't.)
sws.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.0+version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: A simple web server for serving directories, similar to weborf.@@ -42,13 +42,14 @@ 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 +-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files: + README.md CHANGELOG.md+ source-repository head type: git location: https://github.com/derekelkins/sws.git@@ -65,18 +66,26 @@ -- Other library packages from which modules are imported. build-depends: + asn1-types(==0.3.*),+ asn1-encoding(==0.9.*), base >=4.6 && <4.8, bytestring(==0.10.*), + crypto-pubkey(==0.2.*),+ crypto-random(==0.0.*), directory(==1.2.*), filepath(==1.3.*), http-types(==0.8.*), + hourglass(==0.2.*),+ network(==2.6.*),+ pem(==0.2.*), resourcet(==1.1.*), transformers(==0.4.*), warp(==3.0.*), warp-tls(==3.0.*), - wai(==3.0.*), + wai(==3.0.*), wai-middleware-static(==0.6.*), - wai-extra(==3.0.*)+ wai-extra >=3.0.3 && <3.1,+ x509(==1.5.*) -- Directories containing source files. -- hs-source-dirs: