Network/HTTP/Lucu/Resource.hs

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