, abortPage
)
where
-import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Control.Concurrent.STM
import Text.XML.HXT.Arrow.XmlState
data Abortion = Abortion {
- aboStatus :: !StatusCode
- , aboHeaders :: !Headers
- , aboMessage :: !(Maybe Text)
+ aboStatus ∷ !StatusCode
+ , aboHeaders ∷ !Headers
+ , aboMessage ∷ !(Maybe Text)
} deriving (Eq, Show, Typeable)
instance Exception Abortion
-- > abort MovedPermanently
-- > [("Location", "http://example.net/")]
-- > (Just "It has been moved to example.net")
-abort :: MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
+abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
{-# INLINE abort #-}
abort status headers
= liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)
-- |This is similar to 'abort' but computes it with
-- 'System.IO.Unsafe.unsafePerformIO'.
-abortPurely :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
+abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
{-# INLINE abortPurely #-}
abortPurely status headers
= throw ∘ Abortion status (toHeaders headers)
-- |Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a 'Control.Monad.STM.STM' monad.
-abortSTM :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
+abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
{-# INLINE abortSTM #-}
abortSTM status headers
= throwSTM ∘ Abortion status (toHeaders headers)
-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
-abortA :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
+abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
{-# INLINE abortA #-}
abortA = proc (status, (headers, msg)) →
- returnA ⤙ abortPurely status headers msg
+ arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
-abortPage :: Config → Maybe Request → Response → Abortion → Lazy.Text
+abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text
abortPage conf reqM res abo
= case aboMessage abo of
Just msg
#-}
module Network.HTTP.Lucu.DefaultPage
( getDefaultPage
- , writeDefaultPage
+ , defaultPageContentType
, mkDefaultPage
)
where
-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
+import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy as Lazy
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.URI hiding (path)
in
Lazy.pack xmlStr
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage (Interaction {..})
- -- Content-Type が正しくなければ補完できない。
- = do res ← readTVar itrResponse
- when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
- $ do let page = getDefaultPage itrConfig itrRequest res
- putTMVar itrBodyToSend (BB.fromLazyText page)
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
{-# INLINEABLE mkDefaultPage #-}
import qualified Data.ByteString as BS
import Data.Map (Map)
import qualified Data.Map as M
+import qualified Data.Map.Unicode as M
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
= case getHeaders a of
Headers m → M.lookup key m
+ hasHeader ∷ CIAscii → a → Bool
+ {-# INLINE hasHeader #-}
+ hasHeader key a
+ = case getHeaders a of
+ Headers m → key M.∈ m
+
getCIHeader ∷ CIAscii → a → Maybe CIAscii
{-# INLINE getCIHeader #-}
getCIHeader key a
, InteractionQueue
, newInteractionQueue
, newInteraction
- , defaultPageContentType
, setResponseStatus
)
where
import Blaze.ByteString.Builder (Builder)
import Control.Concurrent.STM
-import Data.Ascii (Ascii)
import qualified Data.ByteString as BS
+import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
import Data.Text (Text)
import Network.Socket
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
, itrWillChunkBody ∷ !(TVar Bool)
, itrWillDiscardBody ∷ !(TVar Bool)
, itrWillClose ∷ !(TVar Bool)
+ , itrResponseHasCType ∷ !(TVar Bool)
, itrBodyToSend ∷ !(TMVar Builder)
- , itrSentNoBodySoFar ∷ !(TVar Bool)
, itrState ∷ !(TVar InteractionState)
}
newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
-defaultPageContentType ∷ Ascii
-defaultPageContentType = "application/xhtml+xml"
-
newInteraction ∷ Config
→ PortNumber
→ SockAddr
res = Response {
resVersion = HttpVersion 1 1
, resStatus = arInitialStatus ar
- , resHeaders = singleton "Content-Type" defaultPageContentType
+ , resHeaders = (∅)
}
reqBodyWanted ← newTVarIO 0
receivedBody ← newTVarIO S.empty
receivedBodyLen ← newTVarIO 0
- response ← newTVarIO res
- willChunkBody ← newTVarIO False
- willDiscardBody ← newTVarIO (arWillDiscardBody ar)
- willClose ← newTVarIO (arWillClose ar)
- bodyToSend ← newEmptyTMVarIO
- sentNoBodySoFar ← newTVarIO True
+ response ← newTVarIO res
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO (arWillDiscardBody ar)
+ willClose ← newTVarIO (arWillClose ar)
+ bodyToSend ← newEmptyTMVarIO
+ responseHasCType ← newTVarIO False
- state ← newTVarIO ExaminingRequest
+ state ← newTVarIO ExaminingRequest
return Interaction {
itrConfig = conf
, itrWillChunkBody = willChunkBody
, itrWillDiscardBody = willDiscardBody
, itrWillClose = willClose
+ , itrResponseHasCType = responseHasCType
, itrBodyToSend = bodyToSend
- , itrSentNoBodySoFar = sentNoBodySoFar
, itrState = state
}
mtMajor ∷ !CIAscii
, mtMinor ∷ !CIAscii
, mtParams ∷ !(Map CIAscii Text)
- } deriving (Eq, Show)
+ } deriving (Eq)
+
+instance Show MIMEType where
+ show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
-- |Construct a 'MIMEType' without any parameters.
mkMIMEType ∷ CIAscii → CIAscii → MIMEType
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
+import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
-- |Guess the MIME Type of file.
guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
guessTypeByFileName extMap fpath
- = let ext = T.pack $ takeExtension fpath
- in
- M.lookup ext extMap
+ = case takeExtension fpath of
+ [] → Nothing
+ (_:ext) → M.lookup (T.pack ext) extMap
-- |Read an Apache mime.types and parse it.
parseExtMapFile ∷ FilePath → IO ExtMap
parseExtMapFile fpath
= do file ← B.readFile fpath
case LP.parse extMapP file of
- LP.Done _ xs → return $ compile xs
- LP.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
+ LP.Done _ xs
+ → case compile xs of
+ Right m → return m
+ Left e → fail (concat [ "Duplicate extension \""
+ , show e
+ , "\" in: "
+ , fpath
+ ])
+ LP.Fail _ _ e
+ → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
extMapP ∷ Parser [ (MIMEType, [Text]) ]
extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
_ ← char '\x0A'
return Nothing
-compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType
-compile = M.fromList ∘ concat ∘ map tr
+compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
+compile = go (∅) ∘ concat ∘ map tr
where
- tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ]
- tr (mime, exts) = [ (ext, mime) | ext ← exts ]
+ tr ∷ (v, [k]) → [(k, v)]
+ tr (v, ks) = [(k, v) | k ← ks]
+
+ go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v)
+ go m [] = Right m
+ go m ((k, v):xs)
+ = case M.insertLookupWithKey' f k v m of
+ (Nothing, m') → go m' xs
+ (Just v0, _ ) → Left (k, v0, v)
+
+ f ∷ k → v → v → v
+ f _ _ = id
-- |@'serializeExtMap' extMap moduleName variableName@ generates a
-- Haskell source code which contains the following things:
, completeUnconditionalHeaders
)
where
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Monoid.Unicode
import Data.Time
import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Response
import Prelude.Unicode
-{-
- TODO: Tanslate this memo into English. It doesn't make sense to
- non-Japanese speakers.
-
- * Response が未設定なら、200 OK にする。
-
- * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
-
- * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
-
- * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
- する。
-
- * Content-Length があれば、それを削除する。Transfer-Encoding があって
- も削除する。
-
- * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
- chunked に設定する。
-
- * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
- 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
- する。
-
- * body を持つ事が出來ない時、body 破棄フラグを立てる。
-
- * Connection: close が設定されてゐる時、切斷フラグを立てる。
-
- * 切斷フラグが立ってゐる時、Connection: close を設定する。
-
- * Server が無ければ設定。
-
- * Date が無ければ設定。
-
--}
-
postprocess ∷ Interaction → STM ()
-postprocess (Interaction {..})
- = do res ← readTVar itrResponse
- let sc = resStatus res
-
- unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
- $ abortSTM InternalServerError []
- $ Just
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
- ⊕ printStatusCode sc
-
- when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
- $ abortSTM InternalServerError []
- $ Just
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "The status was "
- ⊕ printStatusCode sc
- ⊕ A.toAsciiBuilder " but no Allow header."
-
- when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
- $ abortSTM InternalServerError []
- $ Just
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "The status code was "
- ⊕ printStatusCode sc
- ⊕ A.toAsciiBuilder " but no Location header."
+postprocess itr@(Interaction {..})
+ = do abortOnCertainConditions itr
+ writeDefaultPageIfNeeded itr
case itrRequest of
- Just req → postprocessWithRequest sc req
+ Just req → postprocessWithRequest itr req
Nothing → return ()
- -- itrResponse の内容は relyOnRequest によって變へられてゐる可
- -- 能性が高い。
- do oldRes ← readTVar itrResponse
- newRes ← unsafeIOToSTM
- $ completeUnconditionalHeaders itrConfig oldRes
- writeTVar itrResponse newRes
+ updateResIO itr $ completeUnconditionalHeaders itrConfig
+
+abortOnCertainConditions ∷ Interaction → STM ()
+abortOnCertainConditions (Interaction {..})
+ = readTVar itrResponse ≫= go
where
- postprocessWithRequest ∷ StatusCode → Request → STM ()
- postprocessWithRequest sc (Request {..})
- = do let canHaveBody = if reqMethod ≡ HEAD then
- False
- else
- (¬) (isInformational sc ∨
- sc ≡ NoContent ∨
- sc ≡ ResetContent ∨
- sc ≡ NotModified )
-
- updateRes $ deleteHeader "Content-Length"
- updateRes $ deleteHeader "Transfer-Encoding"
-
- cType ← readHeader "Content-Type"
- when (cType ≡ Nothing)
- $ updateRes $ setHeader "Content-Type" defaultPageContentType
-
- if canHaveBody then
- when (reqVersion ≡ HttpVersion 1 1)
- $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
- writeTVar itrWillChunkBody True
- else
- -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
- when (reqMethod ≢ HEAD)
- $ do updateRes $ deleteHeader "Content-Type"
- updateRes $ deleteHeader "Etag"
- updateRes $ deleteHeader "Last-Modified"
-
- conn ← readCIHeader "Connection"
- case conn of
- Nothing → return ()
- Just value → when (value ≡ "close")
- $ writeTVar itrWillClose True
-
- willClose ← readTVar itrWillClose
- when willClose
- $ updateRes $ setHeader "Connection" "close"
-
- when (reqMethod ≡ HEAD ∨ not canHaveBody)
- $ writeTVar itrWillDiscardBody True
-
- readHeader ∷ CIAscii → STM (Maybe Ascii)
- {-# INLINE readHeader #-}
- readHeader k = getHeader k <$> readTVar itrResponse
-
- readCIHeader ∷ CIAscii → STM (Maybe CIAscii)
- {-# INLINE readCIHeader #-}
- readCIHeader k = getCIHeader k <$> readTVar itrResponse
-
- updateRes ∷ (Response → Response) → STM ()
- {-# INLINE updateRes #-}
- updateRes f
- = do old ← readTVar itrResponse
- writeTVar itrResponse (f old)
+ go ∷ Response → STM ()
+ go res@(Response {..})
+ = do unless (any (\ p → p resStatus) [ isSuccessful
+ , isRedirection
+ , isError
+ ])
+ $ abort'
+ $ A.toAsciiBuilder "Inappropriate status code for a response: "
+ ⊕ printStatusCode resStatus
+
+ when ( resStatus ≡ MethodNotAllowed ∧
+ hasHeader "Allow" res )
+ $ abort'
+ $ A.toAsciiBuilder "The status was "
+ ⊕ printStatusCode resStatus
+ ⊕ A.toAsciiBuilder " but no \"Allow\" header."
+
+ when ( resStatus ≢ NotModified ∧
+ isRedirection resStatus ∧
+ hasHeader "Location" res )
+ $ abort'
+ $ A.toAsciiBuilder "The status code was "
+ ⊕ printStatusCode resStatus
+ ⊕ A.toAsciiBuilder " but no Location header."
+
+ abort' ∷ AsciiBuilder → STM ()
+ abort' = abortSTM InternalServerError []
+ ∘ Just
+ ∘ A.toText
+ ∘ A.fromAsciiBuilder
+
+postprocessWithRequest ∷ Interaction → Request → STM ()
+postprocessWithRequest itr@(Interaction {..}) (Request {..})
+ = do willDiscardBody ← readTVar itrWillDiscardBody
+ canHaveBody ← if willDiscardBody then
+ return False
+ else
+ resCanHaveBody <$> readTVar itrResponse
+
+ updateRes itr
+ $ deleteHeader "Content-Length"
+ ∘ deleteHeader "Transfer-Encoding"
+
+ if canHaveBody then
+ do when (reqVersion ≡ HttpVersion 1 1)
+ $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
+ writeTVar itrWillChunkBody True
+ writeDefaultPageIfNeeded itr
+ else
+ do writeTVar itrWillDiscardBody True
+ -- These headers make sense for HEAD requests even
+ -- when there won't be a response entity body.
+ when (reqMethod ≢ HEAD)
+ $ updateRes itr
+ $ deleteHeader "Content-Type"
+ ∘ deleteHeader "Etag"
+ ∘ deleteHeader "Last-Modified"
+
+ hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
+ willClose ← readTVar itrWillClose
+ when (hasConnClose ∧ (¬) willClose)
+ $ writeTVar itrWillClose True
+ when ((¬) hasConnClose ∧ willClose)
+ $ writeHeader itr "Connection" (Just "close")
+
+writeDefaultPageIfNeeded ∷ Interaction → STM ()
+writeDefaultPageIfNeeded itr@(Interaction {..})
+ = do resHasCType ← readTVar itrResponseHasCType
+ unless resHasCType
+ $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
+ res ← readTVar itrResponse
+ let page = getDefaultPage itrConfig itrRequest res
+ putTMVar itrBodyToSend (BB.fromLazyText page)
+
+writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
+{-# INLINE writeHeader #-}
+writeHeader itr k v
+ = case v of
+ Just v' → updateRes itr $ setHeader k v'
+ Nothing → updateRes itr $ deleteHeader k
+
+readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+{-# INLINE readCIHeader #-}
+readCIHeader (Interaction {..}) k
+ = getCIHeader k <$> readTVar itrResponse
+
+updateRes ∷ Interaction → (Response → Response) → STM ()
+{-# INLINE updateRes #-}
+updateRes (Interaction {..}) f
+ = do old ← readTVar itrResponse
+ writeTVar itrResponse (f old)
+
+updateResIO ∷ Interaction → (Response → IO Response) → STM ()
+{-# INLINE updateResIO #-}
+updateResIO (Interaction {..}) f
+ = do old ← readTVar itrResponse
+ new ← unsafeIOToSTM $ f old
+ writeTVar itrResponse new
completeUnconditionalHeaders ∷ Config → Response → IO Response
completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
examineBodyLength
= do req ← gets (fromJust ∘ arRequest)
len ← gets arReqBodyLength
- if reqHasBody req then
+ if reqMustHaveBody req then
-- POST and PUT requests must have an entity body.
when (isNothing len)
$ setStatus LengthRequired
module Network.HTTP.Lucu.Request
( Method(..)
, Request(..)
- , reqHasBody
+ , reqMustHaveBody
, requestP
)
where
deriving (Eq, Show)
instance HasHeaders Request where
+ {-# INLINE getHeaders #-}
getHeaders = reqHeaders
+ {-# INLINE setHeaders #-}
setHeaders req hdr = req { reqHeaders = hdr }
-- |Returns 'True' iff the 'Request' must have an entity body.
-reqHasBody ∷ Request → Bool
-reqHasBody (reqMethod → m)
- = m ≡ POST ∨ m ≡ PUT
+reqMustHaveBody ∷ Request → Bool
+{-# INLINEABLE reqMustHaveBody #-}
+reqMustHaveBody (reqMethod → m)
+ | m ≡ POST = True
+ | m ≡ PUT = True
+ | otherwise = False
requestP ∷ Parser Request
requestP = do skipMany crlf
import Data.Text (Text)
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
-import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
= do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
atomically $
do writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
→ STM (IO ())
acceptSemanticallyInvalidRequest ctx itr input
= do writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
return $ acceptRequest ctx input
= do atomically $
do setResponseStatus itr NotFound
writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
acceptRequest ctx input
= do let itr = oldItr { itrResourcePath = Just rsrcPath }
atomically $ enqueue ctx itr
do _ ← runResource rsrcDef itr
- if reqHasBody $ fromJust $ itrRequest itr then
+ if reqMustHaveBody $ fromJust $ itrRequest itr then
observeRequest ctx itr input
else
acceptRequest ctx input
do setResponseStatus itr BadRequest
writeTVar (itrWillClose itr) True
writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
observeNonChunkedRequest ∷ HandleLike h
, driftTo -- private
)
where
-import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
import Data.List
import qualified Data.Map as M
import Data.Maybe
-import Data.Monoid
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Text (Text)
import Network.HTTP.Lucu.Authorization
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ContentCoding
-import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.ETag
import qualified Network.HTTP.Lucu.Headers as H
import Network.HTTP.Lucu.HttpVersion
input limit
= do driftTo GettingBody
itr ← getInteraction
- chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
$ do res ← readTVar $ itrResponse itr
let res' = H.setHeader name value res
writeTVar (itrResponse itr) res'
+ when (name ≡ "Content-Type")
+ $ writeTVar (itrResponseHasCType itr) True
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
-setContentType
- = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+{-# INLINE setContentType #-}
+setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
-- | Write a 'Lazy.ByteString' to the response body, and then transit
-- to the /Done/ state. It is safe to apply 'output' to an infinite
-- string, such as the lazy stream of \/dev\/random.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
output str = outputChunk str *> driftTo Done
-- | Write a 'Lazy.ByteString' to the response body. This action can
-- be repeated as many times as you want. It is safe to apply
-- 'outputChunk' to an infinite string.
+--
+-- Note that you must first set the \"Content-Type\" response header
+-- before applying this function. See: 'setContentType'
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk str
= do driftTo DecidingBody
itr ← getInteraction
liftIO $ atomically
- $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
- unless (Lazy.null str)
- $ writeTVar (itrSentNoBodySoFar itr) False
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。
-
--}
+ $ do hasCType ← readTVar $ itrResponseHasCType itr
+ unless hasCType
+ $ abortSTM InternalServerError []
+ $ Just "outputChunk: Content-Type has not been set."
+ putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
driftTo ∷ InteractionState → Resource ()
driftTo newState
where
throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
throwStateError Done DecidingBody
- = fail "It makes no sense to output something after finishing to output."
+ = fail "It makes no sense to output something after finishing outputs."
throwStateError old new
= fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
= writeTVar itrReqBodyWasteAll True
drift itr DecidingHeader _
= postprocess itr
- drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBodySoFar
- when bodyIsNull
- $ writeDefaultPage itr
drift _ _ _
= return ()
, runResource
)
where
-import Control.Arrow
+import Control.Arrow
import Control.Applicative
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as LT
-import Data.List
+import Data.List
import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Maybe
+import Data.Map (Map)
+import Data.Maybe
import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers (fromHeaders)
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Utils
-import Network.URI hiding (path)
-import System.IO
-import Prelude hiding (catch)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers (fromHeaders)
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Utils
+import Network.URI hiding (path)
+import System.IO
+import Prelude hiding (catch)
import Prelude.Unicode
if state ≤ DecidingHeader then
flip runRes itr $
do setStatus $ aboStatus abo
+ setHeader "Content-Type" defaultPageContentType
mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
else
- do when (cnfDumpTooLateAbortionToStderr itrConfig)
- $ hPutStrLn stderr $ show abo
- atomically $ writeTVar itrWillClose True
+ when (cnfDumpTooLateAbortionToStderr itrConfig)
+ $ hPutStrLn stderr $ show abo
runRes (driftTo Done) itr
-- |Definition of things related on HTTP response.
module Network.HTTP.Lucu.Response
( StatusCode(..)
- , Response(..)
, printStatusCode
+
+ , Response(..)
+ , resCanHaveBody
, printResponse
+
, isInformational
, isSuccessful
, isRedirection
, isError
, isClientError
, isServerError
+
, statusCode
)
where
-- |Convert a 'StatusCode' to 'AsciiBuilder'.
printStatusCode ∷ StatusCode → AsciiBuilder
+{-# INLINEABLE printStatusCode #-}
printStatusCode (statusCode → (# num, msg #))
= ( show3 num ⊕
A.toAsciiBuilder " " ⊕
} deriving (Show, Eq)
instance HasHeaders Response where
+ {-# INLINE getHeaders #-}
getHeaders = resHeaders
+ {-# INLINE setHeaders #-}
setHeaders res hdr = res { resHeaders = hdr }
+-- |Returns 'True' iff a given 'Response' allows the existence of
+-- response entity body.
+resCanHaveBody ∷ Response → Bool
+{-# INLINEABLE resCanHaveBody #-}
+resCanHaveBody (Response {..})
+ | isInformational resStatus = False
+ | resStatus ≡ NoContent = False
+ | resStatus ≡ ResetContent = False
+ | resStatus ≡ NotModified = False
+ | otherwise = True
+
-- |Convert a 'Response' to 'AsciiBuilder'.
printResponse ∷ Response → AsciiBuilder
+{-# INLINEABLE printResponse #-}
printResponse (Response {..})
= printHttpVersion resVersion ⊕
A.toAsciiBuilder " " ⊕
A.toAsciiBuilder "\x0D\x0A" ⊕
printHeaders resHeaders
--- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
+-- |@'isInformational' sc@ returns 'True' iff @sc < 200@.
isInformational ∷ StatusCode → Bool
-isInformational = doesMeet (< 200)
+{-# INLINE isInformational #-}
+isInformational = satisfy (< 200)
--- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@.
+-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@.
isSuccessful ∷ StatusCode → Bool
-isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300)
+{-# INLINE isSuccessful #-}
+isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
--- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@.
+-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@.
isRedirection ∷ StatusCode → Bool
-isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400)
+{-# INLINE isRedirection #-}
+isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
--- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
+-- |@'isError' sc@ returns 'True' iff @400 <= sc@
isError ∷ StatusCode → Bool
-isError = doesMeet (≥ 400)
+{-# INLINE isError #-}
+isError = satisfy (≥ 400)
--- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@.
+-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@.
isClientError ∷ StatusCode → Bool
-isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500)
+{-# INLINE isClientError #-}
+isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
--- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@.
+-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@.
isServerError ∷ StatusCode → Bool
-isServerError = doesMeet (≥ 500)
+{-# INLINE isServerError #-}
+isServerError = satisfy (≥ 500)
-doesMeet ∷ (Int → Bool) → StatusCode → Bool
-{-# INLINE doesMeet #-}
-doesMeet p (statusCode → (# num, _ #)) = p num
+satisfy ∷ (Int → Bool) → StatusCode → Bool
+{-# INLINE satisfy #-}
+satisfy p (statusCode → (# num, _ #)) = p num
-- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
-- representation of @sc@.
statusCode ∷ StatusCode → (# Int, Ascii #)
+{-# INLINEABLE statusCode #-}
statusCode Continue = (# 100, "Continue" #)
statusCode SwitchingProtocols = (# 101, "Switching Protocols" #)
audio/mpeg mpga mp2 mp3
audio/x-ac3 ac3
audio/x-aiff aif aiff aifc
-audio/x-au au snd
audio/x-ircam sf
audio/x-flac flac
audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm
text/rtf rtf
text/sgml sgml sgm
text/tab-separated-values tsv
-text/uri-list ram
+text/uri-list uni unis uri uris
text/vnd.wap.wml wml
text/vnd.wap.wmlscript wmls
+text/x-c c h
+text/x-c++ cc cpp cxx hpp hxx
text/x-cabal cabal
-text/x-haskell hs
+text/x-haskell hs hsc lhs
text/x-setext etx
video/mp4 mp4
video/mpeg mpeg mpg mpe
str3 ← inputChunk 3
setContentType $ parseMIMEType "text/hello"
output ("[" ⊕ str1 ⊕ " - " ⊕ str2 ⊕ "#" ⊕ str3 ⊕ "]")
- }
\ No newline at end of file
+ }
projects / Lucu.git / commitdiff