Network/HTTP/Lucu/Resource/Internal.hs

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