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