{-# LANGUAGE
    BangPatterns
  , GeneralizedNewtypeDeriving
  , DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
{-# OPTIONS_HADDOCK prune #-}

-- |This is the Resource Monad; monadic actions to define the behavior
-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
-- also a state machine.
-- 
-- Request Processing Flow:
--
--   1. A client issues an HTTP request.
--
--   2. If the URI of it matches to any resource, the corresponding
--      'Resource' Monad starts running on a newly spawned thread.
--
--   3. The 'Resource' Monad looks at the request header, find (or not
--      find) an entity, receive the request body (if any), decide the
--      response header, and decide the response body. This process
--      will be discussed later.
--
--   4. The 'Resource' Monad and its thread stops running. The client
--      may or may not be sending us the next request at this point.
--
-- 'Resource' Monad takes the following states. The initial state is
-- /Examining Request/ and the final state is /Done/.
--
--   [/Examining Request/] In this state, a 'Resource' looks at the
--   request header and thinks about an entity for it. If there is a
--   suitable entity, the 'Resource' tells the system an entity tag
--   and its last modification time ('foundEntity'). If it found no
--   entity, it tells the system so ('foundNoEntity'). In case it is
--   impossible to decide the existence of entity, which is a typical
--   case for POST requests, 'Resource' does nothing in this state.
--
--   [/Getting Body/] A 'Resource' asks the system to receive a
--   request body from client. Before actually reading from the
--   socket, the system sends \"100 Continue\" to the client if need
--   be. When a 'Resource' transits to the next state without
--   receiving all or part of request body, the system still reads it
--   and just throws it away.
--
--   [/Deciding Header/] A 'Resource' makes a decision of status code
--   and response header. When it transits to the next state, the
--   system checks the validness of response header and then write
--   them to the socket.
--
--   [/Deciding Body/] In this state, a 'Resource' asks the system to
--   write some response body to the socket. When it transits to the
--   next state without writing any response body, the system
--   completes it depending on the status code.
--
--   [/Done/] Everything is over. A 'Resource' can do nothing for the
--   HTTP interaction anymore.
--
-- Note that the state transition is one-way: for instance, it is an
-- error to try to read a request body after writing some
-- response. This limitation is for efficiency. We don't want to read
-- the entire request before starting 'Resource', nor we don't want to
-- postpone writing the entire response till the end of 'Resource'
-- computation.

module Network.HTTP.Lucu.Resource
    (
    -- * Types
      Resource
    , FormData(..)
    , runRes -- private

    -- * Actions

    -- ** Getting request header

    -- |These actions can be computed regardless of the current state,
    -- and they don't change the state.
    , getConfig
    , getRemoteAddr
    , getRemoteAddr'
    , getRemoteHost
    , getRemoteCertificate
    , getRequest
    , getMethod
    , getRequestURI
    , getRequestVersion
    , getResourcePath
    , getPathInfo
    , getQueryForm
    , getHeader
    , getAccept
    , getAcceptEncoding
    , isEncodingAcceptable
    , getContentType
    , getAuthorization

    -- ** Finding an entity

    -- |These actions can be computed only in the /Examining Request/
    -- state. After the computation, the 'Resource' transits to
    -- /Getting Body/ state.
    , foundEntity
    , foundETag
    , foundTimeStamp
    , foundNoEntity

    -- ** Getting a request body

    -- |Computation of these actions changes the state to /Getting
    -- Body/.
    , input
    , inputChunk
    , inputForm
    , defaultLimit

    -- ** Setting response headers
    
    -- |Computation of these actions changes the state to /Deciding
    -- Header/.
    , setStatus
    , setHeader
    , redirect
    , setContentType
    , setLocation
    , setContentEncoding
    , setWWWAuthenticate

    -- ** Writing a response body

    -- |Computation of these actions changes the state to /Deciding
    -- Body/.
    , output
    , outputChunk

    , driftTo -- private
    )
    where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.Attoparsec.Char8 as P
import qualified Data.Attoparsec.Lazy  as LP
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy  as Lazy
import Data.Foldable (toList)
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 qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Network.HTTP.Lucu.Abortion
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
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.MultipartForm
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
import OpenSSL.X509
import Prelude.Unicode

-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
-- any 'IO' actions.
newtype Resource a
    = Resource {
        unRes ∷ ReaderT Interaction IO a
      }
    deriving (Applicative, Functor, Monad, MonadIO)

runRes ∷ Resource a → Interaction → IO a
runRes r itr
    = runReaderT (unRes r) itr

getInteraction ∷ Resource Interaction
getInteraction = Resource ask

-- |Get the 'Config' value which is used for the httpd.
getConfig ∷ Resource Config
getConfig = itrConfig <$> getInteraction

-- |Get the 'SockAddr' of the remote host. If you want a string
-- representation instead of 'SockAddr', use 'getRemoteAddr''.
getRemoteAddr ∷ Resource SockAddr
getRemoteAddr = itrRemoteAddr <$> getInteraction

-- |Get the string representation of the address of remote host. If
-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
getRemoteAddr' ∷ Resource HostName
getRemoteAddr'
    = do sa          ← getRemoteAddr
         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
         return a

-- |Resolve an address to the remote host.
getRemoteHost ∷ Resource (Maybe HostName)
getRemoteHost
    = do sa ← getRemoteAddr
         fst <$> (liftIO $ getNameInfo [] True False sa)

-- | Return the X.509 certificate of the client, or 'Nothing' if:
--
--   * This request didn't came through an SSL stream.
--
--   * The client didn't send us its certificate.
--
--   * The 'OpenSSL.Session.VerificationMode' of
--   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
--   'OpenSSL.Session.VerifyPeer'.
getRemoteCertificate ∷ Resource (Maybe X509)
getRemoteCertificate = itrRemoteCert <$> getInteraction

-- |Get the 'Request' value which represents the request header. In
-- general you don't have to use this action.
getRequest ∷ Resource Request
getRequest
    = do itr ← getInteraction
         liftIO $ atomically $ readItr itrRequest fromJust itr

-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
getMethod = reqMethod <$> getRequest

-- |Get the URI of the request.
getRequestURI ∷ Resource URI
getRequestURI = reqURI <$> getRequest

-- |Get the HTTP version of the request.
getRequestVersion ∷ Resource HttpVersion
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
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
--
-- Example:
--
-- > main = let tree = mkResTree [ (["foo"], resFoo) ]
-- >        in runHttpd defaultConfig tree
-- >
-- > resFoo = ResourceDef {
-- >     resIsGreedy = True
-- >   , resGet = Just $ do requestURI   ← getRequestURI
-- >                        resourcePath ← getResourcePath
-- >                        pathInfo     ← getPathInfo
-- >                        -- uriPath requestURI == "/foo/bar/baz"
-- >                        -- resourcePath       == ["foo"]
-- >                        -- pathInfo           == ["bar", "baz"]
-- >                        ...
-- >   , ...
-- >   }
getResourcePath ∷ Resource [Ascii]
getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction

-- |This is an analogy of CGI PATH_INFO. The result is
-- URI-unescaped. It is always @[]@ if the
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
-- 'getResourcePath'.
getPathInfo ∷ Resource [ByteString]
getPathInfo = do rsrcPath ← getResourcePath
                 uri      ← getRequestURI
                 let reqPathStr = uriPath uri
                     reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
                 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                 -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
                 -- ければこの Resource が撰ばれた筈が無い）ので、
                 -- rsrcPath の長さの分だけ削除すれば良い。
                 return $ map C8.pack $ drop (length rsrcPath) reqPath

-- |Assume the query part of request URI as
-- application\/x-www-form-urlencoded, and parse it to pairs of
-- @(name, formData)@. This action doesn't parse the request body. See
-- 'inputForm'. Field names are decoded in UTF-8.
getQueryForm ∷ Resource [(Text, FormData)]
getQueryForm = parse' <$> getRequestURI
    where
      parse' = map toPairWithFormData ∘
               parseWWWFormURLEncoded ∘
               fromJust ∘
               A.fromChars ∘
               drop 1 ∘
               uriQuery

toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
toPairWithFormData (name, value)
    = let fd = FormData {
                 fdFileName = Nothing
               , fdContent  = Lazy.fromChunks [value]
               }
      in (T.decodeUtf8 name, fd)

-- |Get a value of given request header. Comparison of header name is
-- case-insensitive. Note that this action is not intended to be used
-- so frequently: there should be actions like 'getContentType' for
-- every common headers.
getHeader ∷ CIAscii → Resource (Maybe Ascii)
getHeader name
    = H.getHeader name <$> getRequest

-- |Get a list of 'MIMEType' enumerated on header \"Accept\".
getAccept ∷ Resource [MIMEType]
getAccept
    = do acceptM ← getHeader "Accept"
         case acceptM of
           Nothing
               → return []
           Just accept
               → case P.parseOnly p (A.toByteString accept) of
                    Right xs → return xs
                    Left  _  → abort BadRequest []
                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
    where
      p = do xs ← mimeTypeListP
             P.endOfInput
             return xs

-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
-- \"Accept-Encoding\". The list is sorted in descending order by
-- qvalue.
getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
getAcceptEncoding
    = do accEncM ← getHeader "Accept-Encoding"
         case accEncM of
           Nothing
               -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
               -- ので安全の爲 identity が指定された事にする。HTTP/1.1
               -- の場合は何でも受け入れて良い事になってゐるので "*" が
               -- 指定された事にする。
               → do ver ← getRequestVersion
                    case ver of
                      HttpVersion 1 0 → return [("identity", Nothing)]
                      HttpVersion 1 1 → return [("*"       , Nothing)]
                      _               → abort InternalServerError []
                                        (Just "getAcceptEncoding: unknown HTTP version")
           Just ae
               → if ae ≡ "" then
                      -- identity のみが許される。
                      return [("identity", Nothing)]
                  else
                      case P.parseOnly p (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort BadRequest []
                                   (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
    where
      p = do xs ← acceptEncodingListP
             P.endOfInput
             return xs

      toTuple (AcceptEncoding {..})
          = (aeEncoding, aeQValue)

-- |Check whether a given content-coding is acceptable.
isEncodingAcceptable ∷ CIAscii → Resource Bool
isEncodingAcceptable encoding = any f <$> getAcceptEncoding
    where
      f (e, q)
          = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0

-- |Get the header \"Content-Type\" as 'MIMEType'.
getContentType ∷ Resource (Maybe MIMEType)
getContentType
    = do cTypeM ← getHeader "Content-Type"
         case cTypeM of
           Nothing
               → return Nothing
           Just cType
               → case P.parseOnly p (A.toByteString cType) of
                    Right t → return $ Just t
                    Left  _ → abort BadRequest []
                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
    where
      p = do t ← mimeTypeP
             P.endOfInput
             return t

-- |Get the header \"Authorization\" as 'AuthCredential'.
getAuthorization ∷ Resource (Maybe AuthCredential)
getAuthorization
    = do authM ← getHeader "Authorization"
         case authM of
           Nothing
               → return Nothing
           Just auth
               → case P.parseOnly p (A.toByteString auth) of
                    Right ac → return $ Just ac
                    Left  _  → return Nothing
    where
      p = do ac ← authCredentialP
             P.endOfInput
             return ac


{- ExaminingRequest 時に使用するアクション群 -}

-- |Tell the system that the 'Resource' found an entity for the
-- request URI. If this is a GET or HEAD request, a found entity means
-- a datum to be replied. If this is a PUT or DELETE request, it means
-- a datum which was stored for the URI until now. It is an error to
-- compute 'foundEntity' if this is a POST request.
--
-- Computation of 'foundEntity' performs \"If-Match\" test or
-- \"If-None-Match\" test if possible. When those tests fail, the
-- computation of 'Resource' immediately aborts with status \"412
-- Precondition Failed\" or \"304 Not Modified\" depending on the
-- situation.
--
-- If this is a GET or HEAD request, 'foundEntity' automatically puts
-- \"ETag\" and \"Last-Modified\" headers into the response.
foundEntity ∷ ETag → UTCTime → Resource ()
foundEntity !tag !timeStamp
    = do driftTo ExaminingRequest

         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
         when (method ≡ POST)
             $ abort InternalServerError []
               (Just "Illegal computation of foundEntity for a POST request.")
         foundETag tag

         driftTo GettingBody

-- |Tell the system that the 'Resource' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
-- the response.
--
-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundETag ∷ ETag → Resource ()
foundETag !tag
    = do driftTo ExaminingRequest
      
         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader' "ETag" (printETag tag)
         when (method ≡ POST)
              $ abort InternalServerError []
                (Just "Illegal computation of foundETag for POST request.")

         -- If-Match があればそれを見る。
         ifMatch ← getHeader "If-Match"
         case ifMatch of
           Nothing    → return ()
           Just value → if value ≡ "*" then
                            return ()
                        else
                            case P.parseOnly p (A.toByteString value) of
                              Right tags
                                 -- tags の中に一致するものが無ければ
                                 -- PreconditionFailed で終了。
                                 → when ((¬) (any (≡ tag) tags))
                                       $ abort PreconditionFailed []
                                         (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
                              Left _
                                   → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)

         let statusForNoneMatch
                 = if method ≡ GET ∨ method ≡ HEAD then
                       NotModified
                   else
                       PreconditionFailed

         -- If-None-Match があればそれを見る。
         ifNoneMatch ← getHeader "If-None-Match"
         case ifNoneMatch of
           Nothing    → return ()
           Just value → if value ≡ "*" then
                             abort statusForNoneMatch [] (Just "The entity tag matches: *")
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)
                                         $ abort statusForNoneMatch []
                                           (Just $ "The entity tag matches: " ⊕ A.toText value)
                               Left _
                                   → abort BadRequest []
                                     (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)

         driftTo GettingBody
    where
      p = do xs ← eTagListP
             P.endOfInput
             return xs

-- |Tell the system that the 'Resource' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
-- \"If-None-Match\" test. Be aware that any tests based on last
-- modification time are unsafe because it is possible to mess up such
-- tests by modifying the entity twice in a second.
--
-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundTimeStamp ∷ UTCTime → Resource ()
foundTimeStamp timeStamp
    = do driftTo ExaminingRequest

         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
         when (method ≡ POST)
             $ abort InternalServerError []
               (Just "Illegal computation of foundTimeStamp for POST request.")

         let statusForIfModSince
                 = if method ≡ GET ∨ method ≡ HEAD then
                       NotModified
                   else
                       PreconditionFailed

         -- If-Modified-Since があればそれを見る。
         ifModSince ← getHeader "If-Modified-Since"
         case ifModSince of
           Just str → case HTTP.fromAscii str of
                         Right lastTime
                             → when (timeStamp ≤ lastTime)
                               $ abort statusForIfModSince []
                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
                         Left _
                             → return () -- 不正な時刻は無視
           Nothing  → return ()

         -- If-Unmodified-Since があればそれを見る。
         ifUnmodSince ← getHeader "If-Unmodified-Since"
         case ifUnmodSince of
           Just str → case HTTP.fromAscii str of
                         Right lastTime
                             → when (timeStamp > lastTime)
                               $ abort PreconditionFailed []
                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
                         Left _
                             → return () -- 不正な時刻は無視
           Nothing  → return ()

         driftTo GettingBody

-- | Computation of @'foundNoEntity' mStr@ tells the system that the
-- 'Resource' found no entity for the request URI. @mStr@ is an
-- optional error message to be replied to the client.
--
-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
-- test and aborts with status \"412 Precondition Failed\" when it
-- failed. If this is a GET, HEAD, POST or DELETE request,
-- 'foundNoEntity' always aborts with status \"404 Not Found\".
foundNoEntity ∷ Maybe Text → Resource ()
foundNoEntity msgM
    = do driftTo ExaminingRequest

         method ← getMethod
         when (method ≢ PUT)
             $ abort NotFound [] msgM

         -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
         -- If-Match: 條件も滿たさない。
         ifMatch ← getHeader "If-Match"
         when (ifMatch ≢ Nothing)
             $ abort PreconditionFailed [] msgM

         driftTo GettingBody


{- GettingBody 時に使用するアクション群 -}

-- | Computation of @'input' limit@ attempts to read the request body
-- up to @limit@ bytes, and then make the 'Resource' transit to
-- /Deciding Header/ state. When the actual size of body is larger
-- than @limit@ bytes, computation of 'Resource' immediately aborts
-- with status \"413 Request Entity Too Large\". When the request has
-- no body, 'input' returns an empty string.
--
-- @limit@ may be less than or equal to zero. In this case, the
-- default limitation value ('cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
-- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
-- reading from the socket just happens at the computation of 'input',
-- not at the evaluation of the 'Lazy.ByteString'. The same goes for
-- 'inputChunk'.
input ∷ Int → Resource Lazy.ByteString
input limit
    = do driftTo GettingBody
         itr     ← getInteraction
         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
         chunk   ← if hasBody then
                       askForInput itr
                   else
                       do driftTo DecidingHeader
                          return (∅)
         return chunk
    where
      askForInput ∷ Interaction → Resource Lazy.ByteString
      askForInput itr
          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
                   actualLimit = if limit ≤ 0 then
                                     confLimit
                                 else
                                     limit
               when (actualLimit ≤ 0)
                        $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
               -- Reader にリクエスト
               liftIO $ atomically
                      $ do chunkLen ← readItr itrReqChunkLength id itr
                           writeItr itrWillReceiveBody True itr
                           if ((> actualLimit) <$> chunkLen) ≡ Just True then
                               -- 受信前から多過ぎる事が分かってゐる
                               tooLarge actualLimit
                           else
                               writeItr itrReqBodyWanted (Just actualLimit) itr
               -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
               chunk ← liftIO $ atomically
                       $ do chunkLen    ← readItr itrReceivedBodyLen id itr
                            chunkIsOver ← readItr itrReqChunkIsOver  id itr
                            if chunkLen < actualLimit then
                                -- 要求された量に滿たなくて、まだ殘りが
                                -- あるなら再試行。
                                unless chunkIsOver
                                    $ retry
                            else
                                -- 制限値一杯まで讀むやうに指示したのに
                                -- まだ殘ってゐるなら、それは多過ぎる。
                                unless chunkIsOver
                                    $ tooLarge actualLimit
                            -- 成功。itr 内にチャンクを置いたままにする
                            -- とメモリの無駄になるので除去。
                            chunk ← readItr itrReceivedBody seqToLBS itr
                            writeItr itrReceivedBody (∅) itr
                            return chunk

               driftTo DecidingHeader
               return chunk

      tooLarge ∷ Int → STM ()
      tooLarge lim = abortSTM RequestEntityTooLarge []
                     (Just $ "Request body must be smaller than "
                             ⊕ T.pack (show lim) ⊕ " bytes.")

seqToLBS ∷ Seq ByteString → Lazy.ByteString
{-# INLINE seqToLBS #-}
seqToLBS = Lazy.fromChunks ∘ toList
         
-- | Computation of @'inputChunk' limit@ attempts to read a part of
-- request body up to @limit@ bytes. You can read any large request by
-- repeating computation of this action. When you've read all the
-- request body, 'inputChunk' returns an empty string and then make
-- the 'Resource' transit to /Deciding Header/ state.
--
-- @limit@ may be less than or equal to zero. In this case, the
-- default limitation value ('cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
-- should use it whenever possible.
inputChunk ∷ Int → Resource Lazy.ByteString
inputChunk limit
    = do driftTo GettingBody
         itr     ← getInteraction
         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
         chunk   ← if hasBody then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
                           return (∅)
         return chunk
    where
      askForInput ∷ Interaction → Resource Lazy.ByteString
      askForInput itr
          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
                   actualLimit = if limit < 0 then
                                      confLimit
                                  else
                                      limit
               when (actualLimit <= 0)
                        $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
               -- Reader にリクエスト
               liftIO $ atomically
                      $ do writeItr itrReqBodyWanted (Just actualLimit) itr
                           writeItr itrWillReceiveBody True itr
               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
               chunk ← liftIO $ atomically
                       $ do chunkLen ← readItr itrReceivedBodyLen id itr
                            -- 要求された量に滿たなくて、まだ殘りがある
                            -- なら再試行。
                            when (chunkLen < actualLimit)
                                $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
                                     unless chunkIsOver
                                         $ retry
                            -- 成功
                            chunk ← readItr itrReceivedBody seqToLBS itr
                            writeItr itrReceivedBody (∅) itr
                            return chunk
               when (Lazy.null chunk)
                   $ driftTo DecidingHeader
               return chunk

-- | Computation of @'inputForm' limit@ attempts to read the request
-- body with 'input' and parse it as
-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
-- the request header \"Content-Type\" is neither of them, 'inputForm'
-- makes 'Resource' abort with status \"415 Unsupported Media
-- Type\". If the request has no \"Content-Type\", it aborts with
-- \"400 Bad Request\".
--
-- Field names in @multipart\/form-data@ will be precisely decoded in
-- accordance with RFC 2231. On the other hand,
-- @application\/x-www-form-urlencoded@ says nothing about the
-- encoding of field names, so they'll always be decoded in UTF-8.
inputForm ∷ Int → Resource [(Text, FormData)]
inputForm limit
    = do cTypeM ← getContentType
         case cTypeM of
           Nothing
               → abort BadRequest [] (Just "Missing Content-Type")
           Just (MIMEType "application" "x-www-form-urlencoded" _)
               → readWWWFormURLEncoded
           Just (MIMEType "multipart" "form-data" params)
               → readMultipartFormData params
           Just cType
               → abort UnsupportedMediaType []
                 $ Just
                 $ A.toText
                 $ A.fromAsciiBuilder
                 $ A.toAsciiBuilder "Unsupported media type: "
                 ⊕ printMIMEType cType
    where
      readWWWFormURLEncoded
          = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
            <$>
            (bsToAscii =≪ input limit)

      bsToAscii bs
          = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
              Just a  → return a
              Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")

      readMultipartFormData params
          = do case M.lookup "boundary" params of
                 Nothing
                     → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
                 Just boundary
                     → do src ← input limit
                          b   ← case A.fromText boundary of
                                   Just b  → return b
                                   Nothing → abort BadRequest []
                                             (Just $ "Malformed boundary: " ⊕ boundary)
                          case LP.parse (p b) src of
                            LP.Done _ formList
                                → return formList
                            _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
          where
            p b = do xs ← multipartFormP b
                     P.endOfInput
                     return xs

-- | This is just a constant @-1@. It's better to say @'input'
-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
-- the same.
defaultLimit ∷ Int
defaultLimit = (-1)


{- DecidingHeader 時に使用するアクション群 -}

-- | Set the response status code. If you omit to compute this action,
-- the status code will be defaulted to \"200 OK\".
setStatus ∷ StatusCode → Resource ()
setStatus code
    = do driftTo DecidingHeader
         itr ← getInteraction
         liftIO $ atomically $ updateItr itrResponse f itr
    where
      f res = res {
                resStatus = code
              }

-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
-- used so frequently: there should be actions like 'setContentType'
-- for every common headers.
--
-- Some important headers (especially \"Content-Length\" and
-- \"Transfer-Encoding\") may be silently dropped or overwritten by
-- the system not to corrupt the interaction with client at the
-- viewpoint of HTTP protocol layer. For instance, if we are keeping
-- the connection alive, without this process it causes a catastrophe
-- to send a header \"Content-Length: 10\" and actually send a body of
-- 20 bytes long. In this case the client shall only accept the first
-- 10 bytes of response body and thinks that the residual 10 bytes is
-- a part of header of the next response.
setHeader ∷ CIAscii → Ascii → Resource ()
setHeader name value
    = driftTo DecidingHeader ≫ setHeader' name value

setHeader' ∷ CIAscii → Ascii → Resource ()
setHeader' name value
    = do itr ← getInteraction
         liftIO $ atomically
                $ updateItr itrResponse (H.setHeader name value) itr

-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- 'isRedirection' or it causes an error.
redirect ∷ StatusCode → URI → Resource ()
redirect code uri
    = do when (code ≡ NotModified ∨ not (isRedirection code))
             $ abort InternalServerError []
             $ Just
             $ A.toText
             $ A.fromAsciiBuilder
             $ A.toAsciiBuilder "Attempted to redirect with status "
             ⊕ printStatusCode code
         setStatus code
         setLocation uri

-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
setContentType
    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType

-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
setLocation ∷ URI → Resource ()
setLocation uri
    = case A.fromChars uriStr of
        Just a  → setHeader "Location" a
        Nothing → abort InternalServerError []
                  (Just $ "Malformed URI: " ⊕ T.pack uriStr)
    where
      uriStr = uriToString id uri ""

-- |Computation of @'setContentEncoding' codings@ sets the response
-- header \"Content-Encoding\" to @codings@.
setContentEncoding ∷ [CIAscii] → Resource ()
setContentEncoding codings
    = do ver ← getRequestVersion
         tr  ← case ver of
                  HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                  HttpVersion 1 1 → return toAB
                  _               → abort InternalServerError []
                                    (Just "setContentEncoding: Unknown HTTP version")
         setHeader "Content-Encoding"
                   (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
    where
      toAB = A.toAsciiBuilder ∘ A.fromCIAscii

-- |Computation of @'setWWWAuthenticate' challenge@ sets the response
-- header \"WWW-Authenticate\" to @challenge@.
setWWWAuthenticate ∷ AuthChallenge → Resource ()
setWWWAuthenticate challenge
    = setHeader "WWW-Authenticate" (printAuthChallenge challenge)


{- DecidingBody 時に使用するアクション群 -}

-- | Computation of @'output' str@ writes @str@ as a response body,
-- and then make the 'Resource' transit to /Done/ state. It is safe to
-- apply 'output' to an infinite string, such as a lazy stream of
-- \/dev\/random.
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
output str = outputChunk str *> driftTo Done

-- | Computation of @'outputChunk' str@ writes @str@ as a part of
-- response body. You can compute this action multiple times to write
-- a body little at a time. It is safe to apply 'outputChunk' to an
-- infinite string.
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk wholeChunk
    = 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 $
                       readItr itrWillDiscardBody id itr

         unless (discardBody)
             $ sendChunks wholeChunk limit

         unless (Lazy.null wholeChunk)
             $ liftIO $ atomically $
               writeItr itrBodyIsNull False itr
    where
      sendChunks ∷ Lazy.ByteString → Int → Resource ()
      sendChunks str limit
          | Lazy.null str = return ()
          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
                               itr ← getInteraction
                               liftIO $ atomically
                                      $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
                               sendChunks remaining limit

      chunkToBuilder ∷ Lazy.ByteString → Builder
      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks

{-

  [GettingBody からそれ以降の状態に遷移する時]
  
  body を讀み終へてゐなければ、殘りの body を讀み捨てる。


  [DecidingHeader からそれ以降の状態に遷移する時]

  postprocess する。


  [Done に遷移する時]

  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
  る。

-}

driftTo ∷ InteractionState → Resource ()
driftTo newState
    = do itr ← getInteraction
         liftIO $ atomically $ do oldState ← readItr itrState id itr
                                  if newState < oldState then
                                      throwStateError oldState newState
                                    else
                                      do let a = [oldState .. newState]
                                             b = tail a
                                             c = zip a b
                                         mapM_ (uncurry $ drift itr) c
                                         writeItr itrState newState itr
    where
      throwStateError ∷ Monad m => InteractionState → InteractionState → m a

      throwStateError Done DecidingBody
          = fail "It makes no sense to output something after finishing to output."

      throwStateError old new
          = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)


      drift ∷ Interaction → InteractionState → InteractionState → STM ()

      drift itr GettingBody _
          = writeItr itrReqBodyWasteAll True itr

      drift itr DecidingHeader _
          = postprocess itr

      drift itr _ Done
          = do bodyIsNull ← readItr itrBodyIsNull id itr
               when bodyIsNull
                        $ writeDefaultPage itr

      drift _ _ _
          = return ()