X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FStaticFile.hs;h=8f93513659affc2dbf5c0ddbe31fe27eab6929ae;hp=f9e2513d47d2d865d4067f4f21e49b9a8ac972e9;hb=895341e;hpb=05f8f795a483f672b7cafc7ba9d444dc84b937a8 diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index f9e2513..8f93513 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,14 +1,12 @@ {-# LANGUAGE - OverloadedStrings + DoAndIfThenElse + , OverloadedStrings , UnicodeSyntax #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile - , handleStaticFile - , staticDir - , handleStaticDir , generateETagFromFile ) @@ -26,6 +24,7 @@ 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 import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree @@ -38,66 +37,53 @@ import System.Posix.Files -- @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 '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 +octetStream ∷ MIMEType +octetStream = mkMIMEType "application" "octet-stream" + +handleStaticFile ∷ Bool → FilePath → Resource () +handleStaticFile sendContent 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 + unless exists + $ foundNoEntity Nothing + + readable ← liftIO $ fileAccess path True False False + unless readable + $ abort 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 Forbidden [] Nothing - -- 實際にファイルを讀んで送る - liftIO (B.readFile path) ≫= output - 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 (B.readFile path) ≫= output + +-- |@'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 @@ -117,32 +103,25 @@ generateETagFromFile path -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in -- @dir@ and its subdirectories on the filesystem to the '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 } --- | 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 +handleStaticDir ∷ Bool → FilePath → Resource () +handleStaticDir sendContent basePath = do extraPath ← getPathInfo securityCheck extraPath let path = basePath joinPath (map T.unpack extraPath) - handleStaticFile path + handleStaticFile sendContent path where securityCheck pathElems = when (any (≡ "..") pathElems)