{-# 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