module Network.HTTP.Lucu.Resource.Tree
    ( ResourceDef(..)
    , ResTree
    , 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.Reader
import           Data.Dynamic
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.MIMEType
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
import           System.IO
import           System.IO.Error hiding (catch)
import           Prelude hiding (catch)


-- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
-- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
-- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
-- 無視される。
data ResourceDef = ResourceDef {
      resUsesNativeThread :: Bool
    , resIsGreedy         :: Bool
    , resGet              :: Maybe (Resource ())
    , resHead             :: Maybe (Resource ())
    , resPost             :: Maybe (Resource ())
    , resPut              :: Maybe (Resource ())
    , resDelete           :: Maybe (Resource ())
    }
type ResTree    = ResNode -- root だから Map ではない
type ResSubtree = Map String ResNode
data ResNode    = ResNode (Maybe ResourceDef) ResSubtree


mkResTree :: [ ([String], ResourceDef) ] -> ResTree
mkResTree list = processRoot list
    where
      processRoot :: [ ([String], ResourceDef) ] -> ResTree
      processRoot list
          = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
                children = processNonRoot nonRoots
            in
              if null roots then
                  -- "/" にリソースが定義されない。"/foo" とかにはあるかも。
                  ResNode Nothing children
              else
                  -- "/" がある。
                  let (_, def) = last roots
                  in 
                    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 -> URI -> Maybe ([String], ResourceDef)
findResource (ResNode rootDefM subtree) uri
    = let pathStr = uriPath uri
          path    = [x | x <- splitBy (== '/') pathStr, x /= ""]
      in
        if null path then
            do def <- rootDefM
               return (path, def)
        else
            walkTree subtree path []
    where
      walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)

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

      walkTree subtree (x:xs) soFar
          = case M.lookup x subtree 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])


runResource :: ResourceDef -> Interaction -> IO ThreadId
runResource def itr
    = fork
      $ catch ( runReaderT ( do fromMaybe notAllowed rsrc 
                                driftTo Done
                           ) itr
              )
      $ \ exc -> processException exc
    where
      fork :: IO () -> IO ThreadId
      fork = if (resUsesNativeThread def)
             then forkOS
             else forkIO
      
      rsrc :: Maybe (Resource ())
      rsrc = case reqMethod $ fromJust $ itrRequest itr 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

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

      allowedMethods :: [String]
      allowedMethods = nub $ foldr (++) [] [ 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 -> []

      processException :: Exception -> IO ()
      processException exc
          = do let abo = case exc of
                           ErrorCall    msg  -> Abortion InternalServerError [] $ Just msg
                           IOException  ioE  -> Abortion InternalServerError [] $ Just $ formatIOE ioE
                           DynException dynE -> case fromDynamic dynE of
                                                  Just (abo :: Abortion) -> abo
                                                  Nothing
                                                      -> Abortion InternalServerError []
                                                         $ Just $ show exc
                           _                 -> Abortion InternalServerError [] $ Just $ show exc
                   conf = itrConfig itr
                   reqM = itrRequest itr
               -- まだ DecidingHeader 以前の状態だったら、この途中終了
               -- を應答に反映させる餘地がある。さうでなければ stderr
               -- にでも吐くしか無い。
               state <- atomically $ readItr itr itrState id
               res   <- atomically $ readItr itr itrResponse id
               if state <= DecidingHeader then
                   flip runReaderT itr
                      $ do setStatus $ aboStatus abo
                           -- FIXME: 同じ名前で複數の値があった時は、こ
                           -- れではまずいと思ふ。
                           mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
                           output $ abortPage conf reqM res abo
                 else
                   hPutStrLn stderr $ show abo

               flip runReaderT itr $ driftTo Done

      formatIOE :: IOError -> String
      formatIOE ioE = if isUserError ioE then
                          ioeGetErrorString ioE
                      else
                          show ioE