Network/HTTP/Lucu/Resource/Tree.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   #-}
   7 {-# OPTIONS_HADDOCK prune #-}
   8
   9 -- | Repository of the resources in httpd.
  10 module Network.HTTP.Lucu.Resource.Tree
  11     ( ResourceDef(..)
  12     , emptyResource
  13
  14     , ResTree
  15     , FallbackHandler
  16
  17     , mkResTree
  18
  19     , findResource
  20     , runResource
  21     )
  22     where
  23 import           Control.Arrow
  24 import Control.Applicative
  25 import Data.Ascii (Ascii)
  26 import qualified Data.Ascii as A
  27 import           Control.Concurrent
  28 import           Control.Concurrent.STM
  29 import           Control.Exception
  30 import           Control.Monad
  31 import Data.Text (Text)
  32 import qualified Data.Text as T
  33 import qualified Data.Text.Lazy.Encoding as LT
  34 import           Data.List
  35 import qualified Data.Map as M
  36 import           Data.Map (Map)
  37 import           Data.Maybe
  38 import Data.Monoid.Unicode
  39 import           Network.HTTP.Lucu.Abortion
  40 import           Network.HTTP.Lucu.Config
  41 import           Network.HTTP.Lucu.Headers (fromHeaders)
  42 import           Network.HTTP.Lucu.Request
  43 import           Network.HTTP.Lucu.Resource
  44 import           Network.HTTP.Lucu.Response
  45 import           Network.HTTP.Lucu.Interaction
  46 import           Network.HTTP.Lucu.Utils
  47 import           Network.URI hiding (path)
  48 import           System.IO
  49 import           Prelude hiding (catch)
  50 import Prelude.Unicode
  51
  52
  53 -- |'FallbackHandler' is an extra resource handler for resources which
  54 -- can't be statically located anywhere in the resource tree. The Lucu
  55 -- httpd first searches for a resource in the tree, and then calls
  56 -- fallback handlers to ask them for a resource. If all of the
  57 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
  58 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
  59
  60
  61 -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
  62 -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
  63 -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
  64 -- 無視される。
  65
  66 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
  67 -- HTTP methods.
  68 data ResourceDef = ResourceDef {
  69     -- |Whether to run a 'Resource' on a native thread (spawned by
  70     -- 'forkOS') or to run it on a user thread (spanwed by
  71     -- 'forkIO'). Generally you don't need to set this field to
  72     -- 'True'.
  73       resUsesNativeThread ∷ !Bool
  74     -- | Whether to be greedy or not.
  75     --
  76     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  77     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  78     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  79     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  80     -- resources are like CGI scripts.
  81     , resIsGreedy         ∷ !Bool
  82     -- | A 'Resource' to be run when a GET request comes for the
  83     -- resource path. If 'resGet' is Nothing, the system responds
  84     -- \"405 Method Not Allowed\" for GET requests.
  85     --
  86     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  87     -- this case 'output' and such like don't actually write a
  88     -- response body.
  89     , resGet              ∷ !(Maybe (Resource ()))
  90     -- | A 'Resource' to be run when a HEAD request comes for the
  91     -- resource path. If 'resHead' is Nothing, the system runs
  92     -- 'resGet' instead. If 'resGet' is also Nothing, the system
  93     -- responds \"405 Method Not Allowed\" for HEAD requests.
  94     , resHead             ∷ !(Maybe (Resource ()))
  95     -- | A 'Resource' to be run when a POST request comes for the
  96     -- resource path. If 'resPost' is Nothing, the system responds
  97     -- \"405 Method Not Allowed\" for POST requests.
  98     , resPost             ∷ !(Maybe (Resource ()))
  99     -- | A 'Resource' to be run when a PUT request comes for the
 100     -- resource path. If 'resPut' is Nothing, the system responds
 101     -- \"405 Method Not Allowed\" for PUT requests.
 102     , resPut              ∷ !(Maybe (Resource ()))
 103     -- | A 'Resource' to be run when a DELETE request comes for the
 104     -- resource path. If 'resDelete' is Nothing, the system responds
 105     -- \"405 Method Not Allowed\" for DELETE requests.
 106     , resDelete           ∷ !(Maybe (Resource ()))
 107     }
 108
 109 -- |'emptyResource' is a resource definition with no actual
 110 -- handlers. You can construct a 'ResourceDef' by selectively
 111 -- overriding 'emptyResource'. It is defined as follows:
 112 --
 113 -- @
 114 --   emptyResource = ResourceDef {
 115 --                     resUsesNativeThread = False
 116 --                   , resIsGreedy         = False
 117 --                   , resGet              = Nothing
 118 --                   , resHead             = Nothing
 119 --                   , resPost             = Nothing
 120 --                   , resPut              = Nothing
 121 --                   , resDelete           = Nothing
 122 --                   }
 123 -- @
 124 emptyResource ∷ ResourceDef
 125 emptyResource = ResourceDef {
 126                   resUsesNativeThread = False
 127                 , resIsGreedy         = False
 128                 , resGet              = Nothing
 129                 , resHead             = Nothing
 130                 , resPost             = Nothing
 131                 , resPut              = Nothing
 132                 , resDelete           = Nothing
 133                 }
 134
 135 -- |'ResTree' is an opaque structure which is a map from resource path
 136 -- to 'ResourceDef'.
 137 newtype ResTree = ResTree ResNode -- root だから Map ではない
 138 type ResSubtree = Map Text ResNode
 139 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
 140
 141 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 142 --
 143 -- @
 144 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
 145 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
 146 --             ]
 147 -- @
 148 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
 149 mkResTree = processRoot . map (first canonicalisePath)
 150     where
 151       canonicalisePath ∷ [Text] → [Text]
 152       canonicalisePath = filter (≢ "")
 153
 154       processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
 155       processRoot list
 156           = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
 157                 children = processNonRoot nonRoots
 158             in
 159               if null roots then
 160                   -- The root has no resources. Maybe there's one at
 161                   -- somewhere like "/foo".
 162                   ResTree (ResNode Nothing children)
 163               else
 164                   -- There is a root resource.
 165                   let (_, def) = last roots
 166                   in
 167                     ResTree (ResNode (Just def) children)
 168
 169       processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
 170       processNonRoot list
 171           = let subtree    = M.fromList [(name, node name)
 172                                              | name ← childNames]
 173                 childNames = [name | (name:_, _) ← list]
 174                 node name  = let defs = [def | (path, def) ← list, path == [name]]
 175                              in
 176                                if null defs then
 177                                    -- No resources are defined
 178                                    -- here. Maybe there's one at
 179                                    -- somewhere below this node.
 180                                    ResNode Nothing children
 181                                else
 182                                    -- There is a resource here.
 183                                    ResNode (Just $ last defs) children
 184                 children   = processNonRoot [(path, def)
 185                                                  | (_:path, def) ← list]
 186             in
 187               subtree
 188
 189
 190 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
 191 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 192     = do let path           = splitPathInfo uri
 193              haveGreedyRoot = case rootDefM of
 194                                 Just def → resIsGreedy def
 195                                 Nothing  → False
 196              foundInTree    = if haveGreedyRoot ∨ null path then
 197                                   do def ← rootDefM
 198                                      return ([], def)
 199                               else
 200                                   walkTree subtree path []
 201          if isJust foundInTree then
 202              return foundInTree
 203          else
 204              fallback path fbs
 205     where
 206       walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
 207
 208       walkTree _ [] _
 209           = error "Internal error: should not reach here."
 210
 211       walkTree tree (name:[]) soFar
 212           = case M.lookup name tree of
 213               Nothing               → Nothing
 214               Just (ResNode defM _) → do def ← defM
 215                                          return (soFar ⧺ [name], def)
 216
 217       walkTree tree (x:xs) soFar
 218           = case M.lookup x tree of
 219               Nothing                      → Nothing
 220               Just (ResNode defM children) → case defM of
 221                                                 Just (ResourceDef { resIsGreedy = True })
 222                                                     → do def ← defM
 223                                                          return (soFar ++ [x], def)
 224                                                 _   → walkTree children xs (soFar ++ [x])
 225
 226       fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
 227       fallback _    []     = return Nothing
 228       fallback path (x:xs) = do m ← x path
 229                                 case m of
 230                                   Just def → return $! Just ([], def)
 231                                   Nothing  → fallback path xs
 232
 233
 234 runResource ∷ ResourceDef → Interaction → IO ThreadId
 235 runResource (ResourceDef {..}) itr@(Interaction {..})
 236     = fork $ ( runRes ( do req ← getRequest
 237                            fromMaybe notAllowed $ rsrc req
 238                            driftTo Done
 239                       ) itr
 240              )
 241              `catch`
 242              processException
 243     where
 244       fork ∷ IO () → IO ThreadId
 245       fork | resUsesNativeThread = forkOS
 246            | otherwise           = forkIO
 247
 248       rsrc ∷ Request → Maybe (Resource ())
 249       rsrc req
 250           = case reqMethod req of
 251               GET    → resGet
 252               HEAD   → case resHead of
 253                           Just r  → Just r
 254                           Nothing → resGet
 255               POST   → resPost
 256               PUT    → resPut
 257               DELETE → resDelete
 258               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 259
 260       notAllowed ∷ Resource ()
 261       notAllowed
 262           = setStatus MethodNotAllowed
 263             *>
 264             (setHeader "Allow" $ A.fromAsciiBuilder
 265                                $ joinWith ", "
 266                                $ map A.toAsciiBuilder allowedMethods)
 267
 268       allowedMethods ∷ [Ascii]
 269       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 270                                     , methods resHead   ["GET", "HEAD"]
 271                                     , methods resPost   ["POST"]
 272                                     , methods resPut    ["PUT"]
 273                                     , methods resDelete ["DELETE"]
 274                                     ]
 275
 276       methods ∷ Maybe a → [Ascii] → [Ascii]
 277       methods m xs
 278           = case m of
 279               Just _  → xs
 280               Nothing → []
 281
 282       toAbortion ∷ SomeException → Abortion
 283       toAbortion e
 284           = case fromException e of
 285               Just abortion → abortion
 286               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
 287
 288       processException ∷ SomeException → IO ()
 289       processException exc
 290           = do let abo = toAbortion exc
 291                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 292                -- を應答に反映させる餘地がある。さうでなければ stderr
 293                -- にでも吐くしか無い。
 294                state ← atomically $ readTVar itrState
 295                reqM  ← atomically $ readTVar itrRequest
 296                res   ← atomically $ readTVar itrResponse
 297                if state ≤ DecidingHeader then
 298                    flip runRes itr $
 299                        do setStatus $ aboStatus abo
 300                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
 301                           output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
 302                  else
 303                    when (cnfDumpTooLateAbortionToStderr itrConfig)
 304                             $ hPutStrLn stderr $ show abo
 305
 306                runRes (driftTo Done) itr