module Main where import Control.Applicative ( liftA2 ) -- base import Control.Exception ( catch ) -- base import Control.Monad ( when ) -- base import Control.Monad.IO.Class ( liftIO ) -- transformers import Control.Monad.Trans.Resource ( withInternalState, runResourceT, ResourceCleanupException ) -- 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.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.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.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.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 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.Parse ( tempFileBackEndOpts, parseRequestBody, fileName, fileContent ) -- wai-extra import Crypto.Random ( getSystemDRG, randomBytesGenerate, SystemDRG ) -- cryptonite -- 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 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.4.2.0" -- STUN code sendStun :: Options -> [Word8] -> Net.Socket -> IO () sendStun opts tId s = do -- TODO: Perhaps add check that length tId == 12 [stunAddr] <- fmap (take 1 . hostAddresses) (getHostByName (optStunHost opts)) -- TODO: maybe have an option to list all addresses Net.sendTo s bytes (Net.SockAddrInet (optStunPort opts) stunAddr) >> return () where bytes = BS.pack ([0x00, 0x01, 0x00, 0x00, -- Type Binding, Size 0 0x21, 0x12, 0xA4, 0x42] -- Magic Cookie ++ tId) -- Transaction ID (should be cryptographically random and unique) recvStun :: [Word8] -> Net.Socket -> IO [Word8] recvStun tId s = do -- Assuming successful XOR-MAPPED-ADDRESS response. See RFC5389. TODO: Don't assume so much. (bytes, addr) <- Net.recvFrom s 576 -- TODO: Check for error, then, if successful, check for XOR-MAPPED-ADDRESS response type and appropriate length. let tId' = BS.unpack $ BS.take 12 $ BS.drop 8 bytes when (tId /= tId') $ ioError (userError "Mismatched Transaction ID in STUN response.") 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 :: Options -> [Word8] -> IO (Maybe [Word8]) -- TODO: add bracket doStun opts tId = do s <- Net.socket Net.AF_INET Net.Datagram Net.defaultProtocol v <- newEmptyMVar forkIO (recvStun tId s >>= putMVar v) sendStun opts tId 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 -> SystemDRG -> (Warp.TLSSettings, SystemDRG) 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') = randomBytesGenerate 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 -> (String -> String -> IO ()) -> Middleware update opts policy copyFileFn app req k = do if requestMethod req == methodPost then (do runResourceT $ do let prefix = if optUploadOnly opts then "" else CBS.unpack (BS.tail (rawPathInfo req)) case tryPolicy policy prefix of Nothing -> liftIO $ ioError $ userError "Forbidden" -- TODO: k (responseLBS status403 [] (LBS.fromChunks [CBS.pack "Forbidden"])) Just tgtDir -> do liftIO $ when (optVerbose opts) $ putStrLn (CBS.unpack (BS.tail (rawPathInfo req))) (_, fs) <- withInternalState (\s -> parseRequestBody (tempFileBackEndOpts (return tgtDir) ".sws.tmp" s) req) -- If UploadOnly then ignore the path part of the URL, i.e. only write the file to the base directory. 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) copyFileFn src tgt app req k) -- We execute the next Application regardless so that we return a listing after the POST completes. `catch` (\e -> const (app req k) (e :: ResourceCleanupException)) -- HACK: tempFileBackEndOpts attempts to remove the temp file but we've already removed it. `catchIOError` \e -> if isUserError e then k (responseLBS status409 [] (LBS.fromChunks [CBS.pack $ ioeGetErrorString e])) else ioError e else app req k overwriteFile :: String -> String -> IO () overwriteFile = renameFile -- copyFile errorOnOverwriteFile :: String -> String -> IO () errorOnOverwriteFile src tgt = do -- TODO: This has a race condition. exists <- doesFileExist tgt if exists then do ioError $ userError "Attempting to overwrite an existing file." else do renameFile src tgt renameOnOverwriteFile :: String -> String -> IO () renameOnOverwriteFile src tgt = do (tgt, h) <- openBinaryTempFileWithDefaultPermissions (takeDirectory tgt) (takeFileName tgt) hClose h renameFile src tgt -- 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) `catchIOError` \_ -> return (fromString "") renderFile label path isDirectory modTime = LBS.concat $ map fromString [ "
Name | Last Modified |