+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , UnicodeSyntax
+ #-}
+-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
( staticFile
- , handleStaticFile
-
, staticDir
- , handleStaticDir
, generateETagFromFile
)
where
-
-import Control.Monad
-import Control.Monad.Trans
+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.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 Data.Monoid.Unicode
+import qualified Data.Text 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
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Tree
+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
-
-
--- |Computation @'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.
+octetStream ∷ MIMEType
+octetStream = mkMIMEType "application" "octet-stream"
+
+handleStaticFile ∷ Bool → FilePath → Resource ()
+handleStaticFile sendContent path
+ = do exists ← liftIO $ fileExist path
+ unless exists
+ $ foundNoEntity Nothing
+
+ readable ← liftIO $ fileAccess path True False False
+ unless readable
+ $ abort Forbidden [] Nothing
+
+ stat ← liftIO $ getFileStatus path
+ when (isDirectory stat)
+ $ abort 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 (B.readFile path) ≫= putChunk
+
+-- |@'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
- = 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 '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
+handleStaticDir ∷ Bool → FilePath → Resource ()
+handleStaticDir sendContent basePath
+ = do extraPath ← getPathInfo
securityCheck extraPath
- let path = basePath ++ "/" ++ joinWith "/" extraPath
+ let path = basePath </> joinPath (map T.unpack extraPath)
- handleStaticFile path
+ handleStaticFile sendContent path
where
- securityCheck :: Monad m => [String] -> m ()
securityCheck pathElems
- = when (any (== "..") pathElems) $ fail ("security error: "
- ++ joinWith "/" pathElems)
+ = when (any (≡ "..") pathElems)
+ $ fail ("security error: " ⧺ show pathElems)
+-- TODO: implement directory listing.