getRemoteAddr' ∷ Resource HostName
getRemoteAddr'
= do sa ← getRemoteAddr
- (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
+ (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
return a
-- |Resolve an address to the remote host.
-- |Get the path of this 'Resource' (to be exact,
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
--- action is the exact path in the tree even if the
+-- action is the exact path in the tree even when the
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
--
-- Example:
-- be repeated as many times as you want. It is safe to apply
-- 'outputChunk' to an infinite string.
outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk wholeChunk
+outputChunk str
= do driftTo DecidingBody
itr ← getInteraction
-
- let limit = cnfMaxOutputChunkLength $ itrConfig itr
- when (limit ≤ 0)
- $ abort InternalServerError []
- (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
-
- discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
- unless (discardBody)
- $ sendChunks itr wholeChunk limit
-
- unless (Lazy.null wholeChunk)
- $ liftIO $ atomically $
- writeTVar (itrSentNoBodySoFar itr) False
- where
- sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
- sendChunks itr@(Interaction {..}) str limit
- | Lazy.null str = return ()
- | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
- liftIO $ atomically
- $ putTMVar itrBodyToSend (chunkToBuilder chunk)
- sendChunks itr remaining limit
-
- chunkToBuilder ∷ Lazy.ByteString → Builder
- chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
+ liftIO $ atomically
+ $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
+ unless (Lazy.null str)
+ $ writeTVar (itrSentNoBodySoFar itr) False
{-
{-# LANGUAGE
- OverloadedStrings
+ DoAndIfThenElse
+ , OverloadedStrings
, UnicodeSyntax
#-}
-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
( staticFile
- , handleStaticFile
-
, staticDir
- , handleStaticDir
, generateETagFromFile
)
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
-- @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
-- | @'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)
projects / Lucu.git / commitdiff