X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=5b0ce579ed66e41bc0c1e1d926588743e05468ae;hb=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d;hp=e710fc90ec62beb0e9cf22164a5c65c92d134b9a;hpb=b340a77fa7bd051dd13a41d0a5b1ad30220bc6b6;p=Lucu.git diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index e710fc9..5b0ce57 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,3 +1,4 @@ +-- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile , handleStaticFile @@ -12,65 +13,75 @@ module Network.HTTP.Lucu.StaticFile import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Time.Clock.POSIX import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils -import System.Directory import System.Posix.Files -import Text.Printf +-- | @'staticFile' fpath@ is a +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file +-- at @fpath@ on the filesystem. staticFile :: FilePath -> ResourceDef staticFile path = ResourceDef { resUsesNativeThread = False , resIsGreedy = False - , resGet = Just $ handleStaticFile path + , resGet = Just $! handleStaticFile path , resHead = Nothing , resPost = Nothing , resPut = Nothing , resDelete = Nothing } - +-- | Computation of @'handleStaticFile' fpath@ serves the file at +-- @fpath@ on the filesystem. The +-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining +-- Request/ state before the computation. It will be in the /Done/ +-- state after the computation. +-- +-- If you just want to place a static file on the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use +-- 'staticFile' instead of this. handleStaticFile :: FilePath -> Resource () handleStaticFile path - = do isFile <- liftIO $ doesFileExist path - if isFile then + = path `seq` + do exists <- liftIO $ fileExist path + if exists then -- 存在はした。讀めるかどうかは知らない。 - do readable <- liftIO $ fileAccess path True False False - unless readable + do stat <- liftIO $ getFileStatus path + if isRegularFile stat then + do readable <- liftIO $ fileAccess path True False False + unless readable -- 讀めない $ abort Forbidden [] Nothing - - -- 讀める - tag <- liftIO $ generateETagFromFile path - lastMod <- liftIO $ getModificationTime path - foundEntity tag lastMod - - -- MIME Type を推定 - conf <- getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime - - -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputBS - else - do isDir <- liftIO $ doesDirectoryExist path - if isDir then - abort Forbidden [] Nothing + -- 讀める + tag <- liftIO $ generateETagFromFile path + let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat + foundEntity tag lastMod + + -- MIME Type を推定 + conf <- getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing -> return () + Just mime -> setContentType mime + + -- 實際にファイルを讀んで送る + liftIO (B.readFile path) >>= outputLBS else - foundNoEntity Nothing + abort Forbidden [] Nothing + else + foundNoEntity Nothing --- |Computation @'generateETagFromFile' fpath@ generates a strong +-- |Computation of @'generateETagFromFile' fpath@ generates a strong -- entity tag from a file. The file doesn't necessarily have to be a -- regular file; it may be a FIFO or a device file. The tag is made of -- inode ID, size and modification time. @@ -84,29 +95,48 @@ handleStaticFile path -- large (say, 1 TiB). generateETagFromFile :: FilePath -> IO ETag generateETagFromFile path - = do stat <- getFileStatus path - let inode = fromEnum $ fileID stat - size = fromEnum $ fileSize stat - lastmod = fromEnum $ modificationTime stat - return $ strongETag $ printf "%x-%x-%x" inode size lastmod - - + = path `seq` + do stat <- getFileStatus path + let inode = fromEnum $! fileID stat + size = fromEnum $! fileSize stat + lastMod = fromEnum $! modificationTime stat + tag = fmtHex False 0 inode + ++ "-" ++ + fmtHex False 0 size + ++ "-" ++ + fmtHex False 0 lastMod + return $! strongETag tag + +-- | @'staticDir' dir@ is a +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files +-- in @dir@ and its subdirectories on the filesystem to the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. staticDir :: FilePath -> ResourceDef staticDir path = ResourceDef { resUsesNativeThread = False , resIsGreedy = True - , resGet = Just $ handleStaticDir path + , resGet = Just $! handleStaticDir path , resHead = Nothing , resPost = Nothing , resPut = Nothing , resDelete = Nothing } - +-- | Computation of @'handleStaticDir' dir@ maps all files in @dir@ +-- and its subdirectories on the filesystem to the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The +-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining +-- Request/ state before the computation. It will be in the /Done/ +-- state after the computation. +-- +-- If you just want to place a static directory tree on the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use +-- 'staticDir' instead of this. handleStaticDir :: FilePath -> Resource () handleStaticDir basePath - = do extraPath <- getPathInfo + = basePath `seq` + do extraPath <- getPathInfo securityCheck extraPath let path = basePath ++ "/" ++ joinWith "/" extraPath @@ -114,5 +144,6 @@ handleStaticDir basePath where securityCheck :: Monad m => [String] -> m () securityCheck pathElems - = when (any (== "..") pathElems) $ fail ("security error: " + = pathElems `seq` + when (any (== "..") pathElems) $ fail ("security error: " ++ joinWith "/" pathElems)