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.DefaultPage
  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 --
 149 -- Note that the request path in an incoming HTTP request is always
 150 -- treated as an URI-encoded UTF-8 string.
 151 mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
 152 mkResTree = processRoot ∘ map (first canonicalisePath)
 153     where
 154       canonicalisePath ∷ [Text] → [Text]
 155       canonicalisePath = filter (≢ "")
 156
 157       processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
 158       processRoot list
 159           = let (roots, nonRoots) = partition (\(path, _) → null path) list
 160                 children = processNonRoot nonRoots
 161             in
 162               if null roots then
 163                   -- The root has no resources. Maybe there's one at
 164                   -- somewhere like "/foo".
 165                   ResTree (ResNode Nothing children)
 166               else
 167                   -- There is a root resource.
 168                   let (_, def) = last roots
 169                   in
 170                     ResTree (ResNode (Just def) children)
 171
 172       processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
 173       processNonRoot list
 174           = let subtree    = M.fromList [(name, node name)
 175                                              | name ← childNames]
 176                 childNames = [name | (name:_, _) ← list]
 177                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
 178                              in
 179                                if null defs then
 180                                    -- No resources are defined
 181                                    -- here. Maybe there's one at
 182                                    -- somewhere below this node.
 183                                    ResNode Nothing children
 184                                else
 185                                    -- There is a resource here.
 186                                    ResNode (Just $ last defs) children
 187                 children   = processNonRoot [(path, def)
 188                                                  | (_:path, def) ← list]
 189             in
 190               subtree
 191
 192 findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
 193 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 194     = do let path          = splitPathInfo uri
 195              hasGreedyRoot = maybe False resIsGreedy rootDefM
 196              foundInTree    = if hasGreedyRoot ∨ 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           = do ResNode defM _ ← M.lookup name tree
 213                def            ← defM
 214                return (soFar ⧺ [name], def)
 215
 216       walkTree tree (x:xs) soFar
 217           = do ResNode defM sub ← M.lookup x tree
 218                case defM of
 219                  Just (ResourceDef { resIsGreedy = True })
 220                      → do def ← defM
 221                           return (soFar ⧺ [x], def)
 222                  _   → walkTree sub xs (soFar ⧺ [x])
 223
 224       fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
 225       fallback _    []     = return Nothing
 226       fallback path (x:xs) = do m ← x path
 227                                 case m of
 228                                   Just def → return $ Just ([], def)
 229                                   Nothing  → fallback path xs
 230
 231
 232 runResource ∷ ResourceDef → Interaction → IO ThreadId
 233 runResource (ResourceDef {..}) itr@(Interaction {..})
 234     = fork $ run `catch` processException
 235     where
 236       fork ∷ IO () → IO ThreadId
 237       fork | resUsesNativeThread = forkOS
 238            | otherwise           = forkIO
 239
 240       run ∷ IO ()
 241       run = flip runRes itr $
 242             do req ← getRequest
 243                fromMaybe notAllowed $ rsrc req
 244                driftTo Done
 245
 246       rsrc ∷ Request → Maybe (Resource ())
 247       rsrc req
 248           = case reqMethod req of
 249               GET    → resGet
 250               HEAD   → case resHead of
 251                           Just r  → Just r
 252                           Nothing → resGet
 253               POST   → resPost
 254               PUT    → resPut
 255               DELETE → resDelete
 256               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 257
 258       notAllowed ∷ Resource ()
 259       notAllowed
 260           = setStatus MethodNotAllowed
 261             *>
 262             (setHeader "Allow" $ A.fromAsciiBuilder
 263                                $ joinWith ", "
 264                                $ map A.toAsciiBuilder allowedMethods)
 265
 266       allowedMethods ∷ [Ascii]
 267       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 268                                     , methods resHead   ["GET", "HEAD"]
 269                                     , methods resPost   ["POST"]
 270                                     , methods resPut    ["PUT"]
 271                                     , methods resDelete ["DELETE"]
 272                                     ]
 273
 274       methods ∷ Maybe a → [Ascii] → [Ascii]
 275       methods m xs
 276           | isJust m  = xs
 277           | otherwise = []
 278
 279       toAbortion ∷ SomeException → Abortion
 280       toAbortion e
 281           = case fromException e of
 282               Just abortion → abortion
 283               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
 284
 285       processException ∷ SomeException → IO ()
 286       processException exc
 287           = do let abo = toAbortion exc
 288                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 289                -- を應答に反映させる餘地がある。さうでなければ stderr
 290                -- にでも吐くしか無い。
 291                state ← atomically $ readTVar itrState
 292                res   ← atomically $ readTVar itrResponse
 293                if state ≤ DecidingHeader then
 294                    flip runRes itr $
 295                        do setStatus $ aboStatus abo
 296                           setHeader "Content-Type" defaultPageContentType
 297                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
 298                           putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
 299                else
 300                    when (cnfDumpTooLateAbortionToStderr itrConfig)
 301                        $ dumpAbortion abo
 302                runRes (driftTo Done) itr
 303
 304 dumpAbortion ∷ Abortion → IO ()
 305 dumpAbortion abo
 306     = hPutStr stderr
 307       $ concat [ "Lucu: an exception occured after "
 308                , "sending response header to the client:\n"
 309                , "  ", show abo, "\n"
 310                ]