X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=5b5eb9734e3a68441516f36a86ada99269ea7888;hp=12cf78b0729c760c82e6f35faa08909f6d53b876;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 12cf78b..5b5eb97 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,149 +1,102 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , QuasiQuotes + , UnicodeSyntax + #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile - , handleStaticFile - , staticDir - , handleStaticDir - - , generateETagFromFile ) where +import Control.Monad +import Control.Monad.Unicode +import Control.Monad.Trans +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +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 Network.HTTP.Lucu.Utils +import Prelude.Unicode +import System.Directory +import System.FilePath -import Control.Monad -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as B -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 - - --- | @'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 'Resource' which serves the file at +-- @fpath@ on the filesystem. +staticFile ∷ FilePath → Resource 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 isFile <- liftIO $ doesFileExist path - if isFile then - -- 存在はした。讀めるかどうかは知らない。 - do readable <- liftIO $ fileAccess path True False False - unless readable - -- 讀めない - $ abort Forbidden [] Nothing +octetStream ∷ MIMEType +octetStream = [mimeType| application/octet-stream |] - -- 讀める - tag <- liftIO $ generateETagFromFile path - lastMod <- liftIO $ getModificationTime path - foundEntity tag lastMod +handleStaticFile ∷ Bool → FilePath → Rsrc () +handleStaticFile sendContent path + = do isDir ← liftIO $ doesDirectoryExist path + when isDir + $ abort + $ mkAbortion Forbidden [] Nothing - -- MIME Type を推定 - conf <- getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime + isFile ← liftIO $ doesFileExist path + unless isFile + foundNoEntity' - -- 實際にファイルを讀んで送る - (liftIO $ B.readFile path) >>= outputLBS - else - do isDir <- liftIO $ doesDirectoryExist path - if isDir then - abort Forbidden [] Nothing - else - foundNoEntity Nothing + perms ← liftIO $ getPermissions path + unless (readable perms) + $ abort + $ mkAbortion Forbidden [] Nothing --- |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 - = 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 + lastMod ← liftIO $ getLastModified path + foundTimeStamp lastMod + + conf ← getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing → setContentType octetStream + Just mime → setContentType mime --- | @'staticDir' dir@ is a --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files --- in @dir@ and its subdirectories on the filesystem to the + when sendContent + $ liftIO (LBS.readFile path) ≫= putChunks + +-- | @'staticDir' dir@ is a 'Resource' 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 → Resource 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 → Rsrc () +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)