X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=f9e2513d47d2d865d4067f4f21e49b9a8ac972e9;hb=32a6ebbb18856ab1203e8a114414f235c2abe22b;hp=89b783281b12bbfdf526fabcdc545c856e68ecec;hpb=a44a96d95b5fcbaf24a21c0336046ce0c3bab614;p=Lucu.git diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 89b7832..f9e2513 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,26 +1,42 @@ +{-# LANGUAGE + OverloadedStrings + , 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 Blaze.ByteString.Builder.ByteString as BB +import qualified Blaze.Text.Int as BT +import Control.Monad +import Control.Monad.Unicode +import Control.Monad.Trans +import qualified Data.Ascii as A import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ETag -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 System.Posix.Files -import Text.Printf +import Data.Monoid.Unicode +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Resource.Tree +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import System.FilePath +import System.Posix.Files - -staticFile :: FilePath -> ResourceDef +-- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at +-- @fpath@ on the filesystem. +staticFile ∷ FilePath → ResourceDef staticFile path = ResourceDef { resUsesNativeThread = False @@ -32,39 +48,103 @@ staticFile path , resDelete = Nothing } - -handleStaticFile :: FilePath -> Resource () +-- | Computation of @'handleStaticFile' fpath@ serves the file at +-- @fpath@ on the filesystem. The '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 'ResTree', you had +-- better use 'staticFile' rather than this. +handleStaticFile ∷ FilePath → Resource () handleStaticFile path - = do exist <- liftIO $ fileExist path - if exist then + = 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) ≫= output + else + abort Forbidden [] Nothing else foundNoEntity Nothing --- inode-size-lastmod -generateETagFromFile :: FilePath -> IO ETag +-- |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 + = do stat ← getFileStatus path + let inode = fileID stat + size = fileSize stat + lastMod = fromEnum $ modificationTime stat + tag = A.fromAsciiBuilder + $ A.unsafeFromBuilder + $ BT.integral inode + ⊕ BB.fromByteString "-" + ⊕ BT.integral size + ⊕ BB.fromByteString "-" + ⊕ BT.integral lastMod + return $ strongETag tag + +-- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in +-- @dir@ and its subdirectories on the filesystem to the '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 'ResTree'. The +-- '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 'ResTree', +-- you had better use 'staticDir' rather than this. +handleStaticDir ∷ FilePath → Resource () +handleStaticDir basePath + = do extraPath ← getPathInfo + securityCheck extraPath + let path = basePath joinPath (map T.unpack extraPath) + + handleStaticFile path + where + securityCheck pathElems + = when (any (≡ "..") pathElems) + $ fail ("security error: " ⧺ show pathElems) +-- TODO: implement directory listing.