{-|
Module      : Resources.Order
Description : 
Copyright   : (c) Alexander Vieth, 2015
Licence     : BSD3
Maintainer  : aovieth@gmail.com
Stability   : experimental
Portability : non-portable (GHC only)
-}

{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Resources.Order (

      resource

    ) where

import GHC.Generics
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Data.Typeable
import Data.AtLeast
import Data.TypeNat.Vect
import Data.Aeson
import Data.JSON.Schema
import qualified Data.Map as M
import qualified Data.Set as S
import Rest
import Rest.Resource as R
import qualified Diplomacy.Phase as Phase
import Diplomacy.Game as Game
import Diplomacy.Aligned
import qualified Diplomacy.GreatPower as DGP
import Diplomacy.Zone
import Diplomacy.Unit
import Diplomacy.Subject
import qualified Diplomacy.OrderObject as DOO
import qualified Diplomacy.Order as DO
import Types.Order
import Types.Credentials
import Types.GreatPower
import Types.GameId
import Types.Server
import Types.GameState

-- | The order resource will give methods
--     PUT : ask to issue an order
resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void
resource = mkResourceId
    { R.name = "order"
    , R.schema = singleton () $ unnamedSingle (const ())
    , R.update = Just update
    }
  where

    update :: Handler (ReaderT GameId Server)
    update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate

    doUpdate :: IssueOrdersInput -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) IssueOrdersOutput
    doUpdate input = do
        gameId <- lift ask
        withUserCredentialsForGame creds gameId (issueOrders gameId)
      where

        creds = credentials input
        issuedOrders = orders input

        issueOrders
            :: GameId
            -> GameStateView
            -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) IssueOrdersOutput
        issueOrders gameId gameStateView = do
            checkAuthorization gameStateView
            (output, nextGame) <- issueOrders' gameStateView
            modifyGameState gameId (return . modifier nextGame)
            return output
        
        modifier :: SomeGame -> GameState -> GameState
        modifier (SomeGame x) state = case state of
            GameNotStarted y duration duration' -> GameNotStarted y duration duration' -- Impossible; should not have this case...
            GameStarted m (AtLeast _ rest) duration duration' elapsed paused ->
                GameStarted m (AtLeast (VCons (SomeGame x) VNil) rest) duration duration' elapsed paused

        checkAuthorization :: GameStateView -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) ()
        checkAuthorization gameStateView = case gameStateView of
            GameNotStartedView -> return ()
            GameStartedView greatPowers _ _ _ _ _ ->
                if issuedOrdersGreatPowers issuedOrders `S.isSubsetOf` (S.map GreatPower greatPowers)
                then return ()
                else throwE NotAllowed

        issueOrders' :: GameStateView -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) (IssueOrdersOutput, SomeGame)
        issueOrders' gameStateView = case gameStateView of
            GameNotStartedView -> throwE (domainReason IssueOrdersGameNotStarted)
            GameStartedView _ (AtLeast (VCons (SomeGame someGame) VNil) _) _ _ _ _ -> case (someGame, issuedOrders) of
                (TypicalGame TypicalRoundOne Unresolved x y z, Typical os) -> issueOrders'' os someGame
                (RetreatGame RetreatRoundOne Unresolved _ _ _ _ _, Retreat os) -> issueOrders'' os someGame
                (TypicalGame TypicalRoundTwo Unresolved x y z, Typical os) -> issueOrders'' os someGame
                (RetreatGame RetreatRoundTwo Unresolved _ _ _ _ _, Retreat os) -> issueOrders'' os someGame
                (AdjustGame AdjustRound Unresolved _ _ _, Adjust os) -> issueOrders'' os someGame
                _ -> throwE (domainReason (IssueOrdersWrongPhase))

        issueOrders''
            :: forall round .
               [(GreatPower, SomeOrder (RoundPhase round))]
            -> Game round RoundUnresolved
            -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) (IssueOrdersOutput, SomeGame)
        issueOrders'' orders game = return $ case game of
            TypicalGame TypicalRoundOne _ _ _ _ -> (IssueOrdersOutputTypical, SomeGame . snd $ Game.issueOrders ordersMap game)
            TypicalGame TypicalRoundTwo _ _ _ _ -> (IssueOrdersOutputTypical, SomeGame . snd $ Game.issueOrders ordersMap game)
            RetreatGame RetreatRoundOne _ _ _ _ _ _ -> (IssueOrdersOutputRetreat, SomeGame . snd $ Game.issueOrders ordersMap game)
            RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> (IssueOrdersOutputRetreat, SomeGame . snd $ Game.issueOrders ordersMap game)
            AdjustGame AdjustRound _ _ _ _ -> (IssueOrdersOutputAdjust, SomeGame . snd $ Game.issueOrders ordersMap game)
          where
            ordersMap :: M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round))
            ordersMap = foldr insertOrder M.empty orders
            insertOrder
                :: (GreatPower, SomeOrder (RoundPhase round))
                -> M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round))
                -> M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round))
            insertOrder (greatPower, order) = case order of
                SomeOrder (DO.SomeOrder (DO.Order (subject, object))) ->
                    M.insert (Zone (subjectProvinceTarget subject)) (align (subjectUnit subject) (outGreatPower greatPower), DOO.SomeOrderObject object)

