{-# LANGUAGE
    CPP
  , ExistentialQuantification
  , FlexibleContexts
  , GADTs
  , GeneralizedNewtypeDeriving
  , NamedFieldPuns
  , RankNTypes
  , ScopedTypeVariables
  , TupleSections
  #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif

module Rest.Driver.Routing.Internal where

import Prelude hiding (id, (.))

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Error.Util
import Control.Monad.Error.Class
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State (MonadState, StateT, evalStateT)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.List.Split
import Network.Multipart (BodyPart (..), HeaderName (..))
import Safe
import qualified Control.Monad.State       as State
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import qualified Data.HashMap.Strict       as H
import qualified Data.Label.Total          as L

import Network.URI.Encode (decode)
import Rest.Api (Some1 (..))
import Rest.Container
import Rest.Dictionary
import Rest.Error
import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range)
import Rest.Types.Container.Resource (Resource, Resources (..))
import qualified Rest.Api                      as Rest
import qualified Rest.Resource                 as Rest
import qualified Rest.Schema                   as Rest
import qualified Rest.StringMap.HashMap.Strict as StringHashMap
import qualified Rest.Types.Container.Resource as R

import Rest.Driver.Perform (failureWriter, writeResponse)
import Rest.Driver.RestM (runRestM)
import Rest.Driver.Types

import qualified Rest.Driver.RestM as Rest

{-# ANN module "HLint: ignore Reduce duplication" #-}

type UriParts = [String]

apiError :: (MonadError (Reason e) m) => Reason e -> m a
apiError = throwError

data RouterData m = RouterData { method :: Method, config :: Config m }

newtype Router m a =
  Router { unRouter :: ReaderT (RouterData m) (StateT UriParts (ExceptT Reason_ Identity)) a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadReader (RouterData m)
           , MonadState UriParts
           , MonadError Reason_
           )

runRouter :: Config m -> Method -> UriParts -> Router m (RunnableHandler m) -> Either Reason_ (RunnableHandler m)
runRouter cfg mtd uri = runIdentity
                      . runExceptT
                      . flip evalStateT uri
                      . flip runReaderT (RouterData mtd cfg)
                      . unRouter

route :: (Applicative m, Monad m) => Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)
route = routeWith defaultConfig

routeWith :: Config m -> Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)
routeWith _    Nothing   _   _   = apiError UnsupportedMethod
routeWith cfg (Just mtd) uri api = runRouter cfg mtd uri $
  case api of
    Rest.Unversioned (Some1 router) -> routeRoot router
    Rest.Versioned   vrs            -> do
      versionStr <- popSegment
      case versionStr `Rest.lookupVersion` vrs of
          Just (Some1 router) -> routeRoot router
          _                   -> apiError UnsupportedVersion

routeRoot :: Rest.Router m s -> Router m (RunnableHandler m)
routeRoot router@(Rest.Embed resource _) = do
  routeName (Rest.name resource)
  fromMaybeT (routeRouter router) (routeMultiGet router)

routeMultiGet :: Rest.Router m s -> MaybeT (Router m) (RunnableHandler m)
routeMultiGet root@(Rest.Embed Rest.Resource{} _) =
  do guardNullPath
     guardMethod POST
     cfg <- asks config
     return (RunnableHandler id (mkMultiGetHandler cfg root))

routeRouter :: Rest.Router m s -> Router n (RunnableHandler m)
routeRouter (Rest.Embed resource@Rest.Resource { Rest.schema } subRouters) =
  case schema of
    (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT
       (  routeToplevel resource subRouters mToplevel
      <|> routeCreate resource
      <|> lift (routeStep resource subRouters step)
       )

routeToplevel :: Rest.Resource m s sid mid aid
              -> [Some1 (Rest.Router s)]
              -> Maybe (Rest.Cardinality sid mid)
              -> MaybeT (Router n) (RunnableHandler m)
routeToplevel resource@Rest.Resource { Rest.list } subRouters mToplevel =
  hoistMaybe mToplevel >>= \toplevel ->
  case toplevel of
    Rest.Single sid -> lift $ withSubresource sid resource subRouters
    Rest.Many   mid ->
      do guardNullPath
         guardMethod GET
         lift $ routeListHandler (list mid)

routeCreate :: Rest.Resource m s sid mid aid -> MaybeT (Router n) (RunnableHandler m)
routeCreate Rest.Resource { Rest.create } = guardNullPath >> guardMethod POST >>
  maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create

routeStep :: Rest.Resource m s sid mid aid
          -> [Some1 (Rest.Router s)]
          -> Rest.Step sid mid aid
          -> Router n (RunnableHandler m)
routeStep resource subRouters step =
  case step of
    Rest.Named ns -> popSegment >>= \seg ->
      case lookup seg ns of
        Nothing -> apiError UnsupportedRoute
        Just h  -> routeNamed resource subRouters h
    Rest.Unnamed h -> routeUnnamed resource subRouters h

routeNamed :: Rest.Resource m s sid mid aid
           -> [Some1 (Rest.Router s)]
           -> Rest.Endpoint sid mid aid
           -> Router n (RunnableHandler m)
routeNamed resource@Rest.Resource { Rest.list, Rest.statics } subRouters h =
  case h of
    Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid))
    Right (Rest.Single getter) -> routeGetter getter resource subRouters
    Right (Rest.Many   getter) -> routeListGetter getter list

