{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} -- | Build your own file serving functions -- -- If the functions in "Happstack.Server.FileServe" do not quite do -- you want you can roll your own by reusing pieces from this module. -- -- You will likely want to start by copying the source for a function -- like, 'serveDirectory' and then modifying it to suit your needs. -- module Happstack.Server.FileServe.BuildingBlocks ( -- * High-Level -- ** Serving files from a directory fileServe, fileServe', fileServeLazy, fileServeStrict, Browsing(..), serveDirectory, serveDirectory', -- ** Serving a single file serveFile, serveFileFrom, serveFileUsing, -- * Low-Level sendFileResponse, lazyByteStringResponse, strictByteStringResponse, filePathSendFile, filePathLazy, filePathStrict, -- * Content-Type \/ Mime-Type MimeMap, mimeTypes, asContentType, guessContentType, guessContentTypeM, -- * Directory Browsing EntryKind(..), browseIndex, renderDirectoryContents, renderDirectoryContentsTable, -- * Other blockDotFiles, defaultIxFiles, combineSafe, isSafePath, tryIndex, doIndex, doIndex', doIndexLazy, doIndexStrict, fileNotFound, isDot ) where import Control.Applicative ((<$>)) import Control.Exception.Extensible (IOException, bracket, catch) import Control.Monad (MonadPlus(mzero), msum) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Data.Data (Data, Typeable) import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.Time (UTCTime, formatTime) import Data.Time.Compat (toUTCTime) 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) import Prelude hiding (catch) import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime) import System.FilePath ((), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid) import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile) import System.Locale (defaultTimeLocale) import System.Log.Logger (Priority(DEBUG), logM) import Text.Blaze.Html ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -- * Mime-Type / Content-Type -- |a 'Map' from file extensions to content-types -- -- example: -- -- > myMimeMap :: MimeMap -- > myMimeMap = Map.fromList [("gz","application/x-gzip"), ... ] -- -- see also: 'mimeTypes' type MimeMap = Map String String -- | try to guess the content-type of a file based on its extension -- -- see also: 'guessContentTypeM' guessContentType :: MimeMap -> FilePath -> Maybe String guessContentType mimeMap filepath = case getExt filepath of "" -> Nothing ext -> Map.lookup ext mimeMap -- | try to guess the content-type of a file based on its extension -- -- defaults to "application/octet-stream" if no match was found. -- -- Useful as an argument to 'serveFile' -- -- see also: 'guessContentType', 'serveFile' 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. -- -- Use this with 'serveFile' if you want to explicitly specify the -- content-type. -- -- see also: 'guessContentTypeM', 'serveFile' 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"] -- | return a simple "File not found 404 page." fileNotFound :: (Monad m, FilterMonad Response m) => FilePath -> m Response fileNotFound fp = return $ result 404 $ "File not found " ++ fp -- | Similar to 'takeExtension' but does not include the extension separator char getExt :: FilePath -> String getExt fp = drop 1 $ takeExtension fp -- | Prevents files of the form '.foo' or 'bar/.foo' from being served blockDotFiles :: (Request -> IO Response) -> Request -> IO Response blockDotFiles fn rq | isDot (joinPath (rqPaths rq)) = return $ result 403 "Dot files not allowed." | otherwise = fn rq -- | Returns True if the given String either starts with a . or is of the form -- "foo/.bar", e.g. the typical *nix convention for hidden files. isDot :: String -> Bool isDot = isD . reverse where isD ('.':'/':_) = True isD ['.'] = True --isD ('/':_) = False isD (_:cs) = isD cs isD [] = False -- * Low-level functions for generating a Response -- | Use sendFile to send the contents of a Handle sendFileResponse :: String -- ^ content-type string -> FilePath -- ^ file path for content to send -> Maybe (UTCTime, Request) -- ^ mod-time for the handle (MUST NOT be later than server's time of message origination), incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into Handle -> Integer -- ^ number of bytes to send -> Response sendFileResponse ct filePath mModTime offset count = let res = ((setHeader "Content-Type" ct) $ (SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count) ) in case mModTime of Nothing -> res (Just (modTime, request)) -> ifModifiedSince modTime request res -- | Send the contents of a Lazy ByteString -- lazyByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) -> L.ByteString -- ^ lazy bytestring content to send -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into the bytestring -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) -> Response lazyByteStringResponse ct body mModTime offset count = let res = ((setHeader "Content-Type" ct) $ resultBS 200 (L.take (fromInteger count) $ (L.drop (fromInteger offset)) body) ) in case mModTime of Nothing -> res (Just (modTime, request)) -> ifModifiedSince modTime request res -- | Send the contents of a Lazy ByteString strictByteStringResponse :: String -- ^ content-type string (e.g. @\"text/plain; charset=utf-8\"@) -> S.ByteString -- ^ lazy bytestring content to send -> Maybe (UTCTime, Request) -- ^ mod-time for the bytestring, incoming request (used to check for if-modified-since header) -> Integer -- ^ offset into the bytestring -> Integer -- ^ number of bytes to send (offset + count must be less than or equal to the length of the bytestring) -> Response strictByteStringResponse ct body mModTime offset count = let res = ((setHeader "Content-Type" ct) $ resultBS 200 (L.fromChunks [S.take (fromInteger count) $ S.drop (fromInteger offset) body]) ) in case mModTime of Nothing -> res (Just (modTime, request)) -> ifModifiedSince modTime request res -- | Send the specified file with the specified mime-type using sendFile() -- -- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. -- -- WARNING: No security checks are performed. filePathSendFile :: (ServerMonad m, MonadIO m) => String -- ^ content-type string -> FilePath -- ^ path to file on disk -> m Response filePathSendFile contentType fp = do count <- liftIO $ withBinaryFile fp ReadMode hFileSize -- garbage collection should close this modtime <- liftIO $ getModificationTime fp rq <- askRq return $ sendFileResponse contentType fp (Just (toUTCTime modtime, rq)) 0 count -- | Send the specified file with the specified mime-type using lazy ByteStrings -- -- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. -- -- WARNING: No security checks are performed. filePathLazy :: (ServerMonad m, MonadIO m) => String -- ^ content-type string -> FilePath -- ^ path to file on disk -> m Response filePathLazy contentType fp = do handle <- liftIO $ openBinaryFile fp ReadMode -- garbage collection should close this contents <- liftIO $ L.hGetContents handle modtime <- liftIO $ getModificationTime fp count <- liftIO $ hFileSize handle rq <- askRq return $ lazyByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count -- | Send the specified file with the specified mime-type using strict ByteStrings -- -- NOTE: assumes file exists and is readable by the server. See 'serveFileUsing'. -- -- WARNING: No security checks are performed. filePathStrict :: (ServerMonad m, MonadIO m) => String -- ^ content-type string -> FilePath -- ^ path to file on disk -> m Response filePathStrict contentType fp = do contents <- liftIO $ S.readFile fp modtime <- liftIO $ getModificationTime fp count <- liftIO $ withBinaryFile fp ReadMode hFileSize rq <- askRq return $ strictByteStringResponse contentType contents (Just (toUTCTime modtime, rq)) 0 count -- * High-level functions for serving files -- ** 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) => (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 = do fe <- liftIO $ doesFileExist fp if fe then do mt <- mimeFn fp serveFn mt fp 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) => (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: -- -- 1. a low-level function which takes a content-type and 'FilePath' and generates a Response -- -- 2. a function which determines the content-type from the 'FilePath' -- -- 3. a list of all the default index files -- -- NOTE: unlike fileServe, there are no index files by default. See 'defaultIxFiles'. fileServe' :: ( WebMonad Response m , ServerMonad m , 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 -> (FilePath -> m Response) -> FilePath -- ^ file/directory to serve -> m Response fileServe' serveFn mimeFn indexFn localPath = do rq <- askRq if (not $ isSafePath (rqPaths rq)) then do liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: unsafe filepath " ++ show (rqPaths rq)) mzero else do let fp = joinPath (localPath : rqPaths rq) fe <- liftIO $ doesFileExist fp de <- liftIO $ doesDirectoryExist fp let status | de = "DIR" | fe = "file" | True = "NOT FOUND" liftIO $ logM "Happstack.Server.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status) if de then if last (rqUri rq) == '/' then indexFn fp else do let path' = addTrailingPathSeparator (rqUri rq) seeOther path' (toResponse path') 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) && not (hasDrive s) && not (isParent s) && isSafePath ss -- note: could be different on other OSs isParent :: FilePath -> Bool isParent ".." = True isParent _ = False -- | Serve files from a directory and its subdirectories using 'sendFile'. -- -- Usage: -- -- > fileServe ["index.html"] "path/to/files/on/disk" -- -- 'fileServe' does not support directory browsing. See 'serveDirectory' -- -- 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' serveFn mimeFn indexFn localPath where serveFn = filePathSendFile mimeFn = guessContentTypeM mimeTypes indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles -- indexFn = browseIndex filePathSendFile mimeFn indexFiles {-# DEPRECATED fileServe "use serveDirectory instead." #-} -- | Serve files from a directory and its subdirectories (lazy ByteString version). -- -- WARNING: May leak file handles. You should probably use 'fileServe' instead. fileServeLazy :: (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 fileServeLazy ixFiles localPath = fileServe' serveFn mimeFn indexFn localPath where serveFn = filePathLazy mimeFn = guessContentTypeM mimeTypes indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles -- | 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) => [FilePath] -- ^ index file names, in case the next argument is a directory -> FilePath -- ^ file/directory to serve -> m Response fileServeStrict ixFiles localPath = fileServe' serveFn mimeFn indexFn localPath where serveFn = filePathStrict mimeFn = guessContentTypeM mimeTypes indexFiles = (ixFiles ++ defaultIxFiles) indexFn = doIndex' filePathSendFile mimeFn indexFiles -- * Index -- | 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' -> FilePath -- ^ directory on disk to search for index files -> m Response doIndex ixFiles mimeMap localPath = doIndex' filePathSendFile (guessContentTypeM mimeMap) ixFiles localPath doIndexLazy :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [String] -> MimeMap -> FilePath -> m Response doIndexLazy ixFiles mimeMap localPath = doIndex' filePathLazy (guessContentTypeM mimeMap) ixFiles localPath doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => [String] -> MimeMap -> FilePath -> m Response doIndexStrict ixFiles mimeMap localPath = doIndex' filePathStrict (guessContentTypeM mimeMap) ixFiles localPath doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (String -> FilePath -> m Response) -> (FilePath -> m String) -> [String] -> FilePath -> m Response doIndex' serveFn mimeFn ixFiles fp = msum [ tryIndex serveFn mimeFn ixFiles fp , forbidden $ toResponse "Directory index forbidden" ] -- | try to find an index file, calls mzero on failure tryIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => (String -> FilePath -> m Response) -- ^ usually 'filePathSendFile' -> (FilePath -> m String) -- ^ function to calculate mime type, usually 'guessContentTypeM' -> [String] -- ^ list of index files. See also 'defaultIxFiles' -> FilePath -- ^ directory to search in -> m Response tryIndex _serveFn _mime [] _fp = mzero tryIndex serveFn mimeFn (index:rest) fp = do let path = fp index fe <- liftIO $ doesFileExist path if fe then serveFileUsing serveFn mimeFn path else tryIndex serveFn mimeFn rest fp -- * Directory Browsing browseIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m, ToMessage b) => (FilePath -> [FilePath] -> m b) -> (String -> FilePath -> m Response) -> (FilePath -> m String) -> [String] -> FilePath -> m Response browseIndex renderFn _serveFn _mimeFn _ixFiles localPath = do c <- liftIO $ getDirectoryContents localPath listing <- renderFn localPath $ filter (/= ".") (sort c) ok $ toResponse $ listing data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum) -- | a function to generate an HTML page showing the contents of a directory on the disk -- -- see also: 'browseIndex', 'renderDirectoryContentsTable' renderDirectoryContents :: (MonadIO m) => FilePath -- ^ path to directory on disk -> [FilePath] -- ^ list of entries in that path -> m H.Html renderDirectoryContents localPath fps = do fps' <- liftIO $ mapM (getMetaData localPath) fps 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; }" , "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; }" , "th.first { background-color: white; width: 24px }" , "td.first { padding-right: 0; padding-left: 0; text-align: center }" , "tr { background-color: white; }" , "tr.alt { background-color: #A3B5BA}" , "th { background-color: #3C4569; color: white; font-size: 1em; }" , "h1 { width: 760px; margin: 1em auto; font-size: 1em }" , "img { width: 20px }" , "a { text-decoration: none }" ] H.body $ do H.h1 $ H.toHtml "Directory Listing" renderDirectoryContentsTable fps' -- | a function to generate an HTML table showing the contents of a directory on the disk -- -- This function generates most of the content of the -- 'renderDirectoryContents' page. If you want to style the page -- differently, or add google analytics code, etc, you can just create -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents' renderDirectoryContentsTable :: [(FilePath, Maybe UTCTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData' -> H.Html renderDirectoryContentsTable fps = H.table $ do H.thead $ do H.th $ H.toHtml "" H.th $ H.toHtml "Name" H.th $ H.toHtml "Last modified" H.th $ H.toHtml "Size" H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True]) where mkRow :: ((FilePath, Maybe UTCTime, Maybe Integer, EntryKind), Bool) -> H.Html 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 "-" (formatTime 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)) mkKind :: EntryKind -> H.Html mkKind File = return () mkKind Directory = H.toHtml "➦" mkKind UnknownKind = return () prettyShow x | x > 1024 = prettyShowK $ x `div` 1024 | otherwise = addCommas "B" x prettyShowK x | x > 1024 = prettyShowM $ x `div` 1024 | otherwise = addCommas "KB" x prettyShowM x | x > 1024 = prettyShowG $ x `div` 1024 | otherwise = addCommas "MB" x prettyShowG x = addCommas "GB" x addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e) addCommas' x = x -- | look up the meta data associated with a file getMetaData :: FilePath -- ^ path to directory on disk containing the entry -> FilePath -- ^ entry in that directory -> IO (FilePath, Maybe UTCTime, Maybe Integer, EntryKind) getMetaData localPath fp = do let localFp = localPath fp modTime <- (Just . toUTCTime <$> 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) `catch` (\(_e :: IOException) -> return Nothing) kind <- do fe <- doesFileExist localFp if fe then return File else do de <- doesDirectoryExist localFp if de then return Directory else return UnknownKind return (if kind == Directory then (fp ++ "/") else fp, modTime, count, kind) -- | see 'serveDirectory' 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" -- -- 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 directory, then the result depends on -- what the first two arguments to the function are. -- -- The first argument controls whether directory browsing is -- enabled. -- -- The second argument is a list of index files (such as -- index.html). -- -- When a directory is requested, 'serveDirectory' will first try to -- 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: -- -- [@'DisableBrowsing', empty index file list@] -- -- This will always return, forbidden \"Directory index forbidden\" -- -- [@'DisableBrowsing', non-empty index file list@] -- -- 1. If an index file is found it will be shown. -- -- 2. Otherwise returns, forbidden \"Directory index forbidden\" -- -- [@'EnableBrowsing', empty index file list@] -- -- Always shows a directory index. -- -- [@'EnableBrowsing', non-empty index file list@] -- -- 1. If an index file is found it will be shown -- -- 2. Otherwise shows a directory index -- -- see also: 'defaultIxFiles', 'serveFile' 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 -- ^ file/directory to serve -> m Response 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 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. mimeTypes :: MimeMap mimeTypes = Map.fromList [("gz","application/x-gzip"),("cabal","application/x-cabal"),("%","application/x-trash"),("323","text/h323"),("3gp","video/3gpp"),("7z","application/x-7z-compressed"),("abw","application/x-abiword"),("ai","application/postscript"),("aif","audio/x-aiff"),("aifc","audio/x-aiff"),("aiff","audio/x-aiff"),("alc","chemical/x-alchemy"),("art","image/x-jg"),("asc","text/plain"),("asf","video/x-ms-asf"),("asn","chemical/x-ncbi-asn1"),("aso","chemical/x-ncbi-asn1-binary"),("asx","video/x-ms-asf"),("atom","application/atom"),("atomcat","application/atomcat+xml"),("atomsrv","application/atomserv+xml"),("au","audio/basic"),("avi","video/x-msvideo"),("b","chemical/x-molconn-Z"),("bak","application/x-trash"),("bat","application/x-msdos-program"),("bcpio","application/x-bcpio"),("bib","text/x-bibtex"),("bin","application/octet-stream"),("bmp","image/x-ms-bmp"),("boo","text/x-boo"),("book","application/x-maker"),("bsd","chemical/x-crossfire"),("c","text/x-csrc"),("c++","text/x-c++src"),("c3d","chemical/x-chem3d"),("cab","application/x-cab"),("cac","chemical/x-cache"),("cache","chemical/x-cache"),("cap","application/cap"),("cascii","chemical/x-cactvs-binary"),("cat","application/vnd.ms-pki.seccat"),("cbin","chemical/x-cactvs-binary"),("cbr","application/x-cbr"),("cbz","application/x-cbz"),("cc","text/x-c++src"),("cdf","application/x-cdf"),("cdr","image/x-coreldraw"),("cdt","image/x-coreldrawtemplate"),("cdx","chemical/x-cdx"),("cdy","application/vnd.cinderella"),("cef","chemical/x-cxf"),("cer","chemical/x-cerius"),("chm","chemical/x-chemdraw"),("chrt","application/x-kchart"),("cif","chemical/x-cif"),("class","application/java-vm"),("cls","text/x-tex"),("cmdf","chemical/x-cmdf"),("cml","chemical/x-cml"),("cod","application/vnd.rim.cod"),("com","application/x-msdos-program"),("cpa","chemical/x-compass"),("cpio","application/x-cpio"),("cpp","text/x-c++src"),("cpt","application/mac-compactpro"),("crl","application/x-pkcs7-crl"),("crt","application/x-x509-ca-cert"),("csf","chemical/x-cache-csf"),("csh","application/x-csh"),("csm","chemical/x-csml"),("csml","chemical/x-csml"),("css","text/css"),("csv","text/csv"),("ctab","chemical/x-cactvs-binary"),("ctx","chemical/x-ctx"),("cu","application/cu-seeme"),("cub","chemical/x-gaussian-cube"),("cxf","chemical/x-cxf"),("cxx","text/x-c++src"),("d","text/x-dsrc"),("dat","chemical/x-mopac-input"),("dcr","application/x-director"),("deb","application/x-debian-package"),("dif","video/dv"),("diff","text/x-diff"),("dir","application/x-director"),("djv","image/vnd.djvu"),("djvu","image/vnd.djvu"),("dl","video/dl"),("dll","application/x-msdos-program"),("dmg","application/x-apple-diskimage"),("dms","application/x-dms"),("doc","application/msword"),("dot","application/msword"),("dv","video/dv"),("dvi","application/x-dvi"),("dx","chemical/x-jcamp-dx"),("dxr","application/x-director"),("emb","chemical/x-embl-dl-nucleotide"),("embl","chemical/x-embl-dl-nucleotide"),("eml","message/rfc822"),("ent","chemical/x-ncbi-asn1-ascii"),("eps","application/postscript"),("etx","text/x-setext"),("exe","application/x-msdos-program"),("ez","application/andrew-inset"),("fb","application/x-maker"),("fbdoc","application/x-maker"),("fch","chemical/x-gaussian-checkpoint"),("fchk","chemical/x-gaussian-checkpoint"),("fig","application/x-xfig"),("flac","application/x-flac"),("fli","video/fli"),("fm","application/x-maker"),("frame","application/x-maker"),("frm","application/x-maker"),("gal","chemical/x-gaussian-log"),("gam","chemical/x-gamess-input"),("gamin","chemical/x-gamess-input"),("gau","chemical/x-gaussian-input"),("gcd","text/x-pcs-gcd"),("gcf","application/x-graphing-calculator"),("gcg","chemical/x-gcg8-sequence"),("gen","chemical/x-genbank"),("gf","application/x-tex-gf"),("gif","image/gif"),("gjc","chemical/x-gaussian-input"),("gjf","chemical/x-gaussian-input"),("gl","video/gl"),("gnumeric","application/x-gnumeric"),("gpt","chemical/x-mopac-graph"),("gsf","application/x-font"),("gsm","audio/x-gsm"),("gtar","application/x-gtar"),("h","text/x-chdr"),("h++","text/x-c++hdr"),("hdf","application/x-hdf"),("hh","text/x-c++hdr"),("hin","chemical/x-hin"),("hpp","text/x-c++hdr"),("hqx","application/mac-binhex40"),("hs","text/x-haskell"),("hta","application/hta"),("htc","text/x-component"),("htm","text/html"),("html","text/html"),("hxx","text/x-c++hdr"),("ica","application/x-ica"),("ice","x-conference/x-cooltalk"),("ico","image/x-icon"),("ics","text/calendar"),("icz","text/calendar"),("ief","image/ief"),("iges","model/iges"),("igs","model/iges"),("iii","application/x-iphone"),("inp","chemical/x-gamess-input"),("ins","application/x-internet-signup"),("iso","application/x-iso9660-image"),("isp","application/x-internet-signup"),("ist","chemical/x-isostar"),("istr","chemical/x-isostar"),("jad","text/vnd.sun.j2me.app-descriptor"),("jar","application/java-archive"),("java","text/x-java"),("jdx","chemical/x-jcamp-dx"),("jmz","application/x-jmol"),("jng","image/x-jng"),("jnlp","application/x-java-jnlp-file"),("jpe","image/jpeg"),("jpeg","image/jpeg"),("jpg","image/jpeg"),("js","application/x-javascript"),("kar","audio/midi"),("key","application/pgp-keys"),("kil","application/x-killustrator"),("kin","chemical/x-kinemage"),("kml","application/vnd.google-earth.kml+xml"),("kmz","application/vnd.google-earth.kmz"),("kpr","application/x-kpresenter"),("kpt","application/x-kpresenter"),("ksp","application/x-kspread"),("kwd","application/x-kword"),("kwt","application/x-kword"),("latex","application/x-latex"),("lha","application/x-lha"),("lhs","text/x-literate-haskell"),("lsf","video/x-la-asf"),("lsx","video/x-la-asf"),("ltx","text/x-tex"),("lyx","application/x-lyx"),("lzh","application/x-lzh"),("lzx","application/x-lzx"),("m3u","audio/mpegurl"),("m4a","audio/mpeg"),("maker","application/x-maker"),("man","application/x-troff-man"),("mcif","chemical/x-mmcif"),("mcm","chemical/x-macmolecule"),("mdb","application/msaccess"),("me","application/x-troff-me"),("mesh","model/mesh"),("mid","audio/midi"),("midi","audio/midi"),("mif","application/x-mif"),("mm","application/x-freemind"),("mmd","chemical/x-macromodel-input"),("mmf","application/vnd.smaf"),("mml","text/mathml"),("mmod","chemical/x-macromodel-input"),("mng","video/x-mng"),("moc","text/x-moc"),("mol","chemical/x-mdl-molfile"),("mol2","chemical/x-mol2"),("moo","chemical/x-mopac-out"),("mop","chemical/x-mopac-input"),("mopcrt","chemical/x-mopac-input"),("mov","video/quicktime"),("movie","video/x-sgi-movie"),("mp2","audio/mpeg"),("mp3","audio/mpeg"),("mp4","video/mp4"),("mpc","chemical/x-mopac-input"),("mpe","video/mpeg"),("mpeg","video/mpeg"),("mpega","audio/mpeg"),("mpg","video/mpeg"),("mpga","audio/mpeg"),("ms","application/x-troff-ms"),("msh","model/mesh"),("msi","application/x-msi"),("mvb","chemical/x-mopac-vib"),("mxu","video/vnd.mpegurl"),("nb","application/mathematica"),("nc","application/x-netcdf"),("nwc","application/x-nwc"),("o","application/x-object"),("oda","application/oda"),("odb","application/vnd.oasis.opendocument.database"),("odc","application/vnd.oasis.opendocument.chart"),("odf","application/vnd.oasis.opendocument.formula"),("odg","application/vnd.oasis.opendocument.graphics"),("odi","application/vnd.oasis.opendocument.image"),("odm","application/vnd.oasis.opendocument.text-master"),("odp","application/vnd.oasis.opendocument.presentation"),("ods","application/vnd.oasis.opendocument.spreadsheet"),("odt","application/vnd.oasis.opendocument.text"),("oga","audio/ogg"),("ogg","application/ogg"),("ogv","video/ogg"),("ogx","application/ogg"),("old","application/x-trash"),("otg","application/vnd.oasis.opendocument.graphics-template"),("oth","application/vnd.oasis.opendocument.text-web"),("otp","application/vnd.oasis.opendocument.presentation-template"),("ots","application/vnd.oasis.opendocument.spreadsheet-template"),("ott","application/vnd.oasis.opendocument.text-template"),("oza","application/x-oz-application"),("p","text/x-pascal"),("p7r","application/x-pkcs7-certreqresp"),("pac","application/x-ns-proxy-autoconfig"),("pas","text/x-pascal"),("pat","image/x-coreldrawpattern"),("patch","text/x-diff"),("pbm","image/x-portable-bitmap"),("pcap","application/cap"),("pcf","application/x-font"),("pcf.Z","application/x-font"),("pcx","image/pcx"),("pdb","chemical/x-pdb"),("pdf","application/pdf"),("pfa","application/x-font"),("pfb","application/x-font"),("pgm","image/x-portable-graymap"),("pgn","application/x-chess-pgn"),("pgp","application/pgp-signature"),("php","application/x-httpd-php"),("php3","application/x-httpd-php3"),("php3p","application/x-httpd-php3-preprocessed"),("php4","application/x-httpd-php4"),("phps","application/x-httpd-php-source"),("pht","application/x-httpd-php"),("phtml","application/x-httpd-php"),("pk","application/x-tex-pk"),("pl","text/x-perl"),("pls","audio/x-scpls"),("pm","text/x-perl"),("png","image/png"),("pnm","image/x-portable-anymap"),("pot","text/plain"),("ppm","image/x-portable-pixmap"),("pps","application/vnd.ms-powerpoint"),("ppt","application/vnd.ms-powerpoint"),("prf","application/pics-rules"),("prt","chemical/x-ncbi-asn1-ascii"),("ps","application/postscript"),("psd","image/x-photoshop"),("py","text/x-python"),("pyc","application/x-python-code"),("pyo","application/x-python-code"),("qt","video/quicktime"),("qtl","application/x-quicktimeplayer"),("ra","audio/x-pn-realaudio"),("ram","audio/x-pn-realaudio"),("rar","application/rar"),("ras","image/x-cmu-raster"),("rd","chemical/x-mdl-rdfile"),("rdf","application/rdf+xml"),("rgb","image/x-rgb"),("rhtml","application/x-httpd-eruby"),("rm","audio/x-pn-realaudio"),("roff","application/x-troff"),("ros","chemical/x-rosdal"),("rpm","application/x-redhat-package-manager"),("rss","application/rss+xml"),("rtf","application/rtf"),("rtx","text/richtext"),("rxn","chemical/x-mdl-rxnfile"),("sct","text/scriptlet"),("sd","chemical/x-mdl-sdfile"),("sd2","audio/x-sd2"),("sda","application/vnd.stardivision.draw"),("sdc","application/vnd.stardivision.calc"),("sdd","application/vnd.stardivision.impress"),("sdf","application/vnd.stardivision.math"),("sds","application/vnd.stardivision.chart"),("sdw","application/vnd.stardivision.writer"),("ser","application/java-serialized-object"),("sgf","application/x-go-sgf"),("sgl","application/vnd.stardivision.writer-global"),("sh","application/x-sh"),("shar","application/x-shar"),("shtml","text/html"),("sid","audio/prs.sid"),("sik","application/x-trash"),("silo","model/mesh"),("sis","application/vnd.symbian.install"),("sisx","x-epoc/x-sisx-app"),("sit","application/x-stuffit"),("sitx","application/x-stuffit"),("skd","application/x-koan"),("skm","application/x-koan"),("skp","application/x-koan"),("skt","application/x-koan"),("smi","application/smil"),("smil","application/smil"),("snd","audio/basic"),("spc","chemical/x-galactic-spc"),("spl","application/futuresplash"),("spx","audio/ogg"),("src","application/x-wais-source"),("stc","application/vnd.sun.xml.calc.template"),("std","application/vnd.sun.xml.draw.template"),("sti","application/vnd.sun.xml.impress.template"),("stl","application/vnd.ms-pki.stl"),("stw","application/vnd.sun.xml.writer.template"),("sty","text/x-tex"),("sv4cpio","application/x-sv4cpio"),("sv4crc","application/x-sv4crc"),("svg","image/svg+xml"),("svgz","image/svg+xml"),("sw","chemical/x-swissprot"),("swf","application/x-shockwave-flash"),("swfl","application/x-shockwave-flash"),("sxc","application/vnd.sun.xml.calc"),("sxd","application/vnd.sun.xml.draw"),("sxg","application/vnd.sun.xml.writer.global"),("sxi","application/vnd.sun.xml.impress"),("sxm","application/vnd.sun.xml.math"),("sxw","application/vnd.sun.xml.writer"),("t","application/x-troff"),("tar","application/x-tar"),("taz","application/x-gtar"),("tcl","application/x-tcl"),("tex","text/x-tex"),("texi","application/x-texinfo"),("texinfo","application/x-texinfo"),("text","text/plain"),("tgf","chemical/x-mdl-tgf"),("tgz","application/x-gtar"),("tif","image/tiff"),("tiff","image/tiff"),("tk","text/x-tcl"),("tm","text/texmacs"),("torrent","application/x-bittorrent"),("tr","application/x-troff"),("ts","text/texmacs"),("tsp","application/dsptype"),("tsv","text/tab-separated-values"),("txt","text/plain"),("udeb","application/x-debian-package"),("uls","text/iuls"),("ustar","application/x-ustar"),("val","chemical/x-ncbi-asn1-binary"),("vcd","application/x-cdlink"),("vcf","text/x-vcard"),("vcs","text/x-vcalendar"),("vmd","chemical/x-vmd"),("vms","chemical/x-vamas-iso14976"),("vrm","x-world/x-vrml"),("vrml","model/vrml"),("vsd","application/vnd.visio"),("wad","application/x-doom"),("wav","audio/x-wav"),("wax","audio/x-ms-wax"),("wbmp","image/vnd.wap.wbmp"),("wbxml","application/vnd.wap.wbxml"),("wk","application/x-123"),("wm","video/x-ms-wm"),("wma","audio/x-ms-wma"),("wmd","application/x-ms-wmd"),("wml","text/vnd.wap.wml"),("wmlc","application/vnd.wap.wmlc"),("wmls","text/vnd.wap.wmlscript"),("wmlsc","application/vnd.wap.wmlscriptc"),("wmv","video/x-ms-wmv"),("wmx","video/x-ms-wmx"),("wmz","application/x-ms-wmz"),("wp5","application/wordperfect5.1"),("wpd","application/wordperfect"),("wrl","model/vrml"),("wsc","text/scriptlet"),("wvx","video/x-ms-wvx"),("wz","application/x-wingz"),("xbm","image/x-xbitmap"),("xcf","application/x-xcf"),("xht","application/xhtml+xml"),("xhtml","application/xhtml+xml"),("xlb","application/vnd.ms-excel"),("xls","application/vnd.ms-excel"),("xlt","application/vnd.ms-excel"),("xml","application/xml"),("xpi","application/x-xpinstall"),("xpm","image/x-xpixmap"),("xsl","application/xml"),("xtel","chemical/x-xtel"),("xul","application/vnd.mozilla.xul+xml"),("xwd","image/x-xwindowdump"),("xyz","chemical/x-xyz"),("zip","application/zip"),("zmt","chemical/x-mopac-input"),("~","application/x-trash")]