From 895341e8b790e969be678c5cfb85c878e321c8fc Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 17 Oct 2011 17:16:11 +0900 Subject: [PATCH] examples/HelloWorld.hs fully works now. Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/Config.hs | 7 -- Network/HTTP/Lucu/Interaction.hs | 4 +- Network/HTTP/Lucu/Resource.hs | 34 ++------ Network/HTTP/Lucu/Resource/Tree.hs | 8 +- Network/HTTP/Lucu/StaticFile.hs | 123 ++++++++++++----------------- cabal-package.mk | 2 +- 6 files changed, 67 insertions(+), 111 deletions(-) diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 5a241b7..4727980 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -62,12 +62,6 @@ data Config = Config { -- guarantee that this value always constrains all the requests. , cnfMaxEntityLength ∷ !Int - -- |The maximum length of chunk to output. This value is used by - -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the - -- chunk length so you can safely output an infinite string (like - -- a lazy stream of \/dev\/random) using those actions. - , cnfMaxOutputChunkLength ∷ !Int - -- | Whether to dump too late abortion to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. , cnfDumpTooLateAbortionToStderr ∷ !Bool @@ -111,7 +105,6 @@ defaultConfig = Config { , cnfSSLConfig = Nothing , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB - , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB , cnfDumpTooLateAbortionToStderr = True , cnfExtToMIMEType = defaultExtensionMap } diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index ac5c1d6..3ecc912 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -96,8 +96,8 @@ newInteraction conf@(Config {..}) port addr cert request response ← newTVarIO res willChunkBody ← newTVarIO False - willDiscardBody ← newTVarIO False - willClose ← newTVarIO False + willDiscardBody ← newTVarIO (arWillDiscardBody ar) + willClose ← newTVarIO (arWillClose ar) bodyToSend ← newEmptyTMVarIO sentNoBodySoFar ← newTVarIO True diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 87d2a33..c754213 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -211,7 +211,7 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction 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. @@ -252,7 +252,7 @@ getRequestVersion = reqVersion <$> getRequest -- |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: @@ -883,33 +883,13 @@ output str = outputChunk str *> driftTo Done -- 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 {- diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 8fbe2bf..11d5b2b 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -144,6 +144,9 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ +-- +-- Note that the request path in an incoming HTTP request is always +-- treated as an URI-encoded UTF-8 string. mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree mkResTree = processRoot ∘ map (first canonicalisePath) where @@ -292,6 +295,7 @@ runResource (ResourceDef {..}) itr@(Interaction {..}) mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo else - when (cnfDumpTooLateAbortionToStderr itrConfig) - $ hPutStrLn stderr $ show abo + do when (cnfDumpTooLateAbortionToStderr itrConfig) + $ hPutStrLn stderr $ show abo + atomically $ writeTVar itrWillClose True runRes (driftTo Done) itr diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index f9e2513..8f93513 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,14 +1,12 @@ {-# LANGUAGE - OverloadedStrings + DoAndIfThenElse + , OverloadedStrings , UnicodeSyntax #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile - , handleStaticFile - , staticDir - , handleStaticDir , generateETagFromFile ) @@ -26,6 +24,7 @@ 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.Tree @@ -38,66 +37,53 @@ import System.Posix.Files -- @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 @@ -117,32 +103,25 @@ generateETagFromFile path -- | @'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) diff --git a/cabal-package.mk b/cabal-package.mk index b2bf655..cc534f4 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -114,7 +114,7 @@ fixme: \( -name '*.c' -or -name '*.h' -or \ -name '*.hs' -or -name '*.lhs' -or \ -name '*.hsc' -or -name '*.cabal' \) \ - -exec egrep -i '(fixme|thinkme)' {} \+ \ + -exec egrep 'FIXME|THINKME|TODO' {} \+ \ || echo 'No FIXME or THINKME found.' lint: -- 2.40.0