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