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