Network/HTTP/Lucu/Resource/Internal.hs

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