{-# 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 Data.Sequence.Unicode hiding ((∅))
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 ResourceDef)

-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'ResourceDef'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
type ResSubtree = Map ByteString ResNode
data ResNode    = ResNode (Maybe ResourceDef) 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], ResourceDef) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
    where
      canonicalisePath ∷ [ByteString] → [ByteString]
      canonicalisePath = filter ((¬) ∘ BS.null)

      processRoot ∷ [ ([ByteString], ResourceDef) ] → 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], ResourceDef) ] → 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], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
    = do let path          = splitPathInfo 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], ResourceDef)

      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 (ResourceDef { resIsGreedy = True })
                     → do def ← defM
                          return (toList $ soFar ⊳ x, def)
                 _   → walkTree sub xs (soFar ⊳ x)

      fallback ∷ [ByteString]
               → [FallbackHandler]
               → IO (Maybe ([ByteString], ResourceDef))
      fallback _    []     = return Nothing
      fallback path (x:xs) = do m ← x path
                                case m of
                                  Just def → return $ Just ([], def)
                                  Nothing  → fallback path xs