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 -- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
 265 -- action is the exact path in the tree even when the 'Resource' is
 266 -- 'Network.HTTP.Lucu.greedy'.
 267 --
 268 -- Example:
 269 --
 270 -- @
 271 --   main :: 'IO' ()
 272 --   main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
 273 --              tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
 274 --          in 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
 275 --
 276 --   resFoo :: 'Resource'
 277 --   resFoo = 'singleton'
 278 --            ( 'GET'
 279 --            , do requestURI   <- 'getRequestURI'
 280 --                 resourcePath <- 'getResourcePath'
 281 --                 pathInfo     <- 'getPathInfo'
 282 --                 -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
 283 --                 -- resourcePath       == ["foo"]
 284 --                 -- pathInfo           == ["bar", "baz"]
 285 --                 ...
 286 --            )
 287 -- @
 288 getResourcePath ∷ Rsrc Path
 289 getResourcePath = niResourcePath <$> getInteraction
 290
 291 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
 292 -- bytes. You can incrementally read the request body by repeatedly
 293 -- calling this function. If there is nothing to be read anymore,
 294 -- 'getChunk' returns 'BS.empty' and makes 'Rsrc' transit to the
 295 -- /Deciding Header/ state.
 296 getChunk ∷ Int → Rsrc ByteString
 297 getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
 298
 299 getChunk' ∷ Int → Rsrc ByteString
 300 getChunk' n
 301     | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
 302     | n ≡ 0     = return (∅)
 303     | otherwise = do req ← getRequest
 304                      if reqMustHaveBody req then
 305                          askForInput =≪ getInteraction
 306                      else
 307                          driftTo DecidingHeader *> return (∅)
 308     where
 309       askForInput ∷ NormalInteraction → Rsrc ByteString
 310       askForInput (NI {..})
 311           = do -- Ask the RequestReader to get a chunk.
 312                liftIO $ atomically
 313                       $ putTMVar niReceiveBodyReq (ReceiveBody n)
 314                -- Then wait for a reply.
 315                chunk ← liftIO
 316                        $ atomically
 317                        $ takeTMVar niReceivedBody
 318                -- Have we got an EOF?
 319                when (BS.null chunk)
 320                    $ driftTo DecidingHeader
 321                return chunk
 322
 323 -- |Declare the response status code. If you don't call this function,
 324 -- the status code will be defaulted to \"200 OK\".
 325 setStatus ∷ StatusCode sc ⇒ sc → Rsrc ()
 326 setStatus sc
 327     = do ni ← getInteraction
 328          liftIO $ atomically
 329                 $ do state ← readTVar $ niState ni
 330                      when (state > DecidingHeader)
 331                          $ fail "Too late to declare the response status."
 332                      res ← readTVar $ niResponse ni
 333                      writeTVar (niResponse ni) $ setStatusCode sc res
 334
 335 -- |@'setHeader' name value@ declares the value of the response header
 336 -- @name@ as @value@. Note that this function is not intended to be
 337 -- used so frequently: there should be specialised functions like
 338 -- 'Network.HTTP.Lucu.setContentType' for every common headers.
 339 --
 340 -- Some important headers (especially \"Content-Length\" and
 341 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 342 -- the system not to corrupt the interaction with client at the
 343 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 344 -- the connection alive, without this manipulation it will be a
 345 -- catastrophe when we send a header \"Content-Length: 10\" and
 346 -- actually send a body of 20 bytes long to the remote peer. In this
 347 -- case the client shall only accept the first 10 bytes of response
 348 -- body and thinks that the residual 10 bytes is a part of the header
 349 -- of the next response.
 350 setHeader ∷ CIAscii → Ascii → Rsrc ()
 351 setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
 352     where
 353       go ∷ NormalInteraction → STM ()
 354       go (NI {..})
 355           = do state ← readTVar niState
 356                when (state > DecidingHeader) $
 357                    fail "Too late to declare a response header field."
 358                res ← readTVar niResponse
 359                writeTVar niResponse $ H.setHeader name value res
 360                when (name ≡ "Content-Type") $
 361                    writeTVar niResponseHasCType True
 362
 363 -- |@'deleteHeader' name@ deletes a response header @name@ if
 364 -- any. This function is not intended to be used so frequently.
 365 deleteHeader ∷ CIAscii → Rsrc ()
 366 deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
 367     where
 368       go ∷ NormalInteraction → STM ()
 369       go (NI {..})
 370           = do state ← readTVar niState
 371                when (state > DecidingHeader) $
 372                    fail "Too late to delete a response header field."
 373                res ← readTVar niResponse
 374                writeTVar niResponse $ H.deleteHeader name res
 375                when (name ≡ "Content-Type") $
 376                    writeTVar niResponseHasCType False
 377
 378 -- |Run a 'Builder' to construct a chunk, and write it to the response
 379 -- body. It can be safely applied to a 'Builder' producing an
 380 -- infinitely long stream of octets.
 381 --
 382 -- Note that you must first declare the response header
 383 -- \"Content-Type\" before applying this function. See
 384 -- 'Network.HTTP.Lucu.setContentType'.
 385 putBuilder ∷ Builder → Rsrc ()
 386 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
 387     where
 388       -- FIXME: should see if resCanHaveBody.
 389       go ∷ NormalInteraction → STM ()
 390       go ni@(NI {..})
 391           = do driftTo' ni SendingBody
 392                hasCType ← readTVar niResponseHasCType
 393                unless hasCType
 394                    $ throwSTM
 395                    $ mkAbortion' InternalServerError
 396                      "putBuilder: Content-Type has not been set."
 397                putTMVar niBodyToSend b
 398
 399 driftTo ∷ InteractionState → Rsrc ()
 400 driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
 401
 402 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 403 driftTo' ni@(NI {..}) newState
 404     = do oldState ← readTVar niState
 405          driftFrom oldState
 406     where
 407       driftFrom ∷ InteractionState → STM ()
 408       driftFrom oldState
 409           | newState < oldState = throwStateError oldState newState
 410           | newState ≡ oldState = return ()
 411           | otherwise
 412               = do let a = [oldState .. newState]
 413                        b = tail a
 414                        c = zip a b
 415                    mapM_ (uncurry driftFromTo) c
 416                    writeTVar niState newState
 417
 418       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 419       throwStateError Done SendingBody
 420           = fail "It makes no sense to output something after finishing outputs."
 421       throwStateError old new
 422           = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 423
 424       driftFromTo ∷ InteractionState → InteractionState → STM ()
 425       driftFromTo ReceivingBody _
 426           = putTMVar niReceiveBodyReq WasteAll
 427       driftFromTo DecidingHeader _
 428           = postprocess ni
 429       driftFromTo _ _
 430           = return ()