X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=5b5eb9734e3a68441516f36a86ada99269ea7888;hp=f9e2513d47d2d865d4067f4f21e49b9a8ac972e9;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=32a6ebbb18856ab1203e8a114414f235c2abe22b diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index f9e2513..5b5eb97 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,150 +1,102 @@ {-# LANGUAGE - OverloadedStrings + 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 qualified Data.ByteString.Lazy.Char8 as B -import Data.Monoid.Unicode +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.String import qualified Data.Text as T -import Data.Time.Clock.POSIX +import qualified Data.Text.Encoding as T 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.Tree +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 System.Posix.Files --- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at +-- | @'staticFile' fpath@ is a 'Resource' which serves the file at -- @fpath@ on the filesystem. -staticFile ∷ FilePath → ResourceDef +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 '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 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 - let lastMod = posixSecondsToUTCTime - $ fromRational - $ toRational - $ modificationTime stat - foundEntity tag lastMod +octetStream ∷ MIMEType +octetStream = [mimeType| application/octet-stream |] - -- MIME Type を推定 - conf ← getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing → return () - Just mime → setContentType mime +handleStaticFile ∷ Bool → FilePath → Rsrc () +handleStaticFile sendContent path + = do isDir ← liftIO $ doesDirectoryExist path + when isDir + $ abort + $ mkAbortion Forbidden [] Nothing - -- 實際にファイルを讀んで送る - liftIO (B.readFile path) ≫= output - else - abort Forbidden [] Nothing - else - foundNoEntity Nothing + isFile ← liftIO $ doesFileExist path + unless isFile + foundNoEntity' + 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 - = 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 + lastMod ← liftIO $ getLastModified path + foundTimeStamp lastMod + + conf ← getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing → setContentType octetStream + Just mime → setContentType mime + + when sendContent + $ liftIO (LBS.readFile path) ≫= putChunks --- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in --- @dir@ and its subdirectories on the filesystem to the 'ResTree'. -staticDir ∷ FilePath → ResourceDef +-- | @'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'. +-- +-- 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 '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 +-- TODO: implement directory listing. +handleStaticDir ∷ Bool → FilePath → Rsrc () +handleStaticDir sendContent basePath = do extraPath ← getPathInfo securityCheck extraPath - let path = basePath joinPath (map T.unpack extraPath) - - handleStaticFile path + let path = basePath joinPath (map dec8 extraPath) + handleStaticFile sendContent path where - securityCheck pathElems - = when (any (≡ "..") pathElems) - $ fail ("security error: " ⧺ show pathElems) --- TODO: implement directory listing. + 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)