Network/HTTP/Lucu/Resource.hs

   1 {-# LANGUAGE
   2     GeneralizedNewtypeDeriving
   3   , DoAndIfThenElse
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , UnicodeSyntax
   7   #-}
   8 {-# OPTIONS_HADDOCK prune #-}
   9 -- |This is the Resource Monad; monadic actions to define the behavior
  10 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
  11 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
  12 -- also a state machine.
  13 --
  14 -- Request Processing Flow:
  15 --
  16 --   1. A client issues an HTTP request.
  17 --
  18 --   2. If the URI of it matches to any resource, the corresponding
  19 --      'Resource' Monad starts running on a newly spawned thread.
  20 --
  21 --   3. The 'Resource' Monad looks at the request header, find (or not
  22 --      find) an entity, receive the request body (if any), decide the
  23 --      response header, and decide the response body. This process
  24 --      will be discussed later.
  25 --
  26 --   4. The 'Resource' Monad and its thread stops running. The client
  27 --      may or may not be sending us the next request at this point.
  28 --
  29 -- 'Resource' Monad takes the following states. The initial state is
  30 -- /Examining Request/ and the final state is /Done/.
  31 --
  32 --   [/Examining Request/] In this state, a 'Resource' looks at the
  33 --   request header and thinks about an entity for it. If there is a
  34 --   suitable entity, the 'Resource' tells the system an entity tag
  35 --   and its last modification time ('foundEntity'). If it found no
  36 --   entity, it tells the system so ('foundNoEntity'). In case it is
  37 --   impossible to decide the existence of entity, which is a typical
  38 --   case for POST requests, 'Resource' does nothing in this state.
  39 --
  40 --   [/Getting Body/] A 'Resource' asks the system to receive a
  41 --   request body from client. Before actually reading from the
  42 --   socket, the system sends \"100 Continue\" to the client if need
  43 --   be. When a 'Resource' transits to the next state without
  44 --   receiving all or part of request body, the system still reads it
  45 --   and just throws it away.
  46 --
  47 --   [/Deciding Header/] A 'Resource' makes a decision of status code
  48 --   and response header. When it transits to the next state, the
  49 --   system checks the validness of response header and then write
  50 --   them to the socket.
  51 --
  52 --   [/Deciding Body/] In this state, a 'Resource' asks the system to
  53 --   write some response body to the socket. When it transits to the
  54 --   next state without writing any response body, the system
  55 --   completes it depending on the status code.
  56 --
  57 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  58 --   HTTP interaction anymore.
  59 --
  60 -- Note that the state transition is one-way: for instance, it is an
  61 -- error to try to read a request body after writing some
  62 -- response. This limitation is for efficiency. We don't want to read
  63 -- the entire request before starting 'Resource', nor we don't want to
  64 -- postpone writing the entire response till the end of 'Resource'
  65 -- computation.
  66
  67 module Network.HTTP.Lucu.Resource
  68     (
  69     -- * Types
  70       Resource
  71     , FormData(..)
  72     , runRes
  73
  74     -- * Actions
  75
  76     -- ** Getting request header
  77
  78     -- |These actions can be computed regardless of the current state,
  79     -- and they don't change the state.
  80     , getConfig
  81     , getRemoteAddr
  82     , getRemoteAddr'
  83     , getRemoteHost
  84     , getRemoteCertificate
  85     , getRequest
  86     , getMethod
  87     , getRequestURI
  88     , getRequestVersion
  89     , getResourcePath
  90     , getPathInfo
  91     , getQueryForm
  92     , getHeader
  93     , getAccept
  94     , getAcceptEncoding
  95     , isEncodingAcceptable
  96     , getContentType
  97     , getAuthorization
  98
  99     -- ** Finding an entity
 100
 101     -- |These actions can be computed only in the /Examining Request/
 102     -- state. After the computation, the 'Resource' transits to
 103     -- /Getting Body/ state.
 104     , foundEntity
 105     , foundETag
 106     , foundTimeStamp
 107     , foundNoEntity
 108
 109     -- ** Getting a request body
 110
 111     -- |Computation of these actions changes the state to /Getting
 112     -- Body/.
 113     , input
 114     , inputChunk
 115     , inputForm
 116     , defaultLimit
 117
 118     -- ** Setting response headers
 119
 120     -- |Computation of these actions changes the state to /Deciding
 121     -- Header/.
 122     , setStatus
 123     , setHeader
 124     , redirect
 125     , setContentType
 126     , setLocation
 127     , setContentEncoding
 128     , setWWWAuthenticate
 129
 130     -- ** Writing a response body
 131
 132     -- |Computation of these actions changes the state to /Deciding
 133     -- Body/.
 134     , putChunk
 135     , putBuilder
 136
 137     , driftTo -- private
 138     )
 139     where
 140 import Blaze.ByteString.Builder (Builder)
 141 import qualified Blaze.ByteString.Builder.ByteString as BB
 142 import Control.Applicative
 143 import Control.Concurrent.STM
 144 import Control.Monad.Reader
 145 import Control.Monad.Unicode
 146 import Data.Ascii (Ascii, CIAscii)
 147 import qualified Data.Ascii as A
 148 import qualified Data.Attoparsec.Char8 as P
 149 import qualified Data.Attoparsec.Lazy  as LP
 150 import Data.ByteString (ByteString)
 151 import qualified Data.ByteString as Strict
 152 import qualified Data.ByteString.Lazy as Lazy
 153 import Data.Foldable (toList)
 154 import Data.List
 155 import qualified Data.Map as M
 156 import Data.Maybe
 157 import Data.Monoid.Unicode
 158 import Data.Sequence (Seq)
 159 import Data.Text (Text)
 160 import qualified Data.Text as T
 161 import qualified Data.Text.Encoding as T
 162 import Data.Time
 163 import qualified Data.Time.HTTP as HTTP
 164 import Network.HTTP.Lucu.Abortion
 165 import Network.HTTP.Lucu.Authorization
 166 import Network.HTTP.Lucu.Config
 167 import Network.HTTP.Lucu.ContentCoding
 168 import Network.HTTP.Lucu.ETag
 169 import qualified Network.HTTP.Lucu.Headers as H
 170 import Network.HTTP.Lucu.HttpVersion
 171 import Network.HTTP.Lucu.Interaction
 172 import Network.HTTP.Lucu.MultipartForm
 173 import Network.HTTP.Lucu.Postprocess
 174 import Network.HTTP.Lucu.Request
 175 import Network.HTTP.Lucu.Response
 176 import Network.HTTP.Lucu.MIMEType
 177 import Network.HTTP.Lucu.Utils
 178 import Network.Socket hiding (accept)
 179 import Network.URI hiding (path)
 180 import OpenSSL.X509
 181 import Prelude.Unicode
 182
 183 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
 184 -- any 'IO' actions.
 185 newtype Resource a
 186     = Resource {
 187         unRes ∷ ReaderT Interaction IO a
 188       }
 189     deriving (Applicative, Functor, Monad, MonadIO)
 190
 191 runRes ∷ Resource a → Interaction → IO a
 192 runRes r itr
 193     = runReaderT (unRes r) itr
 194
 195 getInteraction ∷ Resource Interaction
 196 getInteraction = Resource ask
 197
 198 -- |Get the 'Config' value which is used for the httpd.
 199 getConfig ∷ Resource Config
 200 getConfig = itrConfig <$> getInteraction
 201
 202 -- |Get the 'SockAddr' of the remote host. If you want a string
 203 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
 204 getRemoteAddr ∷ Resource SockAddr
 205 getRemoteAddr = itrRemoteAddr <$> getInteraction
 206
 207 -- |Get the string representation of the address of remote host. If
 208 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
 209 getRemoteAddr' ∷ Resource HostName
 210 getRemoteAddr'
 211     = do sa          ← getRemoteAddr
 212          (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
 213          return a
 214
 215 -- |Resolve an address to the remote host.
 216 getRemoteHost ∷ Resource (Maybe HostName)
 217 getRemoteHost
 218     = do sa ← getRemoteAddr
 219          fst <$> (liftIO $ getNameInfo [] True False sa)
 220
 221 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 222 --
 223 --   * This request didn't came through an SSL stream.
 224 --
 225 --   * The client didn't send us its certificate.
 226 --
 227 --   * The 'OpenSSL.Session.VerificationMode' of
 228 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 229 --   'OpenSSL.Session.VerifyPeer'.
 230 getRemoteCertificate ∷ Resource (Maybe X509)
 231 getRemoteCertificate = itrRemoteCert <$> getInteraction
 232
 233 -- |Get the 'Request' value which represents the request header. In
 234 -- general you don't have to use this action.
 235 getRequest ∷ Resource Request
 236 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 237
 238 -- |Get the 'Method' value of the request.
 239 getMethod ∷ Resource Method
 240 getMethod = reqMethod <$> getRequest
 241
 242 -- |Get the URI of the request.
 243 getRequestURI ∷ Resource URI
 244 getRequestURI = reqURI <$> getRequest
 245
 246 -- |Get the HTTP version of the request.
 247 getRequestVersion ∷ Resource HttpVersion
 248 getRequestVersion = reqVersion <$> getRequest
 249
 250 -- |Get the path of this 'Resource' (to be exact,
 251 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 252 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 253 -- action is the exact path in the tree even when the
 254 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 255 --
 256 -- Example:
 257 --
 258 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 259 -- >        in runHttpd defaultConfig tree
 260 -- >
 261 -- > resFoo = ResourceDef {
 262 -- >     resIsGreedy = True
 263 -- >   , resGet = Just $ do requestURI   <- getRequestURI
 264 -- >                        resourcePath <- getResourcePath
 265 -- >                        pathInfo     <- getPathInfo
 266 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 267 -- >                        -- resourcePath       == ["foo"]
 268 -- >                        -- pathInfo           == ["bar", "baz"]
 269 -- >                        ...
 270 -- >   , ...
 271 -- >   }
 272 getResourcePath ∷ Resource [Text]
 273 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
 274
 275 -- |This is an analogy of CGI PATH_INFO. The result is
 276 -- URI-unescaped. It is always @[]@ if the
 277 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 278 -- 'getResourcePath'.
 279 --
 280 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
 281 getPathInfo ∷ Resource [Text]
 282 getPathInfo = do rsrcPath ← getResourcePath
 283                  reqPath  ← splitPathInfo <$> getRequestURI
 284                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 285                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 286                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 287                  -- ければこの Resource が撰ばれた筈が無い）ので、
 288                  -- rsrcPath の長さの分だけ削除すれば良い。
 289                  return $ drop (length rsrcPath) reqPath
 290
 291 -- |Assume the query part of request URI as
 292 -- application\/x-www-form-urlencoded, and parse it to pairs of
 293 -- @(name, formData)@. This action doesn't parse the request body. See
 294 -- 'inputForm'. Field names are decoded in UTF-8.
 295 getQueryForm ∷ Resource [(Text, FormData)]
 296 getQueryForm = parse' <$> getRequestURI
 297     where
 298       parse' = map toPairWithFormData ∘
 299                parseWWWFormURLEncoded ∘
 300                fromJust ∘
 301                A.fromChars ∘
 302                drop 1 ∘
 303                uriQuery
 304
 305 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
 306 toPairWithFormData (name, value)
 307     = let fd = FormData {
 308                  fdFileName = Nothing
 309                , fdContent  = Lazy.fromChunks [value]
 310                }
 311       in (T.decodeUtf8 name, fd)
 312
 313 -- |Get a value of given request header. Comparison of header name is
 314 -- case-insensitive. Note that this action is not intended to be used
 315 -- so frequently: there should be actions like 'getContentType' for
 316 -- every common headers.
 317 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 318 getHeader name
 319     = H.getHeader name <$> getRequest
 320
 321 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
 322 getAccept ∷ Resource [MIMEType]
 323 getAccept
 324     = do acceptM ← getHeader "Accept"
 325          case acceptM of
 326            Nothing
 327                → return []
 328            Just accept
 329                → case P.parseOnly p (A.toByteString accept) of
 330                     Right xs → return xs
 331                     Left  _  → abort BadRequest []
 332                                (Just $ "Unparsable Accept: " ⊕ A.toText accept)
 333     where
 334       p = do xs ← mimeTypeListP
 335              P.endOfInput
 336              return xs
 337
 338 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
 339 -- \"Accept-Encoding\". The list is sorted in descending order by
 340 -- qvalue.
 341 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 342 getAcceptEncoding
 343     = do accEncM ← getHeader "Accept-Encoding"
 344          case accEncM of
 345            Nothing
 346                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 347                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 348                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 349                -- 指定された事にする。
 350                → do ver ← getRequestVersion
 351                     case ver of
 352                       HttpVersion 1 0 → return [("identity", Nothing)]
 353                       HttpVersion 1 1 → return [("*"       , Nothing)]
 354                       _               → abort InternalServerError []
 355                                         (Just "getAcceptEncoding: unknown HTTP version")
 356            Just ae
 357                → if ae ≡ "" then
 358                       -- identity のみが許される。
 359                       return [("identity", Nothing)]
 360                   else
 361                       case P.parseOnly p (A.toByteString ae) of
 362                         Right xs → return $ map toTuple $ reverse $ sort xs
 363                         Left  _  → abort BadRequest []
 364                                    (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
 365     where
 366       p = do xs ← acceptEncodingListP
 367              P.endOfInput
 368              return xs
 369
 370       toTuple (AcceptEncoding {..})
 371           = (aeEncoding, aeQValue)
 372
 373 -- |Check whether a given content-coding is acceptable.
 374 isEncodingAcceptable ∷ CIAscii → Resource Bool
 375 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
 376     where
 377       f (e, q)
 378           = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 379
 380 -- |Get the header \"Content-Type\" as 'MIMEType'.
 381 getContentType ∷ Resource (Maybe MIMEType)
 382 getContentType
 383     = do cTypeM ← getHeader "Content-Type"
 384          case cTypeM of
 385            Nothing
 386                → return Nothing
 387            Just cType
 388                → case P.parseOnly p (A.toByteString cType) of
 389                     Right t → return $ Just t
 390                     Left  _ → abort BadRequest []
 391                               (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
 392     where
 393       p = do t ← mimeTypeP
 394              P.endOfInput
 395              return t
 396
 397 -- |Get the header \"Authorization\" as 'AuthCredential'.
 398 getAuthorization ∷ Resource (Maybe AuthCredential)
 399 getAuthorization
 400     = do authM ← getHeader "Authorization"
 401          case authM of
 402            Nothing
 403                → return Nothing
 404            Just auth
 405                → case P.parseOnly p (A.toByteString auth) of
 406                     Right ac → return $ Just ac
 407                     Left  _  → return Nothing
 408     where
 409       p = do ac ← authCredentialP
 410              P.endOfInput
 411              return ac
 412
 413
 414 -- Finding an entity
 415
 416 -- |Tell the system that the 'Resource' found an entity for the
 417 -- request URI. If this is a GET or HEAD request, a found entity means
 418 -- a datum to be replied. If this is a PUT or DELETE request, it means
 419 -- a datum which was stored for the URI until now. It is an error to
 420 -- compute 'foundEntity' if this is a POST request.
 421 --
 422 -- Computation of 'foundEntity' performs \"If-Match\" test or
 423 -- \"If-None-Match\" test if possible. When those tests fail, the
 424 -- computation of 'Resource' immediately aborts with status \"412
 425 -- Precondition Failed\" or \"304 Not Modified\" depending on the
 426 -- situation.
 427 --
 428 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 429 -- \"ETag\" and \"Last-Modified\" headers into the response.
 430 foundEntity ∷ ETag → UTCTime → Resource ()
 431 foundEntity tag timeStamp
 432     = do driftTo ExaminingRequest
 433
 434          method ← getMethod
 435          when (method ≡ GET ∨ method ≡ HEAD)
 436              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 437          when (method ≡ POST)
 438              $ abort InternalServerError []
 439                (Just "Illegal computation of foundEntity for a POST request.")
 440          foundETag tag
 441
 442          driftTo GettingBody
 443
 444 -- |Tell the system that the 'Resource' found an entity for the
 445 -- request URI. The only difference from 'foundEntity' is that
 446 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 447 -- the response.
 448 --
 449 -- This action is not preferred. You should use 'foundEntity' whenever
 450 -- possible.
 451 foundETag ∷ ETag → Resource ()
 452 foundETag tag
 453     = do driftTo ExaminingRequest
 454
 455          method ← getMethod
 456          when (method ≡ GET ∨ method ≡ HEAD)
 457               $ setHeader' "ETag"
 458               $ A.fromAsciiBuilder
 459               $ printETag tag
 460          when (method ≡ POST)
 461               $ abort InternalServerError []
 462                 (Just "Illegal computation of foundETag for POST request.")
 463
 464          -- If-Match があればそれを見る。
 465          ifMatch ← getHeader "If-Match"
 466          case ifMatch of
 467            Nothing    → return ()
 468            Just value → if value ≡ "*" then
 469                             return ()
 470                         else
 471                             case P.parseOnly p (A.toByteString value) of
 472                               Right tags
 473                                  -- tags の中に一致するものが無ければ
 474                                  -- PreconditionFailed で終了。
 475                                  → when ((¬) (any (≡ tag) tags))
 476                                        $ abort PreconditionFailed []
 477                                          (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
 478                               Left _
 479                                    → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
 480
 481          let statusForNoneMatch
 482                  = if method ≡ GET ∨ method ≡ HEAD then
 483                        NotModified
 484                    else
 485                        PreconditionFailed
 486
 487          -- If-None-Match があればそれを見る。
 488          ifNoneMatch ← getHeader "If-None-Match"
 489          case ifNoneMatch of
 490            Nothing    → return ()
 491            Just value → if value ≡ "*" then
 492                              abort statusForNoneMatch [] (Just "The entity tag matches: *")
 493                          else
 494                              case P.parseOnly p (A.toByteString value) of
 495                                Right tags
 496                                    → when (any (≡ tag) tags)
 497                                          $ abort statusForNoneMatch []
 498                                            (Just $ "The entity tag matches: " ⊕ A.toText value)
 499                                Left _
 500                                    → abort BadRequest []
 501                                      (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
 502
 503          driftTo GettingBody
 504     where
 505       p = do xs ← eTagListP
 506              P.endOfInput
 507              return xs
 508
 509 -- |Tell the system that the 'Resource' found an entity for the
 510 -- request URI. The only difference from 'foundEntity' is that
 511 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 512 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 513 -- \"If-None-Match\" test. Be aware that any tests based on last
 514 -- modification time are unsafe because it is possible to mess up such
 515 -- tests by modifying the entity twice in a second.
 516 --
 517 -- This action is not preferred. You should use 'foundEntity' whenever
 518 -- possible.
 519 foundTimeStamp ∷ UTCTime → Resource ()
 520 foundTimeStamp timeStamp
 521     = do driftTo ExaminingRequest
 522
 523          method ← getMethod
 524          when (method ≡ GET ∨ method ≡ HEAD)
 525              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 526          when (method ≡ POST)
 527              $ abort InternalServerError []
 528                (Just "Illegal computation of foundTimeStamp for POST request.")
 529
 530          let statusForIfModSince
 531                  = if method ≡ GET ∨ method ≡ HEAD then
 532                        NotModified
 533                    else
 534                        PreconditionFailed
 535
 536          -- If-Modified-Since があればそれを見る。
 537          ifModSince ← getHeader "If-Modified-Since"
 538          case ifModSince of
 539            Just str → case HTTP.fromAscii str of
 540                          Right lastTime
 541                              → when (timeStamp ≤ lastTime)
 542                                $ abort statusForIfModSince []
 543                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 544                          Left _
 545                              → return () -- 不正な時刻は無視
 546            Nothing  → return ()
 547
 548          -- If-Unmodified-Since があればそれを見る。
 549          ifUnmodSince ← getHeader "If-Unmodified-Since"
 550          case ifUnmodSince of
 551            Just str → case HTTP.fromAscii str of
 552                          Right lastTime
 553                              → when (timeStamp > lastTime)
 554                                $ abort PreconditionFailed []
 555                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 556                          Left _
 557                              → return () -- 不正な時刻は無視
 558            Nothing  → return ()
 559
 560          driftTo GettingBody
 561
 562 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 563 -- 'Resource' found no entity for the request URI. @mStr@ is an
 564 -- optional error message to be replied to the client.
 565 --
 566 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 567 -- test and aborts with status \"412 Precondition Failed\" when it
 568 -- failed. If this is a GET, HEAD, POST or DELETE request,
 569 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 570 foundNoEntity ∷ Maybe Text → Resource ()
 571 foundNoEntity msgM
 572     = do driftTo ExaminingRequest
 573
 574          method ← getMethod
 575          when (method ≢ PUT)
 576              $ abort NotFound [] msgM
 577
 578          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 579          -- If-Match: 條件も滿たさない。
 580          ifMatch ← getHeader "If-Match"
 581          when (ifMatch ≢ Nothing)
 582              $ abort PreconditionFailed [] msgM
 583
 584          driftTo GettingBody
 585
 586
 587 -- Getting a request body
 588
 589 -- | Computation of @'input' limit@ attempts to read the request body
 590 -- up to @limit@ bytes, and then make the 'Resource' transit to
 591 -- /Deciding Header/ state. When the actual size of body is larger
 592 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 593 -- with status \"413 Request Entity Too Large\". When the request has
 594 -- no body, 'input' returns an empty string.
 595 --
 596 -- @limit@ may be less than or equal to zero. In this case, the
 597 -- default limitation value ('cnfMaxEntityLength') is used. See
 598 -- 'defaultLimit'.
 599 --
 600 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
 601 -- reading from the socket just happens at the computation of 'input',
 602 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
 603 -- 'inputChunk'.
 604 input ∷ Int → Resource Lazy.ByteString
 605 input limit
 606     = do driftTo GettingBody
 607          itr     ← getInteraction
 608          chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
 609                        askForInput itr
 610                    else
 611                        do driftTo DecidingHeader
 612                           return (∅)
 613          return chunk
 614     where
 615       askForInput ∷ Interaction → Resource Lazy.ByteString
 616       askForInput (Interaction {..})
 617           = do let confLimit   = cnfMaxEntityLength itrConfig
 618                    actualLimit = if limit ≤ 0 then
 619                                      confLimit
 620                                  else
 621                                      limit
 622                when (actualLimit ≤ 0)
 623                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
 624                -- Reader にリクエスト
 625                liftIO $ atomically
 626                       $ writeTVar itrReqBodyWanted actualLimit
 627                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
 628                chunk ← liftIO $ atomically
 629                        $ do chunkLen    ← readTVar itrReceivedBodyLen
 630                             chunkIsOver ← readTVar itrReqChunkIsOver
 631                             if chunkLen < actualLimit then
 632                                 -- 要求された量に滿たなくて、まだ殘りが
 633                                 -- あるなら再試行。
 634                                 unless chunkIsOver
 635                                     $ retry
 636                             else
 637                                 -- 制限値一杯まで讀むやうに指示したのに
 638                                 -- まだ殘ってゐるなら、それは多過ぎる。
 639                                 unless chunkIsOver
 640                                     $ tooLarge actualLimit
 641                             -- 成功。itr 内にチャンクを置いたままにする
 642                             -- とメモリの無駄になるので除去。
 643                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 644                             writeTVar itrReceivedBody    (∅)
 645                             writeTVar itrReceivedBodyLen 0
 646                             return chunk
 647
 648                driftTo DecidingHeader
 649                return chunk
 650
 651       tooLarge ∷ Int → STM ()
 652       tooLarge lim = abortSTM RequestEntityTooLarge []
 653                      (Just $ "Request body must be smaller than "
 654                              ⊕ T.pack (show lim) ⊕ " bytes.")
 655
 656 seqToLBS ∷ Seq ByteString → Lazy.ByteString
 657 {-# INLINE seqToLBS #-}
 658 seqToLBS = Lazy.fromChunks ∘ toList
 659
 660 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 661 -- request body up to @limit@ bytes. You can read any large request by
 662 -- repeating computation of this action. When you've read all the
 663 -- request body, 'inputChunk' returns an empty string and then make
 664 -- the 'Resource' transit to /Deciding Header/ state.
 665 --
 666 -- @limit@ may be less than or equal to zero. In this case, the
 667 -- default limitation value ('cnfMaxEntityLength') is used. See
 668 -- 'defaultLimit'.
 669 --
 670 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
 671 -- should use it whenever possible.
 672 inputChunk ∷ Int → Resource Lazy.ByteString
 673 inputChunk limit
 674     = do driftTo GettingBody
 675          itr     ← getInteraction
 676          chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
 677                        askForInput itr
 678                    else
 679                        do driftTo DecidingHeader
 680                           return (∅)
 681          return chunk
 682     where
 683       askForInput ∷ Interaction → Resource Lazy.ByteString
 684       askForInput (Interaction {..})
 685           = do let confLimit   = cnfMaxEntityLength itrConfig
 686                    actualLimit = if limit < 0 then
 687                                      confLimit
 688                                  else
 689                                      limit
 690                when (actualLimit ≤ 0)
 691                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
 692                -- Reader にリクエスト
 693                liftIO $ atomically
 694                       $ writeTVar itrReqBodyWanted actualLimit
 695                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 696                chunk ← liftIO $ atomically
 697                        $ do chunkLen ← readTVar itrReceivedBodyLen
 698                             -- 要求された量に滿たなくて、まだ殘りがある
 699                             -- なら再試行。
 700                             when (chunkLen < actualLimit)
 701                                 $ do chunkIsOver ← readTVar itrReqChunkIsOver
 702                                      unless chunkIsOver
 703                                          $ retry
 704                             -- 成功
 705                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 706                             writeTVar itrReceivedBody    (∅)
 707                             writeTVar itrReceivedBodyLen 0
 708                             return chunk
 709                when (Lazy.null chunk)
 710                    $ driftTo DecidingHeader
 711                return chunk
 712
 713 -- | Computation of @'inputForm' limit@ attempts to read the request
 714 -- body with 'input' and parse it as
 715 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
 716 -- the request header \"Content-Type\" is neither of them, 'inputForm'
 717 -- makes 'Resource' abort with status \"415 Unsupported Media
 718 -- Type\". If the request has no \"Content-Type\", it aborts with
 719 -- \"400 Bad Request\".
 720 --
 721 -- Field names in @multipart\/form-data@ will be precisely decoded in
 722 -- accordance with RFC 2231. On the other hand,
 723 -- @application\/x-www-form-urlencoded@ says nothing about the
 724 -- encoding of field names, so they'll always be decoded in UTF-8.
 725 inputForm ∷ Int → Resource [(Text, FormData)]
 726 inputForm limit
 727     = do cTypeM ← getContentType
 728          case cTypeM of
 729            Nothing
 730                → abort BadRequest [] (Just "Missing Content-Type")
 731            Just (MIMEType "application" "x-www-form-urlencoded" _)
 732                → readWWWFormURLEncoded
 733            Just (MIMEType "multipart" "form-data" params)
 734                → readMultipartFormData params
 735            Just cType
 736                → abort UnsupportedMediaType []
 737                  $ Just
 738                  $ A.toText
 739                  $ A.fromAsciiBuilder
 740                  $ A.toAsciiBuilder "Unsupported media type: "
 741                  ⊕ printMIMEType cType
 742     where
 743       readWWWFormURLEncoded
 744           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 745             <$>
 746             (bsToAscii =≪ input limit)
 747
 748       bsToAscii bs
 749           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 750               Just a  → return a
 751               Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
 752
 753       readMultipartFormData params
 754           = do case M.lookup "boundary" params of
 755                  Nothing
 756                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
 757                  Just boundary
 758                      → do src ← input limit
 759                           b   ← case A.fromText boundary of
 760                                    Just b  → return b
 761                                    Nothing → abort BadRequest []
 762                                              (Just $ "Malformed boundary: " ⊕ boundary)
 763                           case LP.parse (p b) src of
 764                             LP.Done _ formList
 765                                 → return formList
 766                             _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
 767           where
 768             p b = do xs ← multipartFormP b
 769                      P.endOfInput
 770                      return xs
 771
 772 -- | This is just a constant @-1@. It's better to say @'input'
 773 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 774 -- the same.
 775 defaultLimit ∷ Int
 776 defaultLimit = (-1)
 777
 778
 779 -- Setting response headers
 780
 781 -- | Set the response status code. If you omit to compute this action,
 782 -- the status code will be defaulted to \"200 OK\".
 783 setStatus ∷ StatusCode → Resource ()
 784 setStatus sc
 785     = do driftTo DecidingHeader
 786          itr ← getInteraction
 787          liftIO
 788              $ atomically
 789              $ setResponseStatus itr sc
 790
 791 -- | Set a value of given resource header. Comparison of header name
 792 -- is case-insensitive. Note that this action is not intended to be
 793 -- used so frequently: there should be actions like 'setContentType'
 794 -- for every common headers.
 795 --
 796 -- Some important headers (especially \"Content-Length\" and
 797 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 798 -- the system not to corrupt the interaction with client at the
 799 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 800 -- the connection alive, without this process it causes a catastrophe
 801 -- to send a header \"Content-Length: 10\" and actually send a body of
 802 -- 20 bytes long. In this case the client shall only accept the first
 803 -- 10 bytes of response body and thinks that the residual 10 bytes is
 804 -- a part of header of the next response.
 805 setHeader ∷ CIAscii → Ascii → Resource ()
 806 setHeader name value
 807     = driftTo DecidingHeader ≫ setHeader' name value
 808
 809 setHeader' ∷ CIAscii → Ascii → Resource ()
 810 setHeader' name value
 811     = do itr ← getInteraction
 812          liftIO $ atomically
 813                 $ do res ← readTVar $ itrResponse itr
 814                      let res' = H.setHeader name value res
 815                      writeTVar (itrResponse itr) res'
 816                      when (name ≡ "Content-Type")
 817                          $ writeTVar (itrResponseHasCType itr) True
 818
 819 -- | Computation of @'redirect' code uri@ sets the response status to
 820 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 821 -- 'isRedirection' or it causes an error.
 822 redirect ∷ StatusCode → URI → Resource ()
 823 redirect code uri
 824     = do when (code ≡ NotModified ∨ not (isRedirection code))
 825              $ abort InternalServerError []
 826              $ Just
 827              $ A.toText
 828              $ A.fromAsciiBuilder
 829              $ A.toAsciiBuilder "Attempted to redirect with status "
 830              ⊕ printStatusCode code
 831          setStatus code
 832          setLocation uri
 833
 834 -- | Computation of @'setContentType' mType@ sets the response header
 835 -- \"Content-Type\" to @mType@.
 836 setContentType ∷ MIMEType → Resource ()
 837 {-# INLINE setContentType #-}
 838 setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 839
 840 -- | Computation of @'setLocation' uri@ sets the response header
 841 -- \"Location\" to @uri@.
 842 setLocation ∷ URI → Resource ()
 843 setLocation uri
 844     = case A.fromChars uriStr of
 845         Just a  → setHeader "Location" a
 846         Nothing → abort InternalServerError []
 847                   (Just $ "Malformed URI: " ⊕ T.pack uriStr)
 848     where
 849       uriStr = uriToString id uri ""
 850
 851 -- |Computation of @'setContentEncoding' codings@ sets the response
 852 -- header \"Content-Encoding\" to @codings@.
 853 setContentEncoding ∷ [CIAscii] → Resource ()
 854 setContentEncoding codings
 855     = do ver ← getRequestVersion
 856          tr  ← case ver of
 857                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 858                   HttpVersion 1 1 → return toAB
 859                   _               → abort InternalServerError []
 860                                     (Just "setContentEncoding: Unknown HTTP version")
 861          setHeader "Content-Encoding"
 862                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 863     where
 864       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 865
 866 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
 867 -- header \"WWW-Authenticate\" to @challenge@.
 868 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 869 setWWWAuthenticate challenge
 870     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 871
 872
 873 -- Writing a response body
 874
 875 -- | Write a chunk in 'Lazy.ByteString' to the response body. It is
 876 -- safe to apply this function to an infinitely long
 877 -- 'Lazy.ByteString'.
 878 --
 879 -- Note that you must first set the response header \"Content-Type\"
 880 -- before applying this function. See: 'setContentType'
 881 putChunk ∷ Lazy.ByteString → Resource ()
 882 {-# INLINE putChunk #-}
 883 putChunk = putBuilder ∘ BB.fromLazyByteString
 884
 885 -- | Run a 'Builder' to construct a chunk, and write it to the
 886 -- response body. It is safe to apply this function to a 'Builder'
 887 -- producing an infinitely long stream of octets.
 888 --
 889 -- Note that you must first set the response header \"Content-Type\"
 890 -- before applying this function. See: 'setContentType'
 891 putBuilder ∷ Builder → Resource ()
 892 putBuilder b
 893     = do itr ← getInteraction
 894          liftIO $ atomically
 895                 $ do driftTo' itr DecidingBody
 896                      hasCType ← readTVar $ itrResponseHasCType itr
 897                      unless hasCType
 898                          $ abortSTM InternalServerError []
 899                          $ Just "putBuilder: Content-Type has not been set."
 900                      putTMVar (itrBodyToSend itr) b
 901
 902
 903 -- Private
 904
 905 driftTo ∷ InteractionState → Resource ()
 906 driftTo newState
 907     = do itr ← getInteraction
 908          liftIO $ atomically $ driftTo' itr newState
 909
 910 driftTo' ∷ Interaction → InteractionState → STM ()
 911 driftTo' itr@(Interaction {..}) newState
 912     = do oldState ← readTVar itrState
 913          if newState < oldState then
 914              throwStateError oldState newState
 915          else
 916              do let a = [oldState .. newState]
 917                     b = tail a
 918                     c = zip a b
 919                 mapM_ (uncurry drift) c
 920                 writeTVar itrState newState
 921     where
 922       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 923       throwStateError Done DecidingBody
 924           = fail "It makes no sense to output something after finishing outputs."
 925       throwStateError old new
 926           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 927
 928       drift ∷ InteractionState → InteractionState → STM ()
 929       drift GettingBody _
 930           = writeTVar itrReqBodyWasteAll True
 931       drift DecidingHeader _
 932           = postprocess itr
 933       drift _ _
 934           = return ()