{-# OPTIONS_HADDOCK prune #-}

-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
    ( ResourceDef(..)
    , ResTree
    , FallbackHandler

    , mkResTree    -- [ ([String], ResourceDef) ] -> ResTree

    , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)
    , runResource  -- ResourceDef -> Interaction -> IO ThreadId
    )
    where

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import qualified Data.ByteString.Char8 as C8
import           Data.List
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.Maybe
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Headers (emptyHeaders, 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)


-- |'FallbackHandler' is an extra resource handler for resources which
-- can't be statically located somewhere in the resource tree. The
-- Lucu httpd first search for a resource in the tree, and then call
-- fallback handlers to ask them for a resource. If all of the
-- handlers returned 'Prelude.Nothing', the httpd responds with 404
-- Not Found.
type FallbackHandler = [String] -> IO (Maybe ResourceDef)


-- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
-- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
-- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
-- 無視される。

-- | 'ResourceDef' is basically a set of
-- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
data ResourceDef = ResourceDef {
    -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
    -- native thread (spawned by 'Control.Concurrent.forkOS') or to
    -- run it on a user thread (spanwed by
    -- 'Control.Concurrent.forkIO'). Generally you don't need to set
    -- this field to 'Prelude.True'.
      resUsesNativeThread :: !Bool
    -- | Whether to be greedy or not.
    -- 
    -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
    -- greedy resource at \/aaa\/bbb, it is always chosen even if
    -- there is another resource at \/aaa\/bbb\/ccc. If the resource
    -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
    -- resources are like CGI scripts.
    , resIsGreedy         :: !Bool
    -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
    -- request comes for the resource path. If 'resGet' is Nothing,
    -- the system responds \"405 Method Not Allowed\" for GET
    -- requests.
    -- 
    -- It also runs for HEAD request if the 'resHead' is Nothing. In
    -- this case 'Network.HTTP.Lucu.Resource.output' and such like
    -- don't actually write a response body.
    , resGet              :: !(Maybe (Resource ()))
    -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
    -- request comes for the resource path. If 'resHead' is Nothing,
    -- the system runs 'resGet' instead. If 'resGet' is also Nothing,
    -- the system responds \"405 Method Not Allowed\" for HEAD
    -- requests.
    , resHead             :: !(Maybe (Resource ()))
    -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
    -- request comes for the resource path. If 'resPost' is Nothing,
    -- the system responds \"405 Method Not Allowed\" for POST
    -- requests.
    , resPost             :: !(Maybe (Resource ()))
    -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
    -- request comes for the resource path. If 'resPut' is Nothing,
    -- the system responds \"405 Method Not Allowed\" for PUT
    -- requests.
    , resPut              :: !(Maybe (Resource ()))
    -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
    -- DELETE request comes for the resource path. If 'resDelete' is
    -- Nothing, the system responds \"405 Method Not Allowed\" for
    -- DELETE requests.
    , resDelete           :: !(Maybe (Resource ()))
    }

-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'ResourceDef'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
type ResSubtree = Map String 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
--             ]
-- @
mkResTree :: [ ([String], ResourceDef) ] -> ResTree
mkResTree xs = xs `seq` processRoot xs
    where
      processRoot :: [ ([String], ResourceDef) ] -> ResTree
      processRoot list
          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
                children = processNonRoot nonRoots
            in
              if null roots then
                  -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
                  ResTree (ResNode Nothing children)
              else
                  -- "/" がある。
                  let (_, def) = last roots
                  in 
                    ResTree (ResNode (Just def) children)

      processNonRoot :: [ ([String], 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
                                   -- この位置にリソースが定義されない。
                                   -- もっと下にはあるかも。
                                   ResNode Nothing children
                               else
                                   -- この位置にリソースがある。
                                   ResNode (Just $ last defs) children
                children   = processNonRoot [(path, def)
                                                 | (_:path, def) <- list, not (null path)]
            in
              subtree


findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
    = do let pathStr     = uriPath uri
             path        = [x | x <- splitBy (== '/') pathStr, x /= ""]
             foundInTree = if null path then
                               do def <- rootDefM
                                  return (path, def)
                           else
                               walkTree subtree path []
         if isJust foundInTree then
             return foundInTree
           else
             fallback path fbs
    where
      walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)

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

      walkTree tree (name:[]) soFar
          = case M.lookup name tree of
              Nothing               -> Nothing
              Just (ResNode defM _) -> do def <- defM
                                          return (soFar ++ [name], def)

      walkTree tree (x:xs) soFar
          = case M.lookup x tree of
              Nothing                      -> Nothing
              Just (ResNode defM children) -> case defM of
                                                Just (ResourceDef { resIsGreedy = True })
                                                    -> do def <- defM
                                                          return (soFar ++ [x], def)
                                                _   -> walkTree children xs (soFar ++ [x])

      fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef))
      fallback _    []     = return Nothing
      fallback path (x:xs) = do m <- x path
                                case m of
                                  Just def -> return $! Just ([], def)
                                  Nothing  -> fallback path xs


runResource :: ResourceDef -> Interaction -> IO ThreadId
runResource def itr
    = def `seq` itr `seq`
      fork
      $! catch ( runRes ( do req <- getRequest
                             fromMaybe notAllowed $ rsrc req
                             driftTo Done
                        ) itr
               )
               processException
    where
      fork :: IO () -> IO ThreadId
      fork = if resUsesNativeThread def
             then forkOS
             else forkIO
      
      rsrc :: Request -> Maybe (Resource ())
      rsrc req
          = case reqMethod req of
              GET    -> resGet def
              HEAD   -> case resHead def of
                          Just r  -> Just r
                          Nothing -> resGet def
              POST   -> resPost def
              PUT    -> resPut def
              DELETE -> resDelete def
              _      -> undefined

      notAllowed :: Resource ()
      notAllowed = do setStatus MethodNotAllowed
                      setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)

      allowedMethods :: [String]
      allowedMethods = nub $ concat [ methods resGet    ["GET"]
                                    , methods resHead   ["GET", "HEAD"]
                                    , methods resPost   ["POST"]
                                    , methods resPut    ["PUT"]
                                    , methods resDelete ["DELETE"]
                                    ]

      methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
      methods f xs = case f def of
                       Just _  -> xs
                       Nothing -> []

      toAbortion :: SomeException -> Abortion
      toAbortion e = case fromException e of
                       Just abortion -> abortion
                       Nothing       -> Abortion InternalServerError emptyHeaders (Just (show e))

      processException :: SomeException -> IO ()
      processException exc
          = do let abo = toAbortion exc
                   conf = itrConfig itr
               -- まだ DecidingHeader 以前の状態だったら、この途中終了
               -- を應答に反映させる餘地がある。さうでなければ stderr
               -- にでも吐くしか無い。
               state <- atomically $ readItr itr itrState id
               reqM  <- atomically $ readItr itr itrRequest id
               res   <- atomically $ readItr itr itrResponse id
               if state <= DecidingHeader then
                   flip runRes itr
                      $ do setStatus $ aboStatus abo
                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
                           output $ abortPage conf reqM res abo
                 else
                   when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
                            $ hPutStrLn stderr $ show abo

               flip runRes itr $ driftTo Done