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     ( ResTree
  11     , FallbackHandler
  12
  13     , mkResTree
  14     , findResource
  15     )
  16     where
  17 import Control.Arrow
  18 import Data.ByteString (ByteString)
  19 import qualified Data.ByteString as BS
  20 import Control.Monad
  21 import Data.Foldable
  22 import Data.List
  23 import qualified Data.Map as M
  24 import Data.Map (Map)
  25 import Data.Maybe
  26 import Data.Monoid.Unicode
  27 import Data.Sequence (Seq)
  28 import Data.Sequence.Unicode hiding ((∅))
  29 import Network.HTTP.Lucu.Resource.Internal
  30 import Network.HTTP.Lucu.Utils
  31 import Network.URI hiding (path)
  32 import System.IO
  33 import Prelude hiding (catch)
  34 import Prelude.Unicode
  35
  36 -- |'FallbackHandler' is an extra resource handler for resources which
  37 -- can't be statically located anywhere in the resource tree. The Lucu
  38 -- httpd first searches for a resource in the tree, and then calls
  39 -- fallback handlers to ask them for a resource. If all of the
  40 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
  41 type FallbackHandler = [ByteString] → IO (Maybe ResourceDef)
  42
  43 -- |'ResTree' is an opaque structure which is a map from resource path
  44 -- to 'ResourceDef'.
  45 newtype ResTree = ResTree ResNode -- root だから Map ではない
  46 type ResSubtree = Map ByteString ResNode
  47 data ResNode    = ResNode (Maybe ResourceDef) ResSubtree
  48
  49 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
  50 --
  51 -- @
  52 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  53 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  54 --             ]
  55 -- @
  56 --
  57 -- Note that path components are always represented as octet streams
  58 -- in this system. Lucu automatically decodes percent-encoded URIs but
  59 -- has no involvement in character encodings such as UTF-8, since RFC
  60 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
  61 -- in \"http\" and \"https\" URI schemas.
  62 mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree
  63 mkResTree = processRoot ∘ map (first canonicalisePath)
  64     where
  65       canonicalisePath ∷ [ByteString] → [ByteString]
  66       canonicalisePath = filter ((¬) ∘ BS.null)
  67
  68       processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree
  69       processRoot list
  70           = let (roots, nonRoots) = partition (\(path, _) → null path) list
  71                 children = processNonRoot nonRoots
  72             in
  73               if null roots then
  74                   -- The root has no resources. Maybe there's one at
  75                   -- somewhere like "/foo".
  76                   ResTree (ResNode Nothing children)
  77               else
  78                   -- There is a root resource.
  79                   let (_, def) = last roots
  80                   in
  81                     ResTree (ResNode (Just def) children)
  82
  83       processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
  84       processNonRoot list
  85           = let subtree    = M.fromList [(name, node name)
  86                                              | name ← childNames]
  87                 childNames = [name | (name:_, _) ← list]
  88                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
  89                              in
  90                                if null defs then
  91                                    -- No resources are defined
  92                                    -- here. Maybe there's one at
  93                                    -- somewhere below this node.
  94                                    ResNode Nothing children
  95                                else
  96                                    -- There is a resource here.
  97                                    ResNode (Just $ last defs) children
  98                 children   = processNonRoot [(path, def)
  99                                                  | (_:path, def) ← list]
 100             in
 101               subtree
 102
 103 findResource ∷ ResTree
 104              → [FallbackHandler]
 105              → URI
 106              → IO (Maybe ([ByteString], ResourceDef))
 107 findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 108     = do let path          = splitPathInfo uri
 109              hasGreedyRoot = maybe False resIsGreedy rootDefM
 110              foundInTree    = if hasGreedyRoot ∨ null path then
 111                                   do def ← rootDefM
 112                                      return ([], def)
 113                               else
 114                                   walkTree subtree path (∅)
 115          if isJust foundInTree then
 116              return foundInTree
 117          else
 118              fallback path fbs
 119     where
 120       walkTree ∷ ResSubtree
 121                → [ByteString]
 122                → Seq ByteString
 123                → Maybe ([ByteString], ResourceDef)
 124
 125       walkTree _ [] _
 126           = error "Internal error: should not reach here."
 127
 128       walkTree tree (name:[]) soFar
 129           = do ResNode defM _ ← M.lookup name tree
 130                def            ← defM
 131                return (toList $ soFar ⊳ name, def)
 132
 133       walkTree tree (x:xs) soFar
 134           = do ResNode defM sub ← M.lookup x tree
 135                case defM of
 136                  Just (ResourceDef { resIsGreedy = True })
 137                      → do def ← defM
 138                           return (toList $ soFar ⊳ x, def)
 139                  _   → walkTree sub xs (soFar ⊳ x)
 140
 141       fallback ∷ [ByteString]
 142                → [FallbackHandler]
 143                → IO (Maybe ([ByteString], ResourceDef))
 144       fallback _    []     = return Nothing
 145       fallback path (x:xs) = do m ← x path
 146                                 case m of
 147                                   Just def → return $ Just ([], def)
 148                                   Nothing  → fallback path xs