{-# 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 Control.Applicative
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers (fromHeaders)
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Interaction
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 = [Text] → 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 Text 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 the request path in an incoming HTTP request is always
-- treated as an URI-encoded UTF-8 string.
mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
    where
      canonicalisePath ∷ [Text] → [Text]
      canonicalisePath = filter (≢ "")

      processRoot ∷ [ ([Text], 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 ∷ [ ([Text], 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 ([Text], 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 → [Text] → [Text] → Maybe ([Text], ResourceDef)

      walkTree _ [] _
          = error "Internal error: should not reach here."

      walkTree tree (name:[]) soFar
          = do ResNode defM _ ← M.lookup name tree
               def            ← defM
               return (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 (soFar ⧺ [x], def)
                 _   → walkTree sub xs (soFar ⧺ [x])

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