{-# LANGUAGE
DoAndIfThenElse
, OverloadedStrings
+ , QuasiQuotes
, UnicodeSyntax
#-}
-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
( staticFile
, staticDir
-
- , 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 Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.Monoid.Unicode
import Data.String
-import qualified Data.Text as T
import qualified Data.Text.Encoding 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.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
- = emptyResource {
+ = (∅) {
resGet = Just $ handleStaticFile True path
, resHead = Just $ handleStaticFile False path
}
octetStream ∷ MIMEType
-octetStream = mkMIMEType "application" "octet-stream"
+octetStream = [mimeType| application/octet-stream |]
-handleStaticFile ∷ Bool → FilePath → Resource ()
+handleStaticFile ∷ Bool → FilePath → Rsrc ()
handleStaticFile sendContent path
- = do exists ← liftIO $ fileExist path
- unless exists
- $ foundNoEntity Nothing
-
- readable ← liftIO $ fileAccess path True False False
- unless readable
+ = do isDir ← liftIO $ doesDirectoryExist path
+ when isDir
$ abort
$ mkAbortion Forbidden [] Nothing
- stat ← liftIO $ getFileStatus path
- when (isDirectory stat)
+ isFile ← liftIO $ doesFileExist path
+ unless isFile
+ foundNoEntity'
+
+ perms ← liftIO $ getPermissions path
+ unless (readable perms)
$ abort
$ mkAbortion Forbidden [] Nothing
- tag ← liftIO $ generateETagFromFile path
- let lastMod = posixSecondsToUTCTime
- $ fromRational
- $ toRational
- $ modificationTime stat
- foundEntity tag lastMod
+ lastMod ← liftIO $ getLastModified path
+ foundTimeStamp lastMod
conf ← getConfig
case guessTypeByFileName (cnfExtToMIMEType conf) path of
when sendContent
$ liftIO (LBS.readFile path) ≫= putChunks
--- |@'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 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 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
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
+-- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
+-- and its subdirectories on the filesystem to the resource tree. Thus
+-- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
+-- sense.
--
-- 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 ∷ FilePath → Resource
staticDir path
- = emptyResource {
- resIsGreedy = True
- , resGet = Just $ handleStaticDir True path
- , resHead = Just $ handleStaticDir False path
+ = (∅) {
+ resGet = Just $ handleStaticDir True path
+ , resHead = Just $ handleStaticDir False path
}
-- TODO: implement directory listing.
-handleStaticDir ∷ Bool → FilePath → Resource ()
+handleStaticDir ∷ Bool → FilePath → Rsrc ()
handleStaticDir sendContent basePath
= do extraPath ← getPathInfo
securityCheck extraPath
handleStaticFile sendContent path
where
dec8 ∷ ByteString → String
- dec8 = T.unpack ∘ T.decodeUtf8
+ dec8 = cs ∘ T.decodeUtf8
securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
securityCheck pathElems
projects / Lucu.git / blobdiff