+{-# LANGUAGE
+ OverloadedStrings
+ , 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 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.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 :: 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 $ do
\ No newline at end of file
+ , resGet = Just $ handleStaticFile path
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+-- | 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
+
+ -- MIME Type を推定
+ conf ← getConfig
+ case guessTypeByFileName (cnfExtToMIMEType conf) path of
+ Nothing → return ()
+ Just mime → setContentType mime
+
+ -- 實際にファイルを讀んで送る
+ liftIO (B.readFile path) ≫= output
+ else
+ abort Forbidden [] Nothing
+ else
+ foundNoEntity 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
+
+-- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
+-- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
+staticDir ∷ FilePath → ResourceDef
+staticDir path
+ = ResourceDef {
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Just $ handleStaticDir path
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Nothing
+ , resDelete = Nothing
+ }
+
+-- | 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
+ = do extraPath ← getPathInfo
+ securityCheck extraPath
+ let path = basePath </> joinPath (map T.unpack extraPath)
+
+ handleStaticFile path
+ where
+ securityCheck pathElems
+ = when (any (≡ "..") pathElems)
+ $ fail ("security error: " ⧺ show pathElems)
+-- TODO: implement directory listing.
projects / Lucu.git / blobdiff