From: PHO Date: Sat, 12 Nov 2011 09:10:47 +0000 (+0900) Subject: Don't use the unix package at all. X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=46ea3a6;p=Lucu.git Don't use the unix package at all. Ditz-issue: ce2851ba49c154838b48e56ecf4c01840e4c1b7c --- diff --git a/Lucu.cabal b/Lucu.cabal index 604fc27..e254dbd 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -53,22 +53,22 @@ Library base-unicode-symbols == 0.2.*, base64-bytestring == 0.1.*, blaze-builder == 0.3.*, - blaze-textual == 0.2.*, bytestring == 0.9.*, containers == 0.4.*, containers-unicode-symbols == 0.3.*, + directory == 1.1.*, filepath == 1.2.*, hxt == 9.1.*, mtl == 2.0.*, network == 2.3.*, + old-time == 1.0.*, stm == 2.2.*, stringsearch == 0.3.*, template-haskell == 2.5.*, text == 0.11.*, time == 1.2.*, time-http == 0.2.*, - transformers == 0.2.*, - unix == 2.4.* + transformers == 0.2.* Exposed-Modules: Network.HTTP.Lucu diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 595403a..c8a21b7 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -20,16 +20,11 @@ import Network.HTTP.Lucu.RequestReader import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.ResponseWriter import Network.HTTP.Lucu.SocketLike as SL -import System.Posix.Signals -- |This is the entry point of Lucu httpd. It listens to a socket and -- waits for clients. 'runHttpd' never stops by itself so the only way -- to stop it is to raise an exception in the thread running it. -- --- Note that 'runHttpd' automatically makes SIGPIPE be ignored by --- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can --- hardly cause a problem though. --- -- Example: -- -- > {-# LANGUAGE OverloadedStrings #-} @@ -51,8 +46,7 @@ import System.Posix.Signals runHttpd ∷ Config → ResTree → [FallbackHandler] → IO () runHttpd cnf tree fbs = withSocketsDo $ - do void $ installHandler sigPIPE Ignore Nothing - let launchers + do let launchers = catMaybes [ do scnf ← cnfSSLConfig cnf addr ← cnfServerV4Addr cnf diff --git a/Network/HTTP/Lucu/Implant.hs b/Network/HTTP/Lucu/Implant.hs index f80ac99..90c83f2 100644 --- a/Network/HTTP/Lucu/Implant.hs +++ b/Network/HTTP/Lucu/Implant.hs @@ -22,14 +22,13 @@ import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.SHA import Data.Maybe import Data.Time -import Data.Time.Clock.POSIX import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.MIMEType hiding (mimeType) import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.MIMEType.TH +import Network.HTTP.Lucu.Utils import Prelude.Unicode -import System.Posix.Files data Input = Input { @@ -77,13 +76,7 @@ openInput fpath ctype etag lastModified ∷ FilePath → IO UTCTime lastModified "-" = getCurrentTime -lastModified fpath = ( posixSecondsToUTCTime - ∘ fromRational - ∘ toRational - ∘ modificationTime - ) - <$> - getFileStatus fpath +lastModified fpath = getLastModified fpath openInputFile ∷ FilePath → IO L.ByteString openInputFile "-" = L.getContents diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 97b2cbe..d1420ba 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -450,7 +450,7 @@ foundTimeStamp timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError - "Illegal computation of foundTimeStamp for POST request." + "Illegal call of foundTimeStamp for POST request." let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then @@ -458,7 +458,6 @@ foundTimeStamp timeStamp else fromStatusCode PreconditionFailed - -- If-Modified-Since があればそれを見る。 ifModSince ← getHeader "If-Modified-Since" case ifModSince of Just str → case HTTP.fromAscii str of @@ -467,11 +466,11 @@ foundTimeStamp timeStamp $ abort $ mkAbortion' statusForIfModSince $ "The entity has not been modified since " ⊕ A.toText str - Left _ - → return () -- 不正な時刻は無視 + Left e + → abort $ mkAbortion' BadRequest + $ "Malformed If-Modified-Since: " ⊕ T.pack e Nothing → return () - -- If-Unmodified-Since があればそれを見る。 ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of Just str → case HTTP.fromAscii str of @@ -480,8 +479,9 @@ foundTimeStamp timeStamp $ abort $ mkAbortion' PreconditionFailed $ "The entity has not been modified since " ⊕ A.toText str - Left _ - → return () -- 不正な時刻は無視 + Left e + → abort $ mkAbortion' BadRequest + $ "Malformed If-Unmodified-Since: " ⊕ T.pack e Nothing → return () driftTo ReceivingBody diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index ffda4cf..39ff39c 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -8,35 +8,28 @@ 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.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 hiding (mimeType) import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.MIMEType.TH 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 -- @fpath@ on the filesystem. @@ -52,27 +45,17 @@ octetStream = [mimeType| application/octet-stream |] handleStaticFile ∷ Bool → FilePath → Resource () handleStaticFile sendContent path - = do exists ← liftIO $ fileExist path + = do exists ← liftIO $ doesFileExist path unless exists foundNoEntity' - readable ← liftIO $ fileAccess path True False False - unless readable - $ abort - $ mkAbortion Forbidden [] Nothing - - stat ← liftIO $ getFileStatus path - when (isDirectory stat) + perms ← liftIO $ getPermissions path + unless (readable perms) $ abort $ mkAbortion Forbidden [] Nothing - -- FIXME: Forget about ETags of a static file. - 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 @@ -82,33 +65,6 @@ handleStaticFile sendContent path 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'. diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 18370fa..c07c9c9 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -11,6 +11,9 @@ module Network.HTTP.Lucu.Utils , parseWWWFormURLEncoded , splitPathInfo , trim + + , getLastModified + , liftByteString , liftLazyByteString , liftAscii @@ -20,6 +23,7 @@ module Network.HTTP.Lucu.Utils , liftUTCTime ) where +import Control.Applicative import Control.Monad import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A @@ -35,11 +39,14 @@ import Data.Ratio import Data.Text (Text) import qualified Data.Text as T import Data.Time +import Data.Time.Clock.POSIX import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax import Network.URI import Prelude hiding (last) import Prelude.Unicode +import System.Directory +import System.Time (ClockTime(..)) -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] @@ -111,6 +118,16 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace +-- |Get the modification time of a given file. +getLastModified ∷ FilePath → IO UTCTime +getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime + where + clockTimeToUTC ∷ ClockTime → UTCTime + clockTimeToUTC (TOD sec picoSec) + = posixSecondsToUTCTime + $ fromRational + $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000) + -- |Convert a 'ByteString' to an 'Exp' representing it as a literal. liftByteString ∷ ByteString → Q Exp liftByteString bs diff --git a/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml b/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml index ccd50f7..a1046c6 100644 --- a/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml +++ b/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml @@ -7,8 +7,8 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted -disposition: +status: :closed +disposition: :fixed creation_time: 2011-10-26 23:18:42.168974 Z references: [] @@ -22,4 +22,12 @@ log_events: - PHO - edited title, description - "" +- - 2011-11-12 08:01:44.320957 Z + - PHO + - changed status from unstarted to in_progress + - "" +- - 2011-11-12 09:10:32.315822 Z + - PHO + - closed with disposition fixed + - Done. git_branch: