It (at least) builds now...

[Lucu.git] / Network / HTTP / Lucu / Resource / Tree.hs

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
deleted file mode 100644 (file)
index 8150be9..0000000
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-{-# LANGUAGE
-    DoAndIfThenElse
-  , OverloadedStrings
-  , RecordWildCards
-  , UnicodeSyntax
-  #-}
-
--- | Repository of the resources in httpd.
-module Network.HTTP.Lucu.Resource.Tree
-    ( ResTree
-    , FallbackHandler
-
-    , mkResTree
-    , findResource
-    )
-    where
-import Control.Arrow
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Control.Monad
-import Data.Foldable
-import Data.List
-import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Maybe
-import Data.Monoid.Unicode
-import Data.Sequence (Seq)
-import Network.HTTP.Lucu.Resource.Internal
-import Network.HTTP.Lucu.Utils
-import Network.URI hiding (path)
-import System.IO
-import Prelude hiding (catch)
-import Prelude.Unicode
-
--- |'FallbackHandler' is an extra resource handler for resources which
--- can't be statically located anywhere in the resource tree. The Lucu
--- httpd first searches for a resource in the tree, and then calls
--- fallback handlers to ask them for a resource. If all of the
--- handlers returned 'Nothing', the httpd responds with 404 Not Found.
-type FallbackHandler = [ByteString] → IO (Maybe Resource)
-
--- |'ResTree' is an opaque structure which is a map from resource path
--- to 'Resource'.
-newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map ByteString ResNode
-data ResNode    = ResNode (Maybe Resource) ResSubtree
-
--- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
---
--- @
---   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
---             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
---             ]
--- @
---
--- Note that path components are always represented as octet streams
--- in this system. Lucu automatically decodes percent-encoded URIs but
--- has no involvement in character encodings such as UTF-8, since RFC
--- 2616 (HTTP/1.1) says nothing about character encodings to be used
--- in \"http\" and \"https\" URI schemas.
-mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
-mkResTree = processRoot ∘ map (first canonicalisePath)
-    where
-      canonicalisePath ∷ [ByteString] → [ByteString]
-      canonicalisePath = filter ((¬) ∘ BS.null)
-
-      processRoot ∷ [ ([ByteString], Resource) ] → ResTree
-      processRoot list
-          = let (roots, nonRoots) = partition (\(path, _) → null path) list
-                children = processNonRoot nonRoots
-            in
-              if null roots then
-                  -- The root has no resources. Maybe there's one at
-                  -- somewhere like "/foo".
-                  ResTree (ResNode Nothing children)
-              else
-                  -- There is a root resource.
-                  let (_, def) = last roots
-                  in 
-                    ResTree (ResNode (Just def) children)
-
-      processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
-      processNonRoot list
-          = let subtree    = M.fromList [(name, node name)
-                                             | name ← childNames]
-                childNames = [name | (name:_, _) ← list]
-                node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
-                             in
-                               if null defs then
-                                   -- No resources are defined
-                                   -- here. Maybe there's one at
-                                   -- somewhere below this node.
-                                   ResNode Nothing children
-                               else
-                                   -- There is a resource here.
-                                   ResNode (Just $ last defs) children
-                children   = processNonRoot [(path, def)
-                                                 | (_:path, def) ← list]
-            in
-              subtree
-
-findResource ∷ ResTree
-             → [FallbackHandler]
-             → URI
-             → IO (Maybe ([ByteString], Resource))
-findResource (ResTree (ResNode rootDefM subtree)) fbs uri
-    = do let path          = uriPathSegments uri
-             hasGreedyRoot = maybe False resIsGreedy rootDefM
-             foundInTree    = if hasGreedyRoot ∨ null path then
-                                  do def ← rootDefM
-                                     return ([], def)
-                              else
-                                  walkTree subtree path (∅)
-         if isJust foundInTree then
-             return foundInTree
-         else
-             fallback path fbs
-    where
-      walkTree ∷ ResSubtree
-               → [ByteString]
-               → Seq ByteString
-               → Maybe ([ByteString], Resource)
-
-      walkTree _ [] _
-          = error "Internal error: should not reach here."
-
-      walkTree tree (name:[]) soFar
-          = do ResNode defM _ ← M.lookup name tree
-               def            ← defM
-               return (toList $ soFar ⊳ name, def)
-
-      walkTree tree (x:xs) soFar
-          = do ResNode defM sub ← M.lookup x tree
-               case defM of
-                 Just (Resource { resIsGreedy = True })
-                     → do def ← defM
-                          return (toList $ soFar ⊳ x, def)
-                 _   → walkTree sub xs (soFar ⊳ x)
-
-      fallback ∷ [ByteString]
-               → [FallbackHandler]
-               → IO (Maybe ([ByteString], Resource))
-      fallback _    []     = return Nothing
-      fallback path (x:xs) = do m ← x path
-                                case m of
-                                  Just def → return $ Just ([], def)
-                                  Nothing  → fallback path xs