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