{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings, RankNTypes, FlexibleContexts, TupleSections, ConstraintKinds #-}

-- | A subsite serving a single-user dungeon.
module Web.Antagonist.Server (
  module Web.Antagonist.Server.Data,
  YesodAntagonist (getNick, antagonistLayout, getAuthR, getCustomizeR)
  ) where

import Data.Chatty.AVL
import Game.Antisplice
import Web.Antagonist.Server.Data
import Text.Chatty.Printer
import Text.Chatty.Extended.Printer
import Text.Chatty.Extended.HTML
import Text.Chatty.Expansion
import Text.Chatty.Expansion.Vars
import Text.Chatty.Interactor
import Text.Chatty.Scanner
import Text.Chatty.Channel.Printer
import System.Chatty.Misc
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Error.Class
import Data.IORef
import Data.Monoid
import Data.List
import Data.Text (pack,unpack,Text)
import Data.Time.Format
import System.Locale
import Text.Shakespeare.Text
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod
import Yesod.Auth

class (Yesod master, RenderMessage master FormMessage) => YesodAntagonist master where
  getNick :: HandlerT master IO Text
  getNick = return "Bernd"
  antagonistLayout :: WidgetT master IO () -> HandlerT master IO Html
  antagonistLayout = defaultLayout
  getAuthR :: HandlerT master IO (Maybe (AuthRoute -> Route master))
  getAuthR = return Nothing
  getCustomizeR :: HandlerT master IO (Maybe (Route master))
  getCustomizeR = return Nothing

type AntaHandler a = forall master. YesodAntagonist master => HandlerT SingleUserSub (HandlerT master IO) a

extractSession :: AntaHandler (Int,SessionState,String)
extractSession = do
  SingleUserSub ctrref avlref ctor <- getYesod
  ssid_ <- lookupSession "ssid"
  nick <- lift getNick
  ssid <- case ssid_ of
    Nothing -> do
      ssid <- liftIO $ atomicModifyIORef ctrref $ (+1) &&& (+1)
      setSession "ssid" (pack $ show ssid)
      return ssid
    Just ssid_ -> return $ read $ unpack ssid_
  ss_ <- liftIO $ readIORef avlref
  (ss,ns) <- case avlLookup ssid ss_ of
    Just (x,ns,st) -> return (x,ns)
    Nothing -> do
      liftIO $ atomicModifyIORef avlref $
        let op a
              | avlSize a >= 100 = avlRemove (se a) a
              | otherwise = a
            se = indexOf . head . sortBy (\(_,_,_,a) (_,_,_,b) -> a `compare` b) . avlPreorder
        in op &&& op
      (ss,r) <- liftIO $ runRecorderT $ startSession ctor nick
      return (ss,replay r)
  ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor nick ss runScheduledTasks
  putSession ssid ss1 none
  return (ssid,ss1,ns <> replay r)

substitute :: Eq a => a -> [a] -> [a] -> [a]
substitute e by = concatMap subst'
  where subst' a | a == e = by
                 | otherwise = [a]

prepOutput :: MonadIO m => String -> m String
prepOutput s = do
  u <- liftIO $ mutctime
  let t = formatTime defaultTimeLocale "<span class=\"time\">[%R]</span> " u
      ms :: Int -> String -> String
      ms 0 (' ':sx) = let wc = length $ takeWhile (==' ') sx in " " ++ concat (replicate wc "&nbsp;") ++ ms 0 (drop wc sx)
      ms n ('<':sx) = '<' : ms (n+1) sx
      ms n ('>':sx) = '>' : ms (n-1) sx
      ms n (x:xs) = x : ms n xs
      ms n [] = []
  return (concatMap ((++"<br/>") . ms 0 . (t++)) $ lines s)

prepFeedback :: MonadIO m => String -> m String
prepFeedback s = do
  u <- liftIO mutctime
  let t = formatTime defaultTimeLocale "<span class=\"ftime\">&lt;%R&gt;</span> " u
  return (t++s++"<br/>")

getPrompt :: SessionState -> AntaHandler String
getPrompt ss = do
  u <- liftIO $ mutctime
  nick <- lift getNick
  ((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) nick ss $ expand <=< expand $
                formatTime defaultTimeLocale "%R $prompt" u
  return ps

getPlayR :: AntaHandler Html
getPlayR = do
  (ssid,ss,ns) <- extractSession
  toMaster <- getRouteToParent
  putSession ssid ss ns
  mcustomizeR <- lift getCustomizeR
  lift $ antagonistLayout $ do
    setTitle $ toHtml [lt| Session #{show ssid}|]
    toWidget $(hamletFile "play.htm")
    toWidget $(cassiusFile "play.cass")
    toWidget $(juliusFile "play.js")

postNewsR :: AntaHandler Value
postNewsR = do
  (_,ss,ns) <- extractSession
  nss <- prepOutput ns
  ps <- getPrompt ss
  lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]

postPutR :: AntaHandler Value
postPutR = do
  SingleUserSub _ _ ctor <- getYesod
  (ssid,ss,ns) <- extractSession
  line <- lift $ runInputPost $ id <$> ireq textField "line"
  nick <- lift getNick
  ((_,x),r) <- liftIO $ runRecorderT $ runSession ctor nick ss $ act $ unpack line
  putSession ssid x none
  nss1 <- prepOutput ns
  nss2 <- prepOutput $ replay r
  nssF <- prepFeedback $ unpack line
  let nss = nss1 <> nssF <> nss2
  ps <- getPrompt x
  lift $ return $ object [ "news" .= pack nss, "prompt" .= pack ps ]

instance YesodAntagonist master => YesodSubDispatch SingleUserSub (HandlerT master IO) where
  yesodSubDispatch = $(mkYesodSubDispatch resourcesSingleUserSub)

putSession :: Int -> SessionState -> String -> AntaHandler ()
putSession ssid ss nn = do
  SingleUserSub ctrref avlref ctor <- getYesod
  stamp <- liftIO mgetstamp
  void $ liftIO $ atomicModifyIORef avlref $ let op = avlInsert (ssid,ss,nn,stamp) in op &&& op

runScheduledTasks :: ChattyDungeonM ()
runScheduledTasks = do
  now <- mgetstamp
  ds <- getDungeonState
  let ts = takeWhile ((<now).fst) $ avlInorder $ timeTriggersOf ds
  putDungeonState ds{timeTriggersOf=foldr avlRemove (timeTriggersOf ds) $ map fst ts}
  forM_ ts (runHandler . snd)

runSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> Text -> SessionState -> ChattyDungeonM a -> m (a,SessionState)
runSession ctor nick ss m = do
  x <- withSession ss (mputv "user" (Literal $ unpack nick) >> m)
  case x of
    Right r -> return r
    Left e -> do
      runHtmlPrinterT $ eprintLn (Vivid Red) $ case e of
        VerbMustFirstError -> "Please start with a verb."
        UnintellegibleError -> "I don't understand that."
        CantWalkThereError -> "I can't walk there."
        WhichOneError -> "Which one do you mean?"
        CantSeeOneError -> "I can't see one here."
        DontCarryOneError -> "You don't carry one."
        CantEquipThatError -> "I can't equip that."
        CantEquipThatThereError -> "I can't wear that there. You might want to try some other place?"
        WhereToEquipError -> "Where?"
        CantCastThatNowError -> "Sorry, I can't cast that now. Check your health, mana and cooldowns."
        CantAcquireThatError -> "I can't take that."
        WontHitThatError -> "I won't hit that."
        ReError (Unint _ s) -> s
        ReError (Uncon s) -> s
        _ -> ""
      case e of
        QuitError -> liftM (undefined,) $ startSession ctor nick
        _ -> return (undefined,ss)
      
withSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => SessionState -> ChattyDungeonM a -> m (Either SplErr (a,SessionState))
withSession ((((s,ts),as),c),es) m =
  runJoinerT $
  runNullExpanderT $
  liftM rot $ flip runExpanderT es $
  runHtmlPrinterT $
  liftM rot $ flip runCounterT c $
  liftM rot $ flip runAtomStoreT as $
  liftM rot $ flip runVocabT ts $
  runFailT $
  flip runDungeonT s m
  where unjust (Just j) = j

startSession :: (MonadIO m,ChClock m,ChRandom m,ChPrinter m) => Constructor () -> Text -> m SessionState
startSession init nick = do
  Right (_,x) <- withSession ((((none,defVocab),none),0),none) $ do
    mputv "user" $ Literal $ unpack nick
    init
    reenterCurrentRoom
    roomTriggerOnAnnounceOf =<< getRoomState
    roomTriggerOnLookOf =<< getRoomState
  return x

rot :: (Either x (a,b),c) -> Either x (a,(b,c))
rot (Right (a,b),c) = Right (a,(b,c))
rot (Left e,_) = Left e

semirot :: (Either x a,b) -> Either x (a,b)
semirot (Right a,b) = Right (a,b)
semirot (Left e,_) = Left e