Network/HTTP/Lucu/Resource/Tree.hs

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