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
  45 import Data.Monoid.Unicode
  46 import qualified Data.Text as T
  47 import Network.HTTP.Lucu.Abortion
  48 import Network.HTTP.Lucu.Abortion.Internal
  49 import Network.HTTP.Lucu.Config
  50 import Network.HTTP.Lucu.DefaultPage
  51 import qualified Network.HTTP.Lucu.Headers as H
  52 import Network.HTTP.Lucu.Interaction
  53 import Network.HTTP.Lucu.Postprocess
  54 import Network.HTTP.Lucu.Request
  55 import Network.HTTP.Lucu.Response
  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     -- that case 'putChunk' and such don't actually write a response
  95     -- 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 = do setStatus MethodNotAllowed
 170                       setHeader "Allow"
 171                           $ A.fromAsciiBuilder
 172                           $ mconcat
 173                           $ intersperse (A.toAsciiBuilder ", ")
 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 = emptyResource {
 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 getResourcePath ∷ Resource [Strict.ByteString]
 271 getResourcePath = niResourcePath <$> getInteraction
 272
 273 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
 274 -- bytes. You can incrementally read the request body by repeatedly
 275 -- calling this function. If there is nothing to be read anymore,
 276 -- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
 277 -- the /Deciding Header/ state.
 278 getChunk ∷ Int → Resource Strict.ByteString
 279 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
 280
 281 getChunk' ∷ Int → Resource Strict.ByteString
 282 getChunk' n
 283     | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
 284     | n ≡ 0     = return (∅)
 285     | otherwise = do req ← getRequest
 286                      if reqMustHaveBody req then
 287                          askForInput =≪ getInteraction
 288                      else
 289                          driftTo DecidingHeader *> return (∅)
 290     where
 291       askForInput ∷ NormalInteraction → Resource Strict.ByteString
 292       askForInput (NI {..})
 293           = do -- Ask the RequestReader to get a chunk.
 294                liftIO $ atomically
 295                       $ putTMVar niReceiveBodyReq (ReceiveBody n)
 296                -- Then wait for a reply.
 297                chunk ← liftIO
 298                        $ atomically
 299                        $ takeTMVar niReceivedBody
 300                -- Have we got an EOF?
 301                when (Strict.null chunk)
 302                    $ driftTo DecidingHeader
 303                return chunk
 304
 305 -- |Declare the response status code. If you don't call this function,
 306 -- the status code will be defaulted to \"200 OK\".
 307 setStatus ∷ StatusCode sc ⇒ sc → Resource ()
 308 setStatus sc
 309     = do ni ← getInteraction
 310          liftIO $ atomically
 311                 $ do state ← readTVar $ niState ni
 312                      when (state > DecidingHeader)
 313                          $ fail "Too late to declare the response status."
 314                      setResponseStatus ni sc
 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 → Resource ()
 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 → Resource ()
 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 → Resource ()
 367 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
 368     where
 369       go ∷ NormalInteraction → STM ()
 370       go ni@(NI {..})
 371           = do driftTo' ni SendingBody
 372                hasCType ← readTVar niResponseHasCType
 373                unless hasCType
 374                    $ throwSTM
 375                    $ mkAbortion' InternalServerError
 376                      "putBuilder: Content-Type has not been set."
 377                putTMVar niBodyToSend b
 378
 379 driftTo ∷ InteractionState → Resource ()
 380 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
 381
 382 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 383 driftTo' ni@(NI {..}) newState
 384     = do oldState ← readTVar niState
 385          driftFrom oldState
 386     where
 387       driftFrom ∷ InteractionState → STM ()
 388       driftFrom oldState
 389           | newState < oldState = throwStateError oldState newState
 390           | newState ≡ oldState = return ()
 391           | otherwise
 392               = do let a = [oldState .. newState]
 393                        b = tail a
 394                        c = zip a b
 395                    mapM_ (uncurry driftFromTo) c
 396                    writeTVar niState newState
 397
 398       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 399       throwStateError Done SendingBody
 400           = fail "It makes no sense to output something after finishing outputs."
 401       throwStateError old new
 402           = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 403
 404       driftFromTo ∷ InteractionState → InteractionState → STM ()
 405       driftFromTo ReceivingBody _
 406           = putTMVar niReceiveBodyReq WasteAll
 407       driftFromTo DecidingHeader _
 408           = postprocess ni
 409       driftFromTo _ _
 410           = return ()