-- Order inputs look something like this:
--
--     [["England", "F Spa NC - Mid"], ["France", "A Mar - Spa"]]
--
-- It's important that we accept orders for multiple great powers, since one
-- player may control more than one great power.
data IssuedOrders where
    Typical :: [(GreatPower, SomeOrder Phase.Typical)] -> IssuedOrders
    Retreat :: [(GreatPower, SomeOrder Phase.Retreat)] -> IssuedOrders
    Adjust :: [(GreatPower, SomeOrder Phase.Adjust)] -> IssuedOrders

deriving instance Generic IssuedOrders
deriving instance Typeable IssuedOrders
instance FromJSON IssuedOrders
instance ToJSON IssuedOrders
instance JSONSchema IssuedOrders where
    schema = gSchema

-- | The set of all GreatPowers for which at least one order is relevant.
issuedOrdersGreatPowers :: IssuedOrders -> S.Set GreatPower
issuedOrdersGreatPowers orders = case orders of
    Typical os -> foldr (S.insert . fst) S.empty os
    Retreat os -> foldr (S.insert . fst) S.empty os
    Adjust os -> foldr (S.insert . fst) S.empty os

data IssueOrdersInput = IssueOrdersInput {
      credentials :: Credentials
    , orders :: IssuedOrders
    }

deriving instance Generic IssueOrdersInput
deriving instance Typeable IssueOrdersInput
instance FromJSON IssueOrdersInput
instance ToJSON IssueOrdersInput
instance JSONSchema IssueOrdersInput where
    schema = gSchema

-- | TODO throw in the sets of validity criterion, indexed by the relevant
--   order: [["France", "A Mar - Spa SC"], ["MoveUnitCanOccupy"]]
--   And of course, for the adjust phase, take the other set indexed by the
--   relevant great power.
data IssueOrdersOutput where
    IssueOrdersOutputTypical :: IssueOrdersOutput
    IssueOrdersOutputRetreat :: IssueOrdersOutput
    IssueOrdersOutputAdjust :: IssueOrdersOutput

deriving instance Generic IssueOrdersOutput
deriving instance Typeable IssueOrdersOutput
instance FromJSON IssueOrdersOutput
instance ToJSON IssueOrdersOutput
instance JSONSchema IssueOrdersOutput where
    schema = gSchema

-- | We do not consider invalid orders to be an error. If invalid orders
--   are given, the response will reflect it.
data IssueOrdersError
    = IssueOrdersGameNotStarted
    | IssueOrdersWrongPhase

instance ToResponseCode IssueOrdersError where
    toResponseCode _ = 403

deriving instance Generic IssueOrdersError
deriving instance Typeable IssueOrdersError
instance FromJSON IssueOrdersError
instance ToJSON IssueOrdersError
instance JSONSchema IssueOrdersError where
    schema = gSchema