X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=90cdcb0fa22d65d12e8ce1f08c6940551a142f6c;hp=7c2ce5c4d455602c133cdfcc4669f937532f6674;hb=5e56140;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4 diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 7c2ce5c..90cdcb0 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,149 +1,140 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , QuasiQuotes + , UnicodeSyntax + #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile - , handleStaticFile - , staticDir - , handleStaticDir , generateETagFromFile ) where +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 -import Control.Monad -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as B -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.Posix.Files - - --- | @'staticFile' fpath@ is a --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file --- at @fpath@ on the filesystem. -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 - , 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 } --- | 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 - = path `seq` - do exists <- liftIO $ fileExist path - if exists then - -- 存在はした。讀めるかどうかは知らない。 - 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 <- return $ posixSecondsToUTCTime $ toEnum $ fromEnum $ modificationTime stat - foundEntity tag lastMod +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 - -- MIME Type を推定 - conf <- getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime + stat ← liftIO $ getFileStatus path + when (isDirectory stat) + $ abort + $ mkAbortion Forbidden [] Nothing - -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputLBS - else - abort Forbidden [] Nothing - else - foundNoEntity 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 --- |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. + 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 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 +-- 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 ∷ FilePath → IO ETag generateETagFromFile path - = 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 + = 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 --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files --- in @dir@ and its subdirectories on the filesystem to the +-- | @'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'. -staticDir :: FilePath -> ResourceDef +-- +-- 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 } --- | 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 - = basePath `seq` - 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 - = pathElems `seq` - 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)