diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.0.0 +Version: 7.0.1 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 @@ -27,8 +27,12 @@ Description: Build the testsuite, and include the tests in the library Default: False -Library +Flag template_haskell + Description: Template Haskell is available on this system + Default: True + Manual: True +Library Exposed-modules: Happstack.Server Happstack.Server.Auth @@ -62,9 +66,9 @@ Happstack.Server.Types Happstack.Server.Validation if flag(tests) - Exposed-modules: + Exposed-modules: Happstack.Server.Tests - Other-modules: + Other-modules: Happstack.Server.HTTPClient.HTTP Happstack.Server.HTTPClient.Stream Happstack.Server.HTTPClient.TCP @@ -77,8 +81,8 @@ Paths_happstack_server Build-Depends: base, - blaze-html >= 0.3 && < 0.5, base64-bytestring == 0.1.*, + blaze-html >= 0.3 && < 0.5, bytestring, containers, directory, @@ -87,16 +91,16 @@ hslogger >= 1.0.2, html, monad-control >= 0.3 && < 0.4, - mtl >= 2 && < 2.1, + mtl >= 2 && < 2.2, old-locale, old-time, parsec < 4, process, sendfile >= 0.7.1 && < 0.8, - template-haskell, + system-filepath >= 0.3.1, text >= 0.10 && < 0.12, time, - transformers >= 0.1.3 && < 0.3, + transformers >= 0.1.3 && < 0.4, transformers-base >= 0.4 && < 0.5, utf8-string >= 0.3.4 && < 0.4, xhtml, @@ -106,6 +110,10 @@ Build-Depends: network >= 2.2.3 else Build-Depends: network < 2.2.3, network-bytestring + + if (flag(template_haskell) && !(arch(arm))) + Build-Depends: template-haskell + cpp-options: -DTEMPLATE_HASKELL hs-source-dirs: src if flag(tests) diff --git a/src/Happstack/Server/FileServe.hs b/src/Happstack/Server/FileServe.hs --- a/src/Happstack/Server/FileServe.hs +++ b/src/Happstack/Server/FileServe.hs @@ -4,6 +4,7 @@ Browsing(..) , serveDirectory , serveFile + , serveFileFrom -- * Content-Type \/ Mime-Type , MimeMap , mimeTypes diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs --- a/src/Happstack/Server/FileServe/BuildingBlocks.hs +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -17,11 +17,13 @@ fileServeStrict, Browsing(..), serveDirectory, + serveDirectory', -- ** Serving a single file serveFile, + serveFileFrom, serveFileUsing, -- * Low-Level - sendFileResponse, + sendFileResponse, lazyByteStringResponse, strictByteStringResponse, filePathSendFile, @@ -41,6 +43,7 @@ -- * Other blockDotFiles, defaultIxFiles, + combineSafe, isSafePath, tryIndex, doIndex, @@ -61,6 +64,7 @@ import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map +import Filesystem.Path.CurrentOS (commonPrefix, encodeString, decodeString, collapse, append) import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther) import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader) @@ -78,7 +82,7 @@ -- * Mime-Type / Content-Type -- |a 'Map' from file extensions to content-types --- +-- -- example: -- -- > myMimeMap :: MimeMap @@ -106,19 +110,19 @@ guessContentTypeM :: (Monad m) => MimeMap -> (FilePath -> m String) guessContentTypeM mimeMap filePath = return $ fromMaybe "application/octet-stream" $ guessContentType mimeMap filePath --- | returns a specific content type, completely ignoring the 'FilePath' argument. +-- | returns a specific content type, completely ignoring the 'FilePath' argument. -- -- Use this with 'serveFile' if you want to explicitly specify the -- content-type. -- -- see also: 'guessContentTypeM', 'serveFile' -asContentType :: (Monad m) => +asContentType :: (Monad m) => String -- ^ the content-type to return -> (FilePath -> m String) asContentType = const . return -- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@ --- +-- -- Typically used as an argument to 'serveDiretory'. defaultIxFiles :: [FilePath] defaultIxFiles= ["index.html","index.xml","index.gif"] @@ -158,7 +162,7 @@ -> Integer -- ^ number of bytes to send -> Response sendFileResponse ct filePath mModTime offset count = - let res = ((setHeader "Content-Type" ct) $ + let res = ((setHeader "Content-Type" ct) $ (SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count) ) in case mModTime of @@ -250,27 +254,27 @@ -- ** Serve a single file -- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url. --- +-- -- example 1: --- +-- -- Serve using sendfile() and the specified content-type -- -- > serveFileUsing filePathSendFile (asContentType "image/jpeg") "/srv/data/image.jpg" -- -- -- example 2: --- +-- -- Serve using a lazy ByteString and the guess the content-type from the extension --- +-- -- > serveFileUsing filePathLazy (guessContentTypeM mimeTypes) "/srv/data/image.jpg" --- +-- -- WARNING: No security checks are performed. -serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) +serveFileUsing :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (String -> FilePath -> m Response) -- ^ typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict' -> (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' -> FilePath -- ^ path to the file to serve -> m Response -serveFileUsing serveFn mimeFn fp = +serveFileUsing serveFn mimeFn fp = do fe <- liftIO $ doesFileExist fp if fe then do mt <- mimeFn fp @@ -278,35 +282,48 @@ else mzero -- | Serve a single, specified file. The name of the file being served is specified explicity. It is not derived automatically from the 'Request' url. --- +-- -- example 1: --- +-- -- Serve as a specific content-type: -- -- > serveFile (asContentType "image/jpeg") "/srv/data/image.jpg" -- -- -- example 2: --- +-- -- Serve guessing the content-type from the extension: --- +-- -- > serveFile (guessContentTypeM mimeTypes) "/srv/data/image.jpg" -- -- If the specified path does not exist or is not a file, this function will return 'mzero'. --- +-- -- WARNING: No security checks are performed. -- -- NOTE: alias for 'serveFileUsing' 'filePathSendFile' -serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => +serveFile :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' -> FilePath -- ^ path to the file to serve -> m Response serveFile = serveFileUsing filePathSendFile +-- | Like 'serveFile', but uses 'combineSafe' to prevent directory +-- traversal attacks when the path to the file is supplied by the user. +serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + FilePath -- ^ directory wherein served files must be contained + -> (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'asContentType' or 'guessContentTypeM' + -> FilePath -- ^ path to the file to serve + -> m Response +serveFileFrom root mimeFn fp = + maybe no yes $ combineSafe root fp + where + no = forbidden $ toResponse "Directory traversal forbidden" + yes = serveFile mimeFn + -- ** Serve files from a directory -- | Serve files from a directory and its subdirectories (parameterizable version) --- +-- -- Parameterize this function to create functions like, 'fileServe', 'fileServeLazy', and 'fileServeStrict' -- -- You supply: @@ -323,7 +340,7 @@ , FilterMonad Response m , MonadIO m , MonadPlus m - ) + ) => (String -> FilePath -> m Response) -- ^ function which takes a content-type and filepath and generates a response (typically 'filePathSendFile', 'filePathLazy', or 'filePathStrict') -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath -- -> [FilePath] -- ^ index file names, in case the requested path is a directory @@ -347,15 +364,36 @@ then indexFn fp else do let path' = addTrailingPathSeparator (rqUri rq) seeOther path' (toResponse path') - else if fe + else if fe then serveFileUsing serveFn mimeFn fp else mzero +-- | Combine two 'FilePath's, ensuring that the resulting path leads to +-- a file within the first 'FilePath'. +-- +-- >>> combineSafe "/var/uploads/" "etc/passwd" +-- Just "/var/uploads/etc/passwd" +-- >>> combineSafe "/var/uploads/" "/etc/passwd" +-- Nothing +-- >>> combineSafe "/var/uploads/" "../../etc/passwd" +-- Nothing +-- >>> combineSafe "/var/uploads/" "../uploads/home/../etc/passwd" +-- Just "/var/uploads/etc/passwd" +combineSafe :: FilePath -> FilePath -> Maybe FilePath +combineSafe root path = + if commonPrefix [root', joined] == root' + then Just $ encodeString joined + else Nothing + where + root' = decodeString root + path' = decodeString path + joined = collapse $ append root' path' + isSafePath :: [FilePath] -> Bool isSafePath [] = True isSafePath (s:ss) = - isValid s - && (all (not . isPathSeparator) s) + isValid s + && (all (not . isPathSeparator) s) && not (hasDrive s) && not (isParent s) && isSafePath ss @@ -366,7 +404,7 @@ isParent _ = False -- | Serve files from a directory and its subdirectories using 'sendFile'. --- +-- -- Usage: -- -- > fileServe ["index.html"] "path/to/files/on/disk" @@ -376,19 +414,19 @@ -- DEPRECATED: use 'serveDirectory' instead. -- -- Note: --- +-- -- The list of index files @[\"index.html\"]@ is only used to determine what file to show if the user requests a directory. You *do not* need to explicitly list all the files you want to serve. --- +-- fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [FilePath] -- ^ index file names, in case the requested path is a directory -> FilePath -- ^ file/directory to serve -> m Response -fileServe ixFiles localPath = +fileServe ixFiles localPath = fileServe' serveFn mimeFn indexFn localPath where serveFn = filePathSendFile mimeFn = guessContentTypeM mimeTypes - indexFiles = (ixFiles ++ defaultIxFiles) + indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles -- indexFn = browseIndex filePathSendFile mimeFn indexFiles {-# DEPRECATED fileServe "use serveDirectory instead." #-} @@ -405,10 +443,10 @@ where serveFn = filePathLazy mimeFn = guessContentTypeM mimeTypes - indexFiles = (ixFiles ++ defaultIxFiles) + indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles --- | Serve files from a directory and its subdirectories (strict ByteString version). +-- | Serve files from a directory and its subdirectories (strict ByteString version). -- -- WARNING: the entire file will be read into RAM before being served. You should probably use 'fileServe' instead. fileServeStrict :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => @@ -420,12 +458,12 @@ where serveFn = filePathStrict mimeFn = guessContentTypeM mimeTypes - indexFiles = (ixFiles ++ defaultIxFiles) + indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles -- * Index --- | attempt to serve index files +-- | attempt to serve index files doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [FilePath] -- ^ list of possible index files (e.g., @index.html@) -> MimeMap -- ^ see also 'mimeTypes' @@ -469,8 +507,8 @@ tryIndex serveFn mimeFn (index:rest) fp = do let path = fp index fe <- liftIO $ doesFileExist path - if fe - then serveFileUsing serveFn mimeFn path + if fe + then serveFileUsing serveFn mimeFn path else tryIndex serveFn mimeFn rest fp -- * Directory Browsing @@ -495,15 +533,15 @@ renderDirectoryContents :: (MonadIO m) => FilePath -- ^ path to directory on disk -> [FilePath] -- ^ list of entries in that path - -> m H.Html + -> m H.Html renderDirectoryContents localPath fps = do fps' <- liftIO $ mapM (getMetaData localPath) fps - return $ H.html $ do + return $ H.html $ do H.head $ do H.title $ H.toHtml "Directory Listing" H.meta ! A.httpEquiv (H.toValue "Content-Type") ! A.content (H.toValue "text/html;charset=utf-8") H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }" - , "table, th, td { border: 1px solid #353948; }" + , "table, th, td { border: 1px solid #353948; }" , "td.size { text-align: right; font-size: 0.7em; width: 50px }" , "td.date { text-align: right; font-size: 0.7em; width: 130px }" , "td { padding-right: 1em; padding-left: 1em; }" @@ -538,13 +576,13 @@ H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True]) where mkRow :: ((FilePath, Maybe CalendarTime, Maybe Integer, EntryKind), Bool) -> H.Html - mkRow ((fp, modTime, count, kind), alt) = + mkRow ((fp, modTime, count, kind), alt) = (if alt then (! A.class_ (H.toValue "alt")) else id) $ H.tr $ do H.td (mkKind kind) H.td (H.a ! A.href (H.toValue fp) $ H.toHtml fp) H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime) - (maybe id (\c -> (! A.title (H.toValue (show c)))) count) (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count)) + (maybe id (\c -> (! A.title (H.toValue (show c)))) count) (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count)) mkKind :: EntryKind -> H.Html mkKind File = return () mkKind Directory = H.toHtml "➦" @@ -570,29 +608,29 @@ -> IO (FilePath, Maybe CalendarTime, Maybe Integer, EntryKind) getMetaData localPath fp = do let localFp = localPath fp - modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` + modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` (\(_ :: IOException) -> return Nothing) count <- do de <- doesDirectoryExist localFp if de then do return Nothing - else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) + else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) `catch` (\(_e :: IOException) -> return Nothing) kind <- do fe <- doesFileExist localFp if fe then return File else do de <- doesDirectoryExist localFp - if de + if de then return Directory else return UnknownKind return (fp, modTime, count, kind) -- | see 'serveDirectory' -data Browsing - = EnableBrowsing | DisableBrowsing +data Browsing + = EnableBrowsing | DisableBrowsing deriving (Eq, Enum, Ord, Read, Show, Data, Typeable) -- | Serve files and directories from a directory and its subdirectories using 'sendFile'. --- +-- -- Usage: -- -- > serveDirectory EnableBrowsing ["index.html"] "path/to/files/on/disk" @@ -600,7 +638,7 @@ -- If the requested path does not match a file or directory on the -- disk, then 'serveDirectory' calls 'mzero'. -- --- If the requested path is a file then the file is served normally. +-- If the requested path is a file then the file is served normally. -- -- If the requested path is a directory, then the result depends on -- what the first two arguments to the function are. @@ -615,7 +653,7 @@ -- find one of the index files (in the order they are listed). If that -- fails, it will show a directory listing if 'EnableBrowsing' is set, -- otherwise it will return @forbidden \"Directory index forbidden\"@. --- +-- -- Here is an explicit list of all the possible outcomes when the -- argument is a (valid) directory: -- @@ -629,7 +667,7 @@ -- -- 2. Otherwise returns, forbidden \"Directory index forbidden\" -- --- [@'EnableBrowsing', empty index file list@] +-- [@'EnableBrowsing', empty index file list@] -- -- Always shows a directory index. -- @@ -645,17 +683,31 @@ -> [FilePath] -- ^ index file names, in case the requested path is a directory -> FilePath -- ^ file/directory to serve -> m Response -serveDirectory browsing ixFiles localPath = +serveDirectory browsing ixFiles localPath = + serveDirectory' browsing ixFiles mimeFn localPath + where + mimeFn = guessContentTypeM mimeTypes + + +-- | like 'serveDirectory' but with custom mimeTypes +serveDirectory' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => Browsing -- ^ allow directory browsing + -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath + -> FilePath -- ^ file/directory to serve + -> m Response +serveDirectory' browsing ixFiles mimeFn localPath = fileServe' serveFn mimeFn indexFn localPath where serveFn = filePathSendFile - mimeFn = guessContentTypeM mimeTypes indexFn fp = msum [ tryIndex filePathSendFile mimeFn ixFiles fp , if browsing == EnableBrowsing then browseIndex renderDirectoryContents filePathSendFile mimeFn ixFiles fp else forbidden $ toResponse "Directory index forbidden" ] + + -- | Ready collection of common mime types. -- Except for the first two entries, the mappings come from an Ubuntu 8.04 \/etc\/mime.types file. diff --git a/src/Happstack/Server/Internal/Socket.hs b/src/Happstack/Server/Internal/Socket.hs --- a/src/Happstack/Server/Internal/Socket.hs +++ b/src/Happstack/Server/Internal/Socket.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE CPP #-} +#ifdef TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} +#endif module Happstack.Server.Internal.Socket ( acceptLite , sockAddrToHostName @@ -6,8 +9,11 @@ import Data.List (intersperse) import Data.Word (Word32) +#ifdef TEMPLATE_HASKELL import Happstack.Server.Internal.SocketTH(supportsIPv6) import Language.Haskell.TH.Syntax +#endif + import qualified Network as N ( PortID(PortNumber) , socketPort @@ -56,18 +62,19 @@ sockAddrToHostName :: S.SockAddr -> S.HostName sockAddrToHostName addr = +#ifdef TEMPLATE_HASKELL $(if supportsIPv6 then - return $ CaseE (VarE (mkName "addr")) - [Match - (ConP (mkName "S.SockAddrInet") - [WildP,VarP (mkName "ha")]) - (NormalB (AppE (VarE (mkName "showHostAddress")) + return $ CaseE (VarE (mkName "addr")) + [Match + (ConP (mkName "S.SockAddrInet") + [WildP,VarP (mkName "ha")]) + (NormalB (AppE (VarE (mkName "showHostAddress")) (VarE (mkName "ha")))) [] ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP]) (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) [] ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []] - -- the above mess is the equivalent of this: + -- the above mess is the equivalent of this: {-[| case addr of (S.SockAddrInet _ ha) -> showHostAddress ha (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha @@ -78,3 +85,8 @@ (S.SockAddrInet _ ha) -> showHostAddress ha _ -> error "Unsupported socket" |]) +#else + case addr of + (S.SockAddrInet _ ha) -> showHostAddress ha + _ -> error "Unsupported socket" +#endif diff --git a/src/Happstack/Server/Internal/SocketTH.hs b/src/Happstack/Server/Internal/SocketTH.hs --- a/src/Happstack/Server/Internal/SocketTH.hs +++ b/src/Happstack/Server/Internal/SocketTH.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE CPP #-} +#ifdef TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} +#endif module Happstack.Server.Internal.SocketTH(supportsIPv6) where + +#ifdef TEMPLATE_HASKELL import Language.Haskell.TH +#endif import Network.Socket(SockAddr(..)) -- find out at compile time if the SockAddr6 / HostAddress6 constructors are available supportsIPv6 :: Bool +#ifdef TEMPLATE_HASKELL supportsIPv6 = $(let c = ["Network.Socket.SockAddrInet6", "Network.Socket.Internal.SockAddrInet6"] ; d = ''SockAddr isInet6 :: Con -> Bool isInet6 (NormalC n _) = show n `elem` c @@ -19,4 +26,6 @@ else [| False |] _ -> error "supportsIPv6: SockAddr is no longer a TyConI ?!?! Giving up." ) - +#else +supportsIPv6 = False +#endif diff --git a/src/Happstack/Server/Monads.hs b/src/Happstack/Server/Monads.hs --- a/src/Happstack/Server/Monads.hs +++ b/src/Happstack/Server/Monads.hs @@ -27,6 +27,7 @@ , addHeaderM , getHeaderM , setHeaderM + , neverExpires -- * WebMonad , WebMonad(..) , escape @@ -76,6 +77,11 @@ -- than one header of the same name. setHeaderM :: (FilterMonad Response m) => String -> String -> m () setHeaderM a v = composeFilter $ \res -> setHeader a v res + +-- | Set a far-future Expires header. Useful for static resources. If the +-- browser has the resource cached, no extra request is spent. +neverExpires :: (FilterMonad Response m) => m () +neverExpires = setHeaderM "Expires" "Mon, 31 Dec 2035 12:00:00 GMT" -- | Run an 'IO' action and, if it returns 'Just', pass it to the -- second argument.