+{-# LANGUAGE
+ BangPatterns
+ , UnicodeSyntax
+ #-}
+-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
- ( staticFile -- FilePath -> ResourceDef
- , handleStaticFile -- FilePath -> Resource ()
+ ( staticFile
+ , handleStaticFile
+
+ , staticDir
+ , handleStaticDir
+
+ , generateETagFromFile
)
where
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 System.Directory
+import Network.HTTP.Lucu.Utils
+import System.FilePath.Posix
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 exist <- liftIO $ fileExist path
- if exist 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
+ let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
+ foundEntity tag lastMod
- -- 讀める
- 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
+ -- MIME Type を推定
+ conf <- getConfig
+ case guessTypeByFileName (cnfExtToMIMEType conf) path of
+ Nothing -> return ()
+ Just mime -> setContentType mime
- -- 實際にファイルを讀んで送る
- (liftIO $ B.readFile path) >>= outputBS
+ -- 實際にファイルを讀んで送る
+ liftIO (B.readFile path) >>= outputLBS
+ else
+ abort Forbidden [] Nothing
else
foundNoEntity Nothing
--- inode-size-lastmod
+-- |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.
+--
+-- Note that the tag is not strictly strong because the file could be
+-- modified twice at a second without changing inode ID or size, but
+-- it's not really possible to generate a strict strong ETag from a
+-- file since we don't want to simply grab the entire file and use it
+-- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
+-- increase strictness, but it's too inefficient if the file is really
+-- 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
+ , 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
+ securityCheck extraPath
+ let path = basePath </> joinPath extraPath
+
+ handleStaticFile path
+ where
+ securityCheck :: Monad m => [String] -> m ()
+ securityCheck !pathElems
+ = when (any (== "..") pathElems) $ fail ("security error: "
+ ++ joinWith "/" pathElems)
+-- TODO: implement directory listing.
projects / Lucu.git / blobdiff