{-# 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)
projects / Lucu.git / blobdiff