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                      setResponseStatus ni sc
 322
 323 -- |@'setHeader' name value@ declares the value of the response header
 324 -- @name@ as @value@. Note that this function is not intended to be
 325 -- used so frequently: there should be specialised functions like
 326 -- 'setContentType' for every common headers.
 327 --
 328 -- Some important headers (especially \"Content-Length\" and
 329 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 330 -- the system not to corrupt the interaction with client at the
 331 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 332 -- the connection alive, without this manipulation it will be a
 333 -- catastrophe when we send a header \"Content-Length: 10\" and
 334 -- actually send a body of 20 bytes long to the remote peer. In this
 335 -- case the client shall only accept the first 10 bytes of response
 336 -- body and thinks that the residual 10 bytes is a part of the header
 337 -- of the next response.
 338 setHeader ∷ CIAscii → Ascii → Resource ()
 339 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
 340     where
 341       go ∷ NormalInteraction → STM ()
 342       go (NI {..})
 343           = do state ← readTVar niState
 344                when (state > DecidingHeader) $
 345                    fail "Too late to declare a response header field."
 346                res ← readTVar niResponse
 347                writeTVar niResponse $ H.setHeader name value res
 348                when (name ≡ "Content-Type") $
 349                    writeTVar niResponseHasCType True
 350
 351 -- |@'deleteHeader' name@ deletes a response header @name@ if
 352 -- any. This function is not intended to be used so frequently.
 353 deleteHeader ∷ CIAscii → Resource ()
 354 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
 355     where
 356       go ∷ NormalInteraction → STM ()
 357       go (NI {..})
 358           = do state ← readTVar niState
 359                when (state > DecidingHeader) $
 360                    fail "Too late to delete a response header field."
 361                res ← readTVar niResponse
 362                writeTVar niResponse $ H.deleteHeader name res
 363                when (name ≡ "Content-Type") $
 364                    writeTVar niResponseHasCType False
 365
 366 -- |Run a 'Builder' to construct a chunk, and write it to the response
 367 -- body. It can be safely applied to a 'Builder' producing an
 368 -- infinitely long stream of octets.
 369 --
 370 -- Note that you must first declare the response header
 371 -- \"Content-Type\" before applying this function. See:
 372 -- 'setContentType'
 373 putBuilder ∷ Builder → Resource ()
 374 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
 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 = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
 388
 389 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 390 driftTo' ni@(NI {..}) newState
 391     = do oldState ← readTVar niState
 392          driftFrom oldState
 393     where
 394       driftFrom ∷ InteractionState → STM ()
 395       driftFrom oldState
 396           | newState < oldState = throwStateError oldState newState
 397           | newState ≡ oldState = return ()
 398           | otherwise
 399               = do let a = [oldState .. newState]
 400                        b = tail a
 401                        c = zip a b
 402                    mapM_ (uncurry driftFromTo) c
 403                    writeTVar niState newState
 404
 405       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 406       throwStateError Done SendingBody
 407           = fail "It makes no sense to output something after finishing outputs."
 408       throwStateError old new
 409           = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 410
 411       driftFromTo ∷ InteractionState → InteractionState → STM ()
 412       driftFromTo ReceivingBody _
 413           = putTMVar niReceiveBodyReq WasteAll
 414       driftFromTo DecidingHeader _
 415           = postprocess ni
 416       driftFromTo _ _
 417           = return ()