From: PHO Date: Tue, 4 Oct 2011 07:58:41 +0000 (+0900) Subject: many changes X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=32a6ebbb18856ab1203e8a114414f235c2abe22b;p=Lucu.git many changes Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 3508a51..46e32a1 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -59,7 +59,7 @@ data Interaction = Interaction { , itrWillClose ∷ !(TVar Bool) , itrBodyToSend ∷ !(TMVar Builder) - , itrBodyIsNull ∷ !(TVar Bool) + , itrSentNoBody ∷ !(TVar Bool) , itrState ∷ !(TVar InteractionState) @@ -111,7 +111,7 @@ newInteraction !conf !port !addr !cert !req willClose ← newTVarIO False bodyToSend ← newEmptyTMVarIO - bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False + sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False state ← newTVarIO ExaminingRequest @@ -145,7 +145,7 @@ newInteraction !conf !port !addr !cert !req , itrWillClose = willClose , itrBodyToSend = bodyToSend - , itrBodyIsNull = bodyIsNull + , itrSentNoBody = sentNoBody , itrState = state diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index a54e040..c8ca45d 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -913,7 +913,7 @@ outputChunk wholeChunk unless (Lazy.null wholeChunk) $ liftIO $ atomically $ - writeItr itrBodyIsNull False itr + writeItr itrSentNoBody False itr where sendChunks ∷ Lazy.ByteString → Int → Resource () sendChunks str limit @@ -977,7 +977,7 @@ driftTo newState = postprocess itr drift itr _ Done - = do bodyIsNull ← readItr itrBodyIsNull id itr + = do bodyIsNull ← readItr itrSentNoBody id itr when bodyIsNull $ writeDefaultPage itr diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 5289f5f..f9e2513 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - BangPatterns + OverloadedStrings , UnicodeSyntax #-} -- | Handling static files on the filesystem. @@ -13,30 +13,35 @@ module Network.HTTP.Lucu.StaticFile , 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.Time.Clock.POSIX -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.Format -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.FilePath.Posix -import System.Posix.Files +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' fpath@ is a 'ResourceDef' which serves the file at -- @fpath@ on the filesystem. -staticFile :: FilePath -> ResourceDef +staticFile ∷ FilePath → ResourceDef staticFile path = ResourceDef { resUsesNativeThread = False , resIsGreedy = False - , resGet = Just $! handleStaticFile path + , resGet = Just $ handleStaticFile path , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -44,39 +49,39 @@ staticFile path } -- | Computation of @'handleStaticFile' fpath@ serves the file at --- @fpath@ on the filesystem. The --- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining +-- @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 --- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use --- 'staticFile' instead of this. -handleStaticFile :: FilePath -> Resource () +-- 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 - = path `seq` - do exists <- liftIO $ fileExist path + = do exists ← liftIO $ fileExist path if exists then -- 存在はした。讀めるかどうかは知らない。 - do stat <- liftIO $ getFileStatus path + do stat ← liftIO $ getFileStatus path if isRegularFile stat then - do readable <- liftIO $ fileAccess path True False False + do readable ← liftIO $ fileAccess path True False False unless readable -- 讀めない $ abort Forbidden [] Nothing -- 讀める - tag <- liftIO $ generateETagFromFile path - let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat + tag ← liftIO $ generateETagFromFile path + let lastMod = posixSecondsToUTCTime + $ fromRational + $ toRational + $ modificationTime stat foundEntity tag lastMod -- MIME Type を推定 - conf <- getConfig + conf ← getConfig case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime + Nothing → return () + Just mime → setContentType mime -- 實際にファイルを讀んで送る - liftIO (B.readFile path) >>= outputLBS + liftIO (B.readFile path) ≫= output else abort Forbidden [] Nothing else @@ -95,30 +100,29 @@ handleStaticFile path -- 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 - = path `seq` - do stat <- getFileStatus path - let inode = fromEnum $! fileID stat - size = fromEnum $! fileSize stat - lastMod = fromEnum $! modificationTime stat - tag = fmtHex False 0 inode - ++ "-" ++ - fmtHex False 0 size - ++ "-" ++ - fmtHex False 0 lastMod - return $! strongETag tag + = 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 --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files --- in @dir@ and its subdirectories on the filesystem to the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. -staticDir :: FilePath -> ResourceDef +-- | @'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 + , resGet = Just $ handleStaticDir path , resHead = Nothing , resPost = Nothing , resPut = Nothing @@ -126,25 +130,21 @@ staticDir path } -- | Computation of @'handleStaticDir' dir@ maps all files in @dir@ --- and its subdirectories on the filesystem to the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The --- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining --- Request/ state before the computation. It will be in the /Done/ --- state after the computation. +-- 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 --- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use --- 'staticDir' instead of this. -handleStaticDir :: FilePath -> Resource () -handleStaticDir !basePath - = do extraPath <- getPathInfo +-- 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 extraPath + let path = basePath joinPath (map T.unpack extraPath) handleStaticFile path where - securityCheck :: Monad m => [String] -> m () - securityCheck !pathElems - = when (any (== "..") pathElems) $ fail ("security error: " - ++ joinWith "/" pathElems) + securityCheck pathElems + = when (any (≡ "..") pathElems) + $ fail ("security error: " ⧺ show pathElems) -- TODO: implement directory listing.