X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=90cdcb0fa22d65d12e8ce1f08c6940551a142f6c;hp=7937af9b6fee02996136d7335664f921af0c6932;hb=5e56140;hpb=32cb47e903c5fb1d35fe48dfa8e975464a3832e3 diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 7937af9..90cdcb0 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,105 +1,140 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , QuasiQuotes + , UnicodeSyntax + #-} +-- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile - ( staticFile -- FilePath -> ResourceDef - , handleStaticFile -- FilePath -> Resource () + ( staticFile + , staticDir - , staticDir -- FilePath -> ResourceDef - , handleStaticDir -- FilePath -> Resource () + , generateETagFromFile ) where - -import Control.Monad -import Control.Monad.Trans -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 Network.HTTP.Lucu.Utils -import System.Directory -import System.Posix.Files -import Text.Printf - - -staticFile :: FilePath -> ResourceDef +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 Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Monoid.Unicode +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding 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 hiding (mimeType) +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import System.FilePath +import System.Posix.Files + +-- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at +-- @fpath@ on the filesystem. +staticFile ∷ FilePath → ResourceDef staticFile path - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet = Just $ handleStaticFile path - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + = emptyResource { + resGet = Just $ handleStaticFile True path + , resHead = Just $ handleStaticFile False path } - -handleStaticFile :: FilePath -> Resource () -handleStaticFile path - = do isFile <- liftIO $ doesFileExist path - if isFile 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 - else - foundNoEntity Nothing - - --- inode-size-lastmod -generateETagFromFile :: FilePath -> IO ETag +octetStream ∷ MIMEType +octetStream = [mimeType| application/octet-stream |] + +handleStaticFile ∷ Bool → FilePath → Resource () +handleStaticFile sendContent path + = do exists ← liftIO $ fileExist path + unless exists + foundNoEntity' + + readable ← liftIO $ fileAccess path True False False + unless readable + $ abort + $ mkAbortion Forbidden [] Nothing + + stat ← liftIO $ getFileStatus path + when (isDirectory stat) + $ abort + $ mkAbortion Forbidden [] Nothing + + tag ← liftIO $ generateETagFromFile path + let lastMod = posixSecondsToUTCTime + $ fromRational + $ toRational + $ modificationTime stat + foundEntity tag lastMod + + conf ← getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing → setContentType octetStream + Just mime → setContentType mime + + when sendContent + $ liftIO (LBS.readFile path) ≫= putChunks + +-- |@'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 strictly strong ETag from a +-- file as 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 - - -staticDir :: FilePath -> ResourceDef + = 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 +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. +-- +-- Note that 'staticDir' currently doesn't have a directory-listing +-- capability. Requesting the content of a directory will end up being +-- replied with /403 Forbidden/. +staticDir ∷ FilePath → ResourceDef staticDir path - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = True - , resGet = Just $ handleStaticDir path - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + = emptyResource { + resIsGreedy = True + , resGet = Just $ handleStaticDir True path + , resHead = Just $ handleStaticDir False path } - -handleStaticDir :: FilePath -> Resource () -handleStaticDir basePath - = do extraPath <- getPathInfo +-- TODO: implement directory listing. +handleStaticDir ∷ Bool → FilePath → Resource () +handleStaticDir sendContent basePath + = do extraPath ← getPathInfo securityCheck extraPath - let path = basePath ++ "/" ++ joinWith "/" extraPath - - handleStaticFile path + let path = basePath joinPath (map dec8 extraPath) + handleStaticFile sendContent path where - securityCheck :: Monad m => [String] -> m () - securityCheck pathElems - = when (any (== "..") pathElems) $ fail ("security error: " - ++ joinWith "/" pathElems) + dec8 ∷ ByteString → String + dec8 = T.unpack ∘ T.decodeUtf8 + +securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m () +securityCheck pathElems + = when (any (≡ "..") pathElems) + $ fail ("security error: " ⧺ show pathElems)