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