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

-- | A subsite serving a single-user dungeon.
module Web.Antagonist.Server (
  module Web.Antagonist.Server.Data
  ) where

import Game.Antisplice
import Game.Antisplice.Utils.AVL
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)
import Data.Time.Format
import System.Locale
import Text.Shakespeare.Text
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod

extractSession :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) (Int,SessionState,String)
extractSession = do
  SingleUserSub ctrref avlref ctor <- getYesod
  ssid_ <- lookupSession "ssid"
  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
      return (ss,replay r)
  ((_,ss1),r) <- liftIO $ runRecorderT $ runSession ctor 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 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 :: MonadIO m => SessionState -> m String
getPrompt ss = do
  u <- liftIO $ mutctime
  ((ps,_),_) <- liftIO $ runRecorderT $ runSession (return ()) ss $ expand <=< expand $
                formatTime defaultTimeLocale "%R $prompt" u
  return ps

getPlayR :: Yesod master => HandlerT SingleUserSub (HandlerT master IO) Html
getPlayR = do
  (ssid,ss,ns) <- extractSession
  toMaster <- getRouteToParent
  putSession ssid ss ns
  lift $ defaultLayout $ do
    setTitle $ toHtml [lt| Session #{show ssid}|]
    toWidget $(hamletFile "play.htm")
    toWidget $(cassiusFile "play.cass")
    toWidget $(juliusFile "play.js")

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

postPutR :: (Yesod master,RenderMessage master FormMessage) => HandlerT SingleUserSub (HandlerT master IO) Value
postPutR = do
  SingleUserSub _ _ ctor <- getYesod
  (ssid,ss,ns) <- extractSession
  line <- lift $ runInputPost $ id <$> ireq textField "line"
  ((_,x),r) <- liftIO $ runRecorderT $ runSession ctor 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 (Yesod master,RenderMessage master FormMessage) => YesodSubDispatch SingleUserSub (HandlerT master IO) where
  yesodSubDispatch = $(mkYesodSubDispatch resourcesSingleUserSub)

putSession :: Yesod master => Int -> SessionState -> String -> HandlerT SingleUserSub (HandlerT master IO) ()
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,MonadClock m,MonadRandom m,MonadPrinter m) => Constructor () -> SessionState -> ChattyDungeonM a -> m (a,SessionState)
runSession ctor ss m = do
  x <- withSession ss m
  case x of
    Right r -> return r
    Left e -> do
      mprintLn $ 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."
        _ -> ""
      case e of
        QuitError -> liftM (undefined,) $ startSession ctor
        _ -> return (undefined,ss)
      
withSession :: (MonadIO m,MonadClock m,MonadRandom m,MonadPrinter 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,MonadClock m,MonadRandom m,MonadPrinter m) => Constructor () -> m SessionState
startSession init = do
  Right (_,x) <- withSession ((((none,defVocab),none),0),none) $ do
    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