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