happstack-server-0.3.1: src/Happstack/Server/HTTP/FileServe.hs
{-# LANGUAGE FlexibleContexts, Rank2Types #-}
module Happstack.Server.HTTP.FileServe
(
MimeMap,
blockDotFiles,
doIndex,
doIndexStrict,
errorwrapper,
fileServe,
fileServeStrict,
isDot,
mimeTypes
) where
import Control.Exception.Extensible
import Control.Monad.Reader
import Control.Monad.Trans
import Data.List
import Data.Maybe
import Data.Int
import Happstack.Server.SimpleHTTP hiding (path)
import System.Directory
import System.IO
import System.Locale(defaultTimeLocale)
import System.Log.Logger
import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as Map
import qualified Happstack.Server.SimpleHTTP as SH
ioErrors :: SomeException -> Maybe IOException
ioErrors = fromException
errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response
errorwrapper binarylocation loglocation
= require getErrorLog $ \errorLog ->
return $ toResponse errorLog
where getErrorLog
= handleJust ioErrors (const (return Nothing)) $
do bintime <- getModificationTime binarylocation
logtime <- getModificationTime loglocation
if (logtime > bintime)
then fmap Just $ readFile loglocation
else return Nothing
type MimeMap = Map.Map String String
type GetFileFunc = (MonadIO m) =>
Map.Map String String
-> String
-> m (Either String ((ClockTime, Integer), (String, L.ByteString)))
doIndex :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
[String] -> MimeMap -> String -> m Response
doIndex = doIndex' getFile
-- | A variant of 'doIndex' that relies on 'getFileStrict'
doIndexStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
[String] -> MimeMap -> String -> m Response
doIndexStrict = doIndex' getFileStrict
doIndex' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
GetFileFunc
-> [String]
-> MimeMap
-> String
-> m Response
doIndex' _getFileFunc [] _mime _fp = forbidden $ toResponse "Directory index forbidden"
doIndex' getFileFunc (index:rest) mime fp =
do
let path = fp++'/':index
--print path
fe <- liftIO $ doesFileExist path
if fe then retFile path else doIndex rest mime fp
where retFile = returnFile getFileFunc mime
defaultIxFiles :: [String]
defaultIxFiles= ["index.html","index.xml","index.gif"]
-- | Serve a file (lazy version). For efficiency reasons when serving large
-- files, will escape the computation early if a file is successfully served,
-- to prevent filters from being applied; if a filter were applied, we would
-- need to compute the content-length (thereby forcing the spine of the
-- ByteString into memory) rather than reading it from the filesystem.
--
-- Note that using lazy fileServe can result in some filehandles staying open
-- until the garbage collector gets around to closing them.
fileServe :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m) =>
[FilePath] -- ^ index files if the path is a directory
-> FilePath -- ^ file/directory to serve
-> m Response
fileServe ixFiles localpath = do
resp <- fileServe' localpath
(doIndex (ixFiles++defaultIxFiles))
mimeTypes
getFile
escape' $ resp { rsFlags = RsFlags {rsfContentLength=False} }
-- | Serve a file (strict version). Reads the entire file strictly into
-- memory, and ensures that the handle is properly closed. Unlike lazy
-- fileServe, this function doesn't shortcut the computation early, and it
-- allows for filtering (ex: gzip compression) to be applied
fileServeStrict :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
[FilePath] -- ^ index files if the path is a directory
-> FilePath -- ^ file/directory to serve
-> m Response
fileServeStrict ixFiles localpath = do
resp <- fileServe' localpath
(doIndex (ixFiles++defaultIxFiles))
mimeTypes
getFileStrict
-- clear "Content-Length" because it could be modified by filters
-- downstream
let headers = rsHeaders resp
return $ resp {rsHeaders = Map.delete (P.pack "content-length") headers}
-- | Serve files with a mime type map under a directory.
-- Uses the function to transform URIs to FilePaths.
fileServe' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
String
-> (Map.Map String String -> String -> m Response)
-> Map.Map String String
-> GetFileFunc
-> m Response
fileServe' localpath fdir mime getFileFunc = do
rq <- askRq
let fp2 = takeWhile (/=',') fp
fp = filepath
safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)
filepath = intercalate "/" (localpath:safepath)
fp' = if null safepath then "" else last safepath
if "TESTH" `isPrefixOf` fp'
then renderResponse mime $ fakeFile $ (read $ drop 5 $ fp' :: Integer)
else do
fe <- liftIO $ doesFileExist fp
fe2 <- liftIO $ doesFileExist fp2
de <- liftIO $ doesDirectoryExist fp
-- error $ "show ilepath: " ++show (fp,de)
let status | de = "DIR"
| fe = "file"
| fe2 = "group"
| True = "NOT FOUND"
liftIO $ logM "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)
if de then fdir mime fp else do
getFileFunc mime fp >>= flip either (renderResponse mime)
(const $ returnGroup localpath mime safepath)
returnFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
GetFileFunc -> Map.Map String String -> String -> m Response
returnFile getFileFunc mime fp =
getFileFunc mime fp >>= either fileNotFound (renderResponse mime)
-- if fp has , separated then return concatenation with content-type of last
-- and last modified of latest
tr :: (Eq a) => a -> a -> [a] -> [a]
tr a b = map (\x->if x==a then b else x)
ltrim :: String -> String
ltrim = dropWhile (flip elem " \t\r")
returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>
String -> Map.Map String String -> [String] -> m Response
returnGroup localPath mime fp = do
let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp
fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0
-- if (head $ head fps0)=="TEST" then renderResponse mime rq fakeFile else do
mbFiles <- mapM (getFile mime) $ fps
let notFounds = [x | Left x <- mbFiles]
files = [x | Right x <- mbFiles]
if not $ null notFounds
then fileNotFound $ drop (length localPath) $ head notFounds else do
let totSize = sum $ map (snd . fst) files
maxTime = maximum $ map (fst . fst) files :: ClockTime
renderResponse mime ((maxTime,totSize),(fst $ snd $ head files,
L.concat $ map (snd . snd) files))
fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response
fileNotFound fp = return $ result 404 $ "File not found " ++ fp
--fakeLen = 71* 1024
fakeFile :: (Integral a) =>
a -> ((ClockTime, Int64), (String, L.ByteString))
fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))
where
body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n"
len = fromIntegral fakeLen
-- | @getFile mimeMap path@ will lazily read the file as a ByteString
-- with a content type provided by matching the file extension with the
-- @mimeMap@. getFile will return an error string or ((timeFetched,size), (contentType,fileContents))
getFile :: (MonadIO m) =>
Map.Map String String
-> String
-> m (Either String ((ClockTime, Integer), (String, L.ByteString)))
getFile mime fp = do
let ct = Map.findWithDefault "text/plain" (getExt fp) mime
fe <- liftIO $ doesFileExist fp
if not fe then return $ Left fp else do
time <- liftIO $ getModificationTime fp
h <- liftIO $ openBinaryFile fp ReadMode
size <- liftIO $ hFileSize h
lbs <- liftIO $ L.hGetContents h
return $ Right ((time,size),(ct,lbs))
-- | As 'getFile' but strictly fetches the file, instead of lazily.
getFileStrict :: (MonadIO m) =>
Map.Map String String
-> String
-> m (Either String ((ClockTime, Integer), (String, L.ByteString)))
getFileStrict mime fp = do
let ct = Map.findWithDefault "text/plain" (getExt fp) mime
fe <- liftIO $ doesFileExist fp
if not fe then return $ Left fp else do
time <- liftIO $ getModificationTime fp
s <- liftIO $ P.readFile fp
let lbs = L.fromChunks [s]
let size = toInteger . P.length $ s
return $ Right ((time,size),(ct,lbs))
renderResponse :: (Monad m,
ServerMonad m,
FilterMonad Response m,
Show t1) =>
t
-> ((ClockTime, t1), (String, L.ByteString))
-> m Response
renderResponse _ ((modtime,size),(ct,body)) = do
rq <- askRq
let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)
repr = formatCalendarTime defaultTimeLocale
"%a, %d %b %Y %X GMT" (toUTCTime modtime)
-- "Mon, 07 Jan 2008 19:51:02 GMT"
-- when (isJust $ getHeader "if-modified-since" rq) $ error $ show $ getHeader "if-modified-since" rq
if notmodified then
return $ result 304 ""
else do
return $ ((setHeader "Last-modified" repr) .
(setHeader "Content-Length" (show size)) .
(setHeader "Content-Type" ct)) $
resultBS 200 body
getExt :: String -> String
getExt = reverse . takeWhile (/='.') . reverse
-- | Ready collection of common mime types.
mimeTypes :: MimeMap
mimeTypes = Map.fromList
[("xml","application/xml")
,("xsl","application/xml")
,("js","text/javascript")
,("html","text/html")
,("htm","text/html")
,("css","text/css")
,("gif","image/gif")
,("jpg","image/jpeg")
,("png","image/png")
,("txt","text/plain")
,("doc","application/msword")
,("exe","application/octet-stream")
,("pdf","application/pdf")
,("zip","application/zip")
,("gz","application/x-gzip")
,("ps","application/postscript")
,("rtf","application/rtf")
,("wav","application/x-wav")
,("hs","text/plain")]
-- | Prevents files of the form '.foo' or 'bar/.foo' from being served
blockDotFiles :: (Request -> IO Response) -> Request -> IO Response
blockDotFiles fn rq
| isDot (intercalate "/" (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