routeUnnamed :: Rest.Resource m s sid mid aid
             -> [Some1 (Rest.Router s)]
             -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid)
             -> Router n (RunnableHandler m)
routeUnnamed resource@Rest.Resource { Rest.list } subRouters cardinality =
  case cardinality of
    Rest.Single sBy -> withSegment (multi resource sBy) $
      parseIdent sBy >=> \sid -> withSubresource sid resource subRouters
    Rest.Many   mBy ->
      do seg <- popSegment
         mid <- parseIdent mBy seg
         noRestPath
         hasMethod GET
         routeListHandler (list mid)

routeGetter :: Rest.Getter sid
            -> Rest.Resource m s sid mid aid
            -> [Some1 (Rest.Router s)]
            -> Router n (RunnableHandler m)
routeGetter getter resource subRouters =
  case getter of
    Rest.Singleton sid -> getOrDeep sid
    Rest.By        sBy -> withSegment (multi resource sBy) $
                            parseIdent sBy >=> getOrDeep
  where
    getOrDeep sid = withSubresource sid resource subRouters

multi :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router n (RunnableHandler m)
multi Rest.Resource { Rest.update, Rest.remove, Rest.enter } sBy =
  asks method >>= \mtd ->
  case mtd of
    PUT    -> handleOrNotFound update
    DELETE -> handleOrNotFound remove
    _      -> apiError UnsupportedMethod
  where
    handleOrNotFound handler =
      maybe (apiError UnsupportedRoute)
            (return . RunnableHandler id)
            (handler >>= mkMultiHandler sBy enter)

routeListGetter :: Monad m
                => Rest.Getter mid
                -> (mid -> ListHandler m)
                -> Router n (RunnableHandler m)
routeListGetter getter list = hasMethod GET >>
  case getter of
    Rest.Singleton mid -> noRestPath >> routeListHandler (list mid)
    Rest.By        mBy ->
      do seg <- popSegment
         mid <- parseIdent mBy seg
         noRestPath
         routeListHandler (list mid)

withSubresource :: sid
                -> Rest.Resource m s sid mid aid
                -> [Some1 (Rest.Router s)]
                -> Router n (RunnableHandler m)
withSubresource sid resource@Rest.Resource { Rest.enter, Rest.selects, Rest.actions } subRouters =
  withSegment (routeSingle sid resource) $ \seg ->
  case lookup seg selects of
    Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select)
    Nothing -> case lookup seg actions of
      Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action)
      Nothing ->
        case lookupRouter seg subRouters of
          Just (Some1 subRouter) -> do
            (RunnableHandler subRun subHandler) <- routeRouter subRouter
            return (RunnableHandler (enter sid . subRun) subHandler)
          Nothing -> apiError UnsupportedRoute

routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router n (RunnableHandler m)
routeSingle sid Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove } =
  asks method >>= \mtd ->
  case mtd of
    GET    -> handleOrNotFound get
    PUT    -> handleOrNotFound update
    DELETE -> handleOrNotFound remove
    _      -> apiError UnsupportedMethod
  where
    handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid))

routeName :: String -> Router n ()
routeName ident = unless (null ident) $
  do identStr <- popSegment
     when (identStr /= ident) $
       apiError UnsupportedRoute

routeListHandler :: Monad m => ListHandler m -> Router n (RunnableHandler m)
routeListHandler list =
      maybe (apiError UnsupportedRoute)
            (return . RunnableHandler id)
            (mkListHandler list)

lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s))
lookupRouter _    [] = Nothing
lookupRouter name (Some1 router@(Rest.Embed resource _) : routers)
   =  (guard (Rest.name resource == name) >> return (Some1 router))
  <|> lookupRouter name routers

parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id
parseIdent (Rest.Id StringId byF) seg = return (byF seg)
parseIdent (Rest.Id ReadId   byF) seg =
  case readMay seg of
    Nothing  -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg))
    Just sid -> return (byF sid)

splitUriString :: String -> UriParts
splitUriString = filter (/= "") . map decode . splitOn "/"

popSegment :: Router n String
popSegment =
  do uriParts <- State.get
     case uriParts of
       []      -> apiError UnsupportedRoute
       (hd:tl) -> do
         State.put tl
         return hd

withSegment :: Router n a -> (String -> Router n a) -> Router n a
withSegment noSeg withSeg =
  do uriParts <- State.get
     case uriParts of
       [] -> noSeg
       (hd:tl) -> do
         State.put tl
         withSeg hd

noRestPath :: Router n ()
noRestPath =
  do uriParts <- State.get
     unless (null uriParts) $
       apiError UnsupportedRoute

guardNullPath :: (MonadPlus m, MonadState UriParts m) => m ()
guardNullPath = State.get >>= guard . null

hasMethod :: Method -> Router n ()
hasMethod wantedMethod = asks method >>= \mtd ->
  unless (mtd == wantedMethod) $
    apiError UnsupportedMethod

guardMethod :: (MonadPlus m, MonadReader (RouterData c) m) => Method -> m ()
guardMethod mtd = asks method >>= guard . (== mtd)

mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m)
mkListHandler (GenHandler dict act sec) =
  do newDict <- L.traverse outputs listO . addPar range $ dict
     return $ GenHandler newDict (mkListAction act) sec

mkListAction :: Monad m
            => (Env h p i -> ExceptT (Reason e) m [a])
            -> Env h (Range, p) i
            -> ExceptT (Reason e) m (List a)
mkListAction act (Env h (Range f c, p) i) = do
  xs <- act (Env h p i)
  return (List f (min c (length xs)) (take c xs))

mkMultiHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m)
mkMultiHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec
  where
    newErrDict = L.modify errors reasonE dict
    mNewDict =  L.traverse inputs mappingI
            <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict))
             .  L.set errors defaultE
             $  dict
    newAct (Env hs ps vs) =
      do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $
           do i <- parseIdent sBy k
              mapExceptT (run i) (act (Env hs ps v))
         return . StringHashMap.fromList $ zipWith (\(k, _) b -> (k, eitherToStatus b)) (StringHashMap.toList vs) bs

mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Config m -> Rest.Router m s -> Handler m
mkMultiGetHandler cfg root = mkInputHandler (xmlJsonI . multipartO) $ \(Resources rs) -> runMultiResources cfg cfg root rs

defaultRunMultiResources :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart]
defaultRunMultiResources cfg root rs = lift $ forM rs (runResource cfg root)

defaultConfig :: (Applicative m, Monad m) => Config m
defaultConfig = Config { runMultiResources = defaultRunMultiResources }

runResource :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> Resource -> m BodyPart
runResource cfg root res
  = fmap (uncurry mkBodyPart)
  . runRestM (toRestInput res)
  . either (failureWriter None) (writeResponse . mapHandler lift)
  $ routeResource cfg root res

routeResource :: Config m -> Rest.Router m s -> Resource -> Either Reason_ (RunnableHandler m)
routeResource cfg root res = runRouter cfg (R.method res) (splitUriString $ R.uri res) (routeRoot root)

toRestInput :: Resource -> Rest.RestInput
toRestInput r = Rest.emptyInput
  { Rest.headers    = H.map R.unValue . StringHashMap.toHashMap . R.headers    $ r
  , Rest.parameters = H.map R.unValue . StringHashMap.toHashMap . R.parameters $ r
  , Rest.body       = LUTF8.fromString (R.input r)
  , Rest.method     = Just (R.method r)
  , Rest.paths      = splitUriString (R.uri r)
  }

mkHeaders :: H.HashMap String d -> [(HeaderName, d)]
mkHeaders = map (first HeaderName) . H.toList

mkBodyPart :: LUTF8.ByteString -> Rest.RestOutput -> BodyPart
mkBodyPart bdy restOutput =
  let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput))
           : mkHeaders (Rest.headersSet restOutput)
  in BodyPart hdrs bdy

-- * Utilities

fromMaybeT :: Monad m => m a -> MaybeT m a -> m a
fromMaybeT def act = runMaybeT act >>= maybe def return