mohws 0.2.1.3 → 0.2.1.4
raw patch · 4 files changed
+61/−21 lines, 4 filesdep +network-uridep ~networkdep ~transformers
Dependencies added: network-uri
Dependency ranges changed: network, transformers
Files
- mohws.cabal +5/−4
- src/Network/MoHWS/Part/VirtualHost.hs +11/−8
- src/Network/MoHWS/Server.hs +1/−3
- src/Network/MoHWS/Utility.hs +44/−6
mohws.cabal view
@@ -1,5 +1,5 @@ Name: mohws-Version: 0.2.1.3+Version: 0.2.1.4 Author: Simon Marlow, Bjorn Bringert <bjorn@bringert.net> Copyright: Simon Marlow, Bjorn Bringert Maintainer: Henning Thielemann <webserver@henning-thielemann.de>@@ -28,7 +28,7 @@ Source-Repository this Type: darcs Location: http://code.haskell.org/mohws/- Tag: 0.2.1.3+ Tag: 0.2.1.4 Flag dynamic description: Build server with dynamically loaded plugins@@ -37,7 +37,8 @@ Library Build-depends: HTTP >=4000.0.4 && <4001,- network >=2.1 && <2.4,+ network >=2.6 && <2.7,+ network-uri >=2.6 && <2.7, unix >=2.3 && <2.7, parsec >=2.1 && <3.2, html >=1.0 && <1.1,@@ -48,7 +49,7 @@ bytestring >=0.9 && <0.11, filepath >=1.1 && <1.4, utility-ht >=0.0.3 && <0.1,- transformers >=0.2 && <0.4,+ transformers >=0.2 && <0.6, explicit-exception >=0.1 && <0.2, data-accessor >=0.2 && <0.3, directory >=1.0 && <1.3,
src/Network/MoHWS/Part/VirtualHost.hs view
@@ -6,6 +6,7 @@ import qualified Network.MoHWS.Module as Module import qualified Network.MoHWS.Module.Description as ModuleDesc import qualified Network.MoHWS.Server.Context as ServerContext+import qualified Network.MoHWS.Utility as Util import qualified System.FilePath as FilePath import qualified Network.MoHWS.Configuration as Config@@ -97,15 +98,17 @@ translatePath :: ServerContext.T Configuration -> String -> String -> MaybeT IO FilePath translatePath st host path = -- (\x -> print (host,path) >> print x >> return x) $- MaybeT $ return $ let conf = ServerContext.config st ext = Config.extension conf in mplus- (fmap (FilePath.combine (Config.documentRoot conf)) $+ (MaybeT $ return $+ fmap (FilePath.combine (Config.documentRoot conf)) $ Map.lookup path =<< Map.lookup host (virtualFile_ ext))- (case path of- '/':_ ->- fmap (++path) $--- fmap (flip FilePath.combine path) $ this omits the trailing slash when path=="/"- Map.lookup host (virtualDocumentRoot_ ext)- _ -> Nothing)+ {-+ If a path contains too many '..'+ then Util.localPath will refuse to translate the path.+ However, later stages will still try to translate.+ -}+ (do+ root <- MaybeT $ return $ Map.lookup host (virtualDocumentRoot_ ext)+ MaybeT $ Util.localPath root path)
src/Network/MoHWS/Server.hs view
@@ -481,9 +481,7 @@ ServerEnv.T body ext -> String -> EIO body FilePath defaultTranslatePath st pth = let conf = ServerEnv.config st- in case pth of- '/':_ -> return $ documentRoot conf ++ pth- _ -> Exc.throwT $ Response.makeNotFound conf+ in fmap (maybe "" id) $ lift (Util.localPath (documentRoot conf) pth) -- Request tweaking
src/Network/MoHWS/Utility.hs view
@@ -46,7 +46,11 @@ import Data.Ratio (numerator, ) import Foreign.C.Error (getErrno, eNOENT, eNOTDIR, ) import Network.Socket as Socket-import System.IO++import qualified System.FilePath as FilePath+import qualified System.IO as IO+import qualified System.Directory as Dir+import System.IO.Error (isDoesNotExistError, ) import System.Exit (exitFailure, ) import System.Locale (defaultTimeLocale, ) import System.Posix (EpochTime, FileStatus,@@ -62,11 +66,11 @@ deHex :: String -> String deHex s = s -hPutStrCrLf :: Handle -> String -> IO ()-hPutStrCrLf h s = hPutStr h s >> hPutChar h '\r' >> hPutChar h '\n'+hPutStrCrLf :: IO.Handle -> String -> IO ()+hPutStrCrLf h s = IO.hPutStr h s >> IO.hPutChar h '\r' >> IO.hPutChar h '\n' die :: String -> IO ()-die err = do hPutStrLn stderr err+die err = do IO.hPutStrLn IO.stderr err exitFailure -----------------------------------------------------------------------------@@ -156,10 +160,10 @@ -- networking utils accept :: Socket -- Listening Socket- -> IO (Handle,SockAddr) -- StdIO Handle for read/write+ -> IO (IO.Handle,SockAddr) -- StdIO IO.Handle for read/write accept sock = do (sock', addr) <- Socket.accept sock- hndle <- socketToHandle sock' ReadWriteMode+ hndle <- socketToHandle sock' IO.ReadWriteMode return (hndle,addr) -----------------------------------------------------------------------------@@ -185,6 +189,40 @@ isSymLink :: FilePath -> IO Bool isSymLink = liftM (maybe False isSymbolicLink) . runMaybeT . statSymLink++isPrefix :: FilePath -> FilePath -> Bool+isPrefix root absolute = FilePath.makeRelative root absolute /= absolute++{- |+It is important to maintain a trailing slash,+otherwise, say, the URL "http://domain.de/"+will be translated to "/srv/www/",+then canonicalized to "/srv/www"+and then we will no longer be able to resolve this to "/srv/www/index.html".+-}+canonicalizePath :: FilePath -> IO FilePath+canonicalizePath path = do+ absolute <- Dir.canonicalizePath path+ return $+ if FilePath.hasTrailingPathSeparator path &&+ not (FilePath.hasTrailingPathSeparator absolute)+ then FilePath.addTrailingPathSeparator absolute+ else absolute++{- |+This function should prevent fetching files+from outside the document directory using '..' in paths.+-}+localPath :: FilePath -> String -> IO (Maybe FilePath)+localPath root urlPath =+ case urlPath of+ '/' : _ ->+ catchSomeIOErrors isDoesNotExistError+ (do+ absolute <- canonicalizePath (root ++ urlPath)+ return $ toMaybe (isPrefix root absolute) absolute)+ (const $ return Nothing)+ _ -> return Nothing ----------------------------------------------------------------------------- -- Exception utils