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 Data.Ascii (Ascii, CIAscii)
  39 import qualified Data.Ascii as A
  40 import qualified Data.ByteString as Strict
  41 import Data.List
  42 import Data.Maybe
  43 import Data.Monoid.Unicode
  44 import qualified Data.Text as T
  45 import Network.HTTP.Lucu.Abortion
  46 import Network.HTTP.Lucu.Config
  47 import Network.HTTP.Lucu.DefaultPage
  48 import qualified Network.HTTP.Lucu.Headers as H
  49 import Network.HTTP.Lucu.Interaction
  50 import Network.HTTP.Lucu.Postprocess
  51 import Network.HTTP.Lucu.Request
  52 import Network.HTTP.Lucu.Response
  53 import Network.HTTP.Lucu.Utils
  54 import Network.Socket
  55 import OpenSSL.X509
  56 import Prelude hiding (catch)
  57 import Prelude.Unicode
  58 import System.IO
  59
  60 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
  61 -- any 'IO' actions.
  62 newtype Resource a
  63     = Resource {
  64         unResource ∷ ReaderT Interaction IO a
  65       }
  66     deriving (Applicative, Functor, Monad, MonadIO)
  67
  68 runResource ∷ Resource a → Interaction → IO a
  69 runResource = runReaderT ∘ unResource
  70
  71 -- |'ResourceDef' is basically a set of 'Resource' monads for each
  72 -- HTTP methods.
  73 data ResourceDef = ResourceDef {
  74     -- |Whether to run a 'Resource' on a native thread (spawned by
  75     -- 'forkOS') or to run it on a user thread (spanwed by
  76     -- 'forkIO'). Generally you don't need to set this field to
  77     -- 'True'.
  78       resUsesNativeThread ∷ !Bool
  79     -- | Whether to be greedy or not.
  80     --
  81     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  82     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  83     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  84     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  85     -- resources are like CGI scripts.
  86     , resIsGreedy         ∷ !Bool
  87     -- |A 'Resource' to be run when a GET request comes for the
  88     -- resource path. If 'resGet' is Nothing, the system responds
  89     -- \"405 Method Not Allowed\" for GET requests.
  90     --
  91     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  92     -- this case 'output' and such like don't actually write a
  93     -- response body.
  94     , resGet              ∷ !(Maybe (Resource ()))
  95     -- |A 'Resource' to be run when a HEAD request comes for the
  96     -- resource path. If 'resHead' is Nothing, the system runs
  97     -- 'resGet' instead. If 'resGet' is also Nothing, the system
  98     -- responds \"405 Method Not Allowed\" for HEAD requests.
  99     , resHead             ∷ !(Maybe (Resource ()))
 100     -- |A 'Resource' to be run when a POST request comes for the
 101     -- resource path. If 'resPost' is Nothing, the system responds
 102     -- \"405 Method Not Allowed\" for POST requests.
 103     , resPost             ∷ !(Maybe (Resource ()))
 104     -- |A 'Resource' to be run when a PUT request comes for the
 105     -- resource path. If 'resPut' is Nothing, the system responds
 106     -- \"405 Method Not Allowed\" for PUT requests.
 107     , resPut              ∷ !(Maybe (Resource ()))
 108     -- |A 'Resource' to be run when a DELETE request comes for the
 109     -- resource path. If 'resDelete' is Nothing, the system responds
 110     -- \"405 Method Not Allowed\" for DELETE requests.
 111     , resDelete           ∷ !(Maybe (Resource ()))
 112     }
 113
 114 -- |'emptyResource' is a resource definition with no actual
 115 -- handlers. You can construct a 'ResourceDef' by selectively
 116 -- overriding 'emptyResource'. It is defined as follows:
 117 --
 118 -- @
 119 --   emptyResource = ResourceDef {
 120 --                     resUsesNativeThread = False
 121 --                   , resIsGreedy         = False
 122 --                   , resGet              = Nothing
 123 --                   , resHead             = Nothing
 124 --                   , resPost             = Nothing
 125 --                   , resPut              = Nothing
 126 --                   , resDelete           = Nothing
 127 --                   }
 128 -- @
 129 emptyResource ∷ ResourceDef
 130 emptyResource = ResourceDef {
 131                   resUsesNativeThread = False
 132                 , resIsGreedy         = False
 133                 , resGet              = Nothing
 134                 , resHead             = Nothing
 135                 , resPost             = Nothing
 136                 , resPut              = Nothing
 137                 , resDelete           = Nothing
 138                 }
 139
 140 spawnResource ∷ ResourceDef → Interaction → IO ThreadId
 141 spawnResource (ResourceDef {..}) itr@(Interaction {..})
 142     = fork $ run `catch` processException
 143     where
 144       fork ∷ IO () → IO ThreadId
 145       fork | resUsesNativeThread = forkOS
 146            | otherwise           = forkIO
 147
 148       run ∷ IO ()
 149       run = flip runResource itr $
 150             do req ← getRequest
 151                fromMaybe notAllowed $ rsrc req
 152                driftTo Done
 153
 154       rsrc ∷ Request → Maybe (Resource ())
 155       rsrc req
 156           = case reqMethod req of
 157               GET    → resGet
 158               HEAD   → case resHead of
 159                           Just r  → Just r
 160                           Nothing → resGet
 161               POST   → resPost
 162               PUT    → resPut
 163               DELETE → resDelete
 164               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 165
 166       notAllowed ∷ Resource ()
 167       notAllowed
 168           = setStatus MethodNotAllowed
 169             *>
 170             (setHeader "Allow" $ A.fromAsciiBuilder
 171                                $ joinWith ", "
 172                                $ map A.toAsciiBuilder allowedMethods)
 173
 174       allowedMethods ∷ [Ascii]
 175       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 176                                     , methods resHead   ["GET", "HEAD"]
 177                                     , methods resPost   ["POST"]
 178                                     , methods resPut    ["PUT"]
 179                                     , methods resDelete ["DELETE"]
 180                                     ]
 181
 182       methods ∷ Maybe a → [Ascii] → [Ascii]
 183       methods m xs
 184           | isJust m  = xs
 185           | otherwise = []
 186
 187       toAbortion ∷ SomeException → Abortion
 188       toAbortion e
 189           = case fromException e of
 190               Just abortion → abortion
 191               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
 192
 193       processException ∷ SomeException → IO ()
 194       processException exc
 195           = do let abo = toAbortion exc
 196                state ← atomically $ readTVar itrState
 197                res   ← atomically $ readTVar itrResponse
 198                if state ≤ DecidingHeader then
 199                    -- We still have a chance to reflect this abortion
 200                    -- in the response. Hooray!
 201                    flip runResource itr $
 202                        do setStatus $ aboStatus abo
 203                           setHeader "Content-Type" defaultPageContentType
 204                           deleteHeader "Content-Encoding"
 205                           mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
 206                           putBuilder $ abortPage itrConfig itrRequest res abo
 207                else
 208                    when (cnfDumpTooLateAbortionToStderr itrConfig)
 209                        $ dumpAbortion abo
 210                runResource (driftTo Done) itr
 211
 212 dumpAbortion ∷ Abortion → IO ()
 213 dumpAbortion abo
 214     = hPutStr stderr
 215       $ concat [ "Lucu: an exception occured after "
 216                , "sending the response header to the client:\n"
 217                , "  ", show abo, "\n"
 218                ]
 219
 220 getInteraction ∷ Resource Interaction
 221 getInteraction = Resource ask
 222
 223 -- |Get the 'Config' value for this httpd.
 224 getConfig ∷ Resource Config
 225 getConfig = itrConfig <$> getInteraction
 226
 227 -- |Get the 'SockAddr' of the remote host.
 228 getRemoteAddr ∷ Resource SockAddr
 229 getRemoteAddr = itrRemoteAddr <$> getInteraction
 230
 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 ∷ Resource (Maybe X509)
 241 getRemoteCertificate = itrRemoteCert <$> getInteraction
 242
 243 -- |Return the 'Request' value representing the request header. You
 244 -- usually don't need to call this function directly.
 245 getRequest ∷ Resource Request
 246 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 247
 248 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
 249 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 250 -- action is the exact path in the tree even when the 'ResourceDef' is
 251 -- greedy.
 252 --
 253 -- Example:
 254 --
 255 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 256 -- >        in runHttpd defaultConfig tree []
 257 -- >
 258 -- > resFoo = ResourceDef {
 259 -- >     resIsGreedy = True
 260 -- >   , resGet = Just $ do requestURI   <- getRequestURI
 261 -- >                        resourcePath <- getResourcePath
 262 -- >                        pathInfo     <- getPathInfo
 263 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 264 -- >                        -- resourcePath       == ["foo"]
 265 -- >                        -- pathInfo           == ["bar", "baz"]
 266 -- >                        ...
 267 -- >   , ...
 268 -- >   }
 269 getResourcePath ∷ Resource [Strict.ByteString]
 270 getResourcePath = (fromJust ∘ itrResourcePath) <$> 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 'Resource' transit to
 276 -- the /Deciding Header/ state.
 277 getChunk ∷ Int → Resource Strict.ByteString
 278 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
 279
 280 getChunk' ∷ Int → Resource 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                          do itr ← getInteraction
 287                             askForInput itr
 288                      else
 289                          driftTo DecidingHeader *> return (∅)
 290     where
 291       askForInput ∷ Interaction → Resource Strict.ByteString
 292       askForInput (Interaction {..})
 293           = do -- Ask the RequestReader to get a chunk.
 294                liftIO $ atomically
 295                       $ putTMVar itrReceiveBodyReq (ReceiveBody n)
 296                -- Then wait for a reply.
 297                chunk ← liftIO
 298                        $ atomically
 299                        $ takeTMVar itrReceivedBody
 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 → Resource ()
 308 setStatus sc
 309     = do itr ← getInteraction
 310          liftIO $ atomically
 311                 $ do state ← readTVar $ itrState itr
 312                      when (state > DecidingHeader)
 313                          $ fail "Too late to declare the response status."
 314                      setResponseStatus itr 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
 333     = do itr ← getInteraction
 334          liftIO $ atomically
 335                 $ do state ← readTVar $ itrState itr
 336                      when (state > DecidingHeader)
 337                          $ fail "Too late to declare a response header field."
 338                      res ← readTVar $ itrResponse itr
 339                      let res' = H.setHeader name value res
 340                      writeTVar (itrResponse itr) res'
 341                      when (name ≡ "Content-Type")
 342                          $ writeTVar (itrResponseHasCType itr) 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
 348     = do itr ← getInteraction
 349          liftIO $ atomically
 350                 $ do state ← readTVar $ itrState itr
 351                      when (state > DecidingHeader)
 352                          $ fail "Too late to delete a response header field."
 353                      res ← readTVar $ itrResponse itr
 354                      let res' = H.deleteHeader name res
 355                      writeTVar (itrResponse itr) res'
 356                      when (name ≡ "Content-Type")
 357                          $ writeTVar (itrResponseHasCType itr) False
 358
 359 -- |Run a 'Builder' to construct a chunk, and write it to the response
 360 -- body. It is safe to apply this function 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
 368     = do itr ← getInteraction
 369          liftIO $ atomically
 370                 $ do driftTo' itr SendingBody
 371                      hasCType ← readTVar $ itrResponseHasCType itr
 372                      unless hasCType
 373                          $ abortSTM InternalServerError []
 374                          $ Just "putBuilder: Content-Type has not been set."
 375                      putTMVar (itrBodyToSend itr) b
 376
 377 driftTo ∷ InteractionState → Resource ()
 378 driftTo newState
 379     = do itr ← getInteraction
 380          liftIO $ atomically $ driftTo' itr newState
 381
 382 driftTo' ∷ Interaction → InteractionState → STM ()
 383 driftTo' itr@(Interaction {..}) newState
 384     = do oldState ← readTVar itrState
 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 itrState 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 itrReceiveBodyReq WasteAll
 407       driftFromTo DecidingHeader _
 408           = postprocess itr
 409       driftFromTo _ _
 410           = return ()