happstack-server 7.0.0 → 7.0.1
raw patch · 6 files changed
+154/−66 lines, 6 filesdep +system-filepathdep ~mtldep ~transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: system-filepath
Dependency ranges changed: mtl, transformers
API changes (from Hackage documentation)
+ Happstack.Server.FileServe: serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m String) -> FilePath -> m Response
+ Happstack.Server.FileServe.BuildingBlocks: combineSafe :: FilePath -> FilePath -> Maybe FilePath
+ Happstack.Server.FileServe.BuildingBlocks: serveDirectory' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => Browsing -> [FilePath] -> (FilePath -> m String) -> FilePath -> m Response
+ Happstack.Server.FileServe.BuildingBlocks: serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m String) -> FilePath -> m Response
+ Happstack.Server.Monads: neverExpires :: FilterMonad Response m => m ()
Files
- happstack-server.cabal +16/−8
- src/Happstack/Server/FileServe.hs +1/−0
- src/Happstack/Server/FileServe/BuildingBlocks.hs +103/−51
- src/Happstack/Server/Internal/Socket.hs +18/−6
- src/Happstack/Server/Internal/SocketTH.hs +10/−1
- src/Happstack/Server/Monads.hs +6/−0
happstack-server.cabal view
@@ -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 <http://happstack.com/docs/crashcourse/index.html> 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)
src/Happstack/Server/FileServe.hs view
@@ -4,6 +4,7 @@ Browsing(..) , serveDirectory , serveFile+ , serveFileFrom -- * Content-Type \/ Mime-Type , MimeMap , mimeTypes
src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -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.
src/Happstack/Server/Internal/Socket.hs view
@@ -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
src/Happstack/Server/Internal/SocketTH.hs view
@@ -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
src/Happstack/Server/Monads.hs view
@@ -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.