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