Network/HTTP/Lucu/Resource/Internal.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , GeneralizedNewtypeDeriving
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.Resource.Internal
   9     ( Resource
  10     , ResourceDef(..)
  11     , emptyResource
  12     , spawnResource
  13
  14     , getConfig
  15     , getRemoteAddr
  16     , getRemoteCertificate
  17     , getRequest
  18     , getResourcePath
  19
  20     , getChunk
  21
  22     , setStatus
  23     , setHeader
  24     , deleteHeader
  25
  26     , putBuilder
  27
  28     , driftTo
  29     )
  30     where
  31 import Blaze.ByteString.Builder (Builder)
  32 import Control.Applicative
  33 import Control.Concurrent
  34 import Control.Concurrent.STM
  35 import Control.Exception
  36 import Control.Monad.IO.Class
  37 import Control.Monad.Reader
  38 import Control.Monad.Unicode
  39 import Data.Ascii (Ascii, CIAscii)
  40 import qualified Data.Ascii as A
  41 import qualified Data.ByteString as Strict
  42 import Data.List
  43 import Data.Maybe
  44 import Data.Monoid.Unicode
  45 import qualified Data.Text as T
  46 import Network.HTTP.Lucu.Abortion
  47 import Network.HTTP.Lucu.Abortion.Internal
  48 import Network.HTTP.Lucu.Config
  49 import Network.HTTP.Lucu.DefaultPage
  50 import qualified Network.HTTP.Lucu.Headers as H
  51 import Network.HTTP.Lucu.Interaction
  52 import Network.HTTP.Lucu.Postprocess
  53 import Network.HTTP.Lucu.Request
  54 import Network.HTTP.Lucu.Response
  55 import Network.HTTP.Lucu.Utils
  56 import Network.Socket
  57 import OpenSSL.X509
  58 import Prelude hiding (catch)
  59 import Prelude.Unicode
  60 import System.IO
  61
  62 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
  63 -- any 'IO' actions.
  64 newtype Resource a
  65     = Resource {
  66         unResource ∷ ReaderT NormalInteraction IO a
  67       }
  68     deriving (Applicative, Functor, Monad, MonadIO)
  69
  70 runResource ∷ Resource a → NormalInteraction → IO a
  71 runResource = runReaderT ∘ unResource
  72
  73 -- |'ResourceDef' is basically a set of 'Resource' monads for each
  74 -- HTTP methods.
  75 data ResourceDef = ResourceDef {
  76     -- |Whether to run a 'Resource' on a native thread (spawned by
  77     -- 'forkOS') or to run it on a user thread (spanwed by
  78     -- 'forkIO'). Generally you don't need to set this field to
  79     -- 'True'.
  80       resUsesNativeThread ∷ !Bool
  81     -- | Whether to be greedy or not.
  82     --
  83     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  84     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  85     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  86     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  87     -- resources are like CGI scripts.
  88     , resIsGreedy         ∷ !Bool
  89     -- |A 'Resource' to be run when a GET request comes for the
  90     -- resource path. If 'resGet' is Nothing, the system responds
  91     -- \"405 Method Not Allowed\" for GET requests.
  92     --
  93     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  94     -- this case 'output' and such like don't actually write a
  95     -- response body.
  96     , resGet              ∷ !(Maybe (Resource ()))
  97     -- |A 'Resource' to be run when a HEAD request comes for the
  98     -- resource path. If 'resHead' is Nothing, the system runs
  99     -- 'resGet' instead. If 'resGet' is also Nothing, the system
 100     -- responds \"405 Method Not Allowed\" for HEAD requests.
 101     , resHead             ∷ !(Maybe (Resource ()))
 102     -- |A 'Resource' to be run when a POST request comes for the
 103     -- resource path. If 'resPost' is Nothing, the system responds
 104     -- \"405 Method Not Allowed\" for POST requests.
 105     , resPost             ∷ !(Maybe (Resource ()))
 106     -- |A 'Resource' to be run when a PUT request comes for the
 107     -- resource path. If 'resPut' is Nothing, the system responds
 108     -- \"405 Method Not Allowed\" for PUT requests.
 109     , resPut              ∷ !(Maybe (Resource ()))
 110     -- |A 'Resource' to be run when a DELETE request comes for the
 111     -- resource path. If 'resDelete' is Nothing, the system responds
 112     -- \"405 Method Not Allowed\" for DELETE requests.
 113     , resDelete           ∷ !(Maybe (Resource ()))
 114     }
 115
 116 -- |'emptyResource' is a resource definition with no actual
 117 -- handlers. You can construct a 'ResourceDef' by selectively
 118 -- overriding 'emptyResource'. It is defined as follows:
 119 --
 120 -- @
 121 --   emptyResource = ResourceDef {
 122 --                     resUsesNativeThread = False
 123 --                   , resIsGreedy         = False
 124 --                   , resGet              = Nothing
 125 --                   , resHead             = Nothing
 126 --                   , resPost             = Nothing
 127 --                   , resPut              = Nothing
 128 --                   , resDelete           = Nothing
 129 --                   }
 130 -- @
 131 emptyResource ∷ ResourceDef
 132 emptyResource = ResourceDef {
 133                   resUsesNativeThread = False
 134                 , resIsGreedy         = False
 135                 , resGet              = Nothing
 136                 , resHead             = Nothing
 137                 , resPost             = Nothing
 138                 , resPut              = Nothing
 139                 , resDelete           = Nothing
 140                 }
 141
 142 spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
 143 spawnResource (ResourceDef {..}) ni@(NI {..})
 144     = fork $ run `catch` processException
 145     where
 146       fork ∷ IO () → IO ThreadId
 147       fork | resUsesNativeThread = forkOS
 148            | otherwise           = forkIO
 149
 150       run ∷ IO ()
 151       run = flip runResource ni $
 152             do req ← getRequest
 153                fromMaybe notAllowed $ rsrc req
 154                driftTo Done
 155
 156       rsrc ∷ Request → Maybe (Resource ())
 157       rsrc req
 158           = case reqMethod req of
 159               GET    → resGet
 160               HEAD   → case resHead of
 161                           Just r  → Just r
 162                           Nothing → resGet
 163               POST   → resPost
 164               PUT    → resPut
 165               DELETE → resDelete
 166               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 167
 168       notAllowed ∷ Resource ()
 169       notAllowed
 170           = setStatus MethodNotAllowed
 171             *>
 172             (setHeader "Allow" $ A.fromAsciiBuilder
 173                                $ joinWith ", "
 174                                $ map A.toAsciiBuilder allowedMethods)
 175
 176       allowedMethods ∷ [Ascii]
 177       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 178                                     , methods resHead   ["GET", "HEAD"]
 179                                     , methods resPost   ["POST"]
 180                                     , methods resPut    ["PUT"]
 181                                     , methods resDelete ["DELETE"]
 182                                     ]
 183
 184       methods ∷ Maybe a → [Ascii] → [Ascii]
 185       methods m xs
 186           | isJust m  = xs
 187           | otherwise = []
 188
 189       toAbortion ∷ SomeException → Abortion
 190       toAbortion e
 191           = case fromException e of
 192               Just abortion → abortion
 193               Nothing       → mkAbortion' InternalServerError $ T.pack $ show e
 194
 195       processException ∷ SomeException → IO ()
 196       processException exc
 197           = do let abo = toAbortion exc
 198                state ← atomically $ readTVar niState
 199                res   ← atomically $ readTVar niResponse
 200                if state ≤ DecidingHeader then
 201                    -- We still have a chance to reflect this abortion
 202                    -- in the response. Hooray!
 203                    flip runResource ni $
 204                        do setStatus $ aboStatus abo
 205                           mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
 206                           setHeader "Content-Type" defaultPageContentType
 207                           deleteHeader "Content-Encoding"
 208                           putBuilder $ abortPage niConfig (Just niRequest) res abo
 209                else
 210                    when (cnfDumpTooLateAbortionToStderr niConfig)
 211                        $ dumpAbortion abo
 212                runResource (driftTo Done) ni
 213
 214 dumpAbortion ∷ Abortion → IO ()
 215 dumpAbortion abo
 216     = hPutStr stderr
 217       $ concat [ "Lucu: an exception occured after "
 218                , "sending the response header to the client:\n"
 219                , "  ", show abo, "\n"
 220                ]
 221
 222 getInteraction ∷ Resource NormalInteraction
 223 getInteraction = Resource ask
 224
 225 -- |Get the 'Config' value for this httpd.
 226 getConfig ∷ Resource Config
 227 getConfig = niConfig <$> getInteraction
 228
 229 -- |Get the 'SockAddr' of the remote host.
 230 getRemoteAddr ∷ Resource SockAddr
 231 getRemoteAddr = niRemoteAddr <$> getInteraction
 232
 233 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 234 --
 235 --   * This request didn't came through an SSL stream.
 236 --
 237 --   * The client didn't send us its certificate.
 238 --
 239 --   * The 'OpenSSL.Session.VerificationMode' of
 240 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 241 --   'OpenSSL.Session.VerifyPeer'.
 242 getRemoteCertificate ∷ Resource (Maybe X509)
 243 getRemoteCertificate = niRemoteCert <$> getInteraction
 244
 245 -- |Return the 'Request' value representing the request header. You
 246 -- usually don't need to call this function directly.
 247 getRequest ∷ Resource Request
 248 getRequest = niRequest <$> getInteraction
 249
 250 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
 251 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 252 -- action is the exact path in the tree even when the 'ResourceDef' is
 253 -- 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 [Strict.ByteString]
 272 getResourcePath = niResourcePath <$> getInteraction
 273
 274 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
 275 -- bytes. You can incrementally read the request body by repeatedly
 276 -- calling this function. If there is nothing to be read anymore,
 277 -- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
 278 -- the /Deciding Header/ state.
 279 getChunk ∷ Int → Resource Strict.ByteString
 280 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
 281
 282 getChunk' ∷ Int → Resource Strict.ByteString
 283 getChunk' n
 284     | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
 285     | n ≡ 0     = return (∅)
 286     | otherwise = do req ← getRequest
 287                      if reqMustHaveBody req then
 288                          askForInput =≪ getInteraction
 289                      else
 290                          driftTo DecidingHeader *> return (∅)
 291     where
 292       askForInput ∷ NormalInteraction → Resource Strict.ByteString
 293       askForInput (NI {..})
 294           = do -- Ask the RequestReader to get a chunk.
 295                liftIO $ atomically
 296                       $ putTMVar niReceiveBodyReq (ReceiveBody n)
 297                -- Then wait for a reply.
 298                chunk ← liftIO
 299                        $ atomically
 300                        $ takeTMVar niReceivedBody
 301                -- Have we got an EOF?
 302                when (Strict.null chunk)
 303                    $ driftTo DecidingHeader
 304                return chunk
 305
 306 -- |Declare the response status code. If you don't call this function,
 307 -- the status code will be defaulted to \"200 OK\".
 308 setStatus ∷ StatusCode → Resource ()
 309 setStatus sc
 310     = do ni ← getInteraction
 311          liftIO $ atomically
 312                 $ do state ← readTVar $ niState ni
 313                      when (state > DecidingHeader)
 314                          $ fail "Too late to declare the response status."
 315                      setResponseStatus ni sc
 316
 317 -- |@'setHeader' name value@ declares the value of the response header
 318 -- @name@ as @value@. Note that this function is not intended to be
 319 -- used so frequently: there should be specialised functions like
 320 -- 'setContentType' for every common headers.
 321 --
 322 -- Some important headers (especially \"Content-Length\" and
 323 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 324 -- the system not to corrupt the interaction with client at the
 325 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 326 -- the connection alive, without this manipulation it will be a
 327 -- catastrophe when we send a header \"Content-Length: 10\" and
 328 -- actually send a body of 20 bytes long to the remote peer. In this
 329 -- case the client shall only accept the first 10 bytes of response
 330 -- body and thinks that the residual 10 bytes is a part of the header
 331 -- of the next response.
 332 setHeader ∷ CIAscii → Ascii → Resource ()
 333 setHeader name value
 334     = do ni ← getInteraction
 335          liftIO $ atomically $ go ni
 336     where
 337       go ∷ NormalInteraction → STM ()
 338       go (NI {..})
 339           = do state ← readTVar niState
 340                when (state > DecidingHeader) $
 341                    fail "Too late to declare a response header field."
 342                res ← readTVar niResponse
 343                writeTVar niResponse $ H.setHeader name value res
 344                when (name ≡ "Content-Type") $
 345                    writeTVar niResponseHasCType True
 346
 347 -- |@'deleteHeader' name@ deletes a response header @name@ if
 348 -- any. This function is not intended to be used so frequently.
 349 deleteHeader ∷ CIAscii → Resource ()
 350 deleteHeader name
 351     = do ni ← getInteraction
 352          liftIO $ atomically $ go ni
 353     where
 354       go ∷ NormalInteraction → STM ()
 355       go (NI {..})
 356           = do state ← readTVar niState
 357                when (state > DecidingHeader) $
 358                    fail "Too late to delete a response header field."
 359                res ← readTVar niResponse
 360                writeTVar niResponse $ H.deleteHeader name res
 361                when (name ≡ "Content-Type") $
 362                    writeTVar niResponseHasCType False
 363
 364 -- |Run a 'Builder' to construct a chunk, and write it to the response
 365 -- body. It is safe to apply this function to a 'Builder' producing an
 366 -- infinitely long stream of octets.
 367 --
 368 -- Note that you must first declare the response header
 369 -- \"Content-Type\" before applying this function. See
 370 -- 'setContentType'.
 371 putBuilder ∷ Builder → Resource ()
 372 putBuilder b
 373     = do ni ← getInteraction
 374          liftIO $ atomically $ go ni
 375     where
 376       go ∷ NormalInteraction → STM ()
 377       go ni@(NI {..})
 378           = do driftTo' ni SendingBody
 379                hasCType ← readTVar niResponseHasCType
 380                unless hasCType
 381                    $ throwSTM
 382                    $ mkAbortion' InternalServerError
 383                      "putBuilder: Content-Type has not been set."
 384                putTMVar niBodyToSend b
 385
 386 driftTo ∷ InteractionState → Resource ()
 387 driftTo newState
 388     = do ni ← getInteraction
 389          liftIO $ atomically $ driftTo' ni newState
 390
 391 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 392 driftTo' ni@(NI {..}) newState
 393     = do oldState ← readTVar niState
 394          driftFrom oldState
 395     where
 396       driftFrom ∷ InteractionState → STM ()
 397       driftFrom oldState
 398           | newState < oldState = throwStateError oldState newState
 399           | newState ≡ oldState = return ()
 400           | otherwise
 401               = do let a = [oldState .. newState]
 402                        b = tail a
 403                        c = zip a b
 404                    mapM_ (uncurry driftFromTo) c
 405                    writeTVar niState newState
 406
 407       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 408       throwStateError Done SendingBody
 409           = fail "It makes no sense to output something after finishing outputs."
 410       throwStateError old new
 411           = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 412
 413       driftFromTo ∷ InteractionState → InteractionState → STM ()
 414       driftFromTo ReceivingBody _
 415           = putTMVar niReceiveBodyReq WasteAll
 416       driftFromTo DecidingHeader _
 417           = postprocess ni
 418       driftFromTo _ _
 419           = return ()