{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Scotty.Comet
    ( connect
    , kCometPlugin
    , send
    , Document
    , Options(..)
    , getReply
    , eventQueue
    , debugDocument
    , debugReplyDocument
    , defaultOptions
    ) where

import qualified Web.Scotty as Scotty
import Web.Scotty (ScottyM, text, post, capture, setHeader, get, ActionM, jsonData)
import Data.Aeson (Value(..))
import Control.Monad
import Control.Concurrent.STM as STM
import Control.Concurrent.MVar as STM
import Control.Monad.IO.Class
import Paths_kansas_comet (getDataFileName)
import qualified Data.Map as Map
import Control.Concurrent
import Data.Default.Class
import Data.Maybe ( fromJust )
import System.Exit
import qualified Data.Text.Lazy as LT
import qualified Data.Text      as T
import Data.Time.Calendar
import Data.Time.Clock
import Numeric

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#else
import qualified Data.HashMap.Strict as HashMap
#endif

-- | connect "/foobar" (...) gives a scotty session that:
--
-- >  POST http://.../foobar/                       <- bootstrap the interaction
-- >  GET  http://.../foobar/act/<id#>/<act#>       <- get a specific action
-- >  POST http://.../foobar/reply/<id#>/<reply#>   <- send a reply as a JSON object

connect :: Options             -- ^ URL path prefix for this page
        -> (Document -> IO ()) -- ^ called for access of the page
        -> IO (ScottyM ())
connect opt callback = do
   if not rtsSupportsBoundThreads  -- we need the -threaded flag turned on
   then do putStrLn "Application needs to be re-compiled with -threaded flag"
           exitFailure
   else return ()


   when (verbose opt >= 1) $ putStrLn $ "kansas-comet connect with prefix=" ++ show (prefix opt)

   -- A unique number generator, or ephemeral generator.
   -- This is the (open) secret between the client and server.
   -- (Why are we using an MVar vs a TMVar? No specific reason here)
   uniqVar <- newMVar 0
   let getUniq :: IO Int
       getUniq = do
              u <- takeMVar uniqVar
              putMVar uniqVar (u + 1)
              return u

   tm ::  UTCTime  <- getCurrentTime

   let server_id
           = Numeric.showHex (toModifiedJulianDay (utctDay tm))
           $ ("-" ++)
           $ Numeric.showHex (floor (utctDayTime tm * 1000) :: Integer)
           $ ""

   contextDB <- atomically $ newTVar $ (Map.empty :: Map.Map Int Document)
   let newContext :: IO Int
       newContext = do
            uq <- getUniq
            picture <- atomically $ newEmptyTMVar
            callbacks <- atomically $ newTVar $ Map.empty
            queue <- atomically $ newTChan
            let cxt = Document picture callbacks queue uq
            liftIO $ atomically $ do
                    db <- readTVar contextDB
                    -- assumes the getUniq is actually unique
                    writeTVar contextDB $ Map.insert uq cxt db
            -- Here is where we actually spawn the user code
            _ <- forkIO $ callback cxt
            return uq

   -- POST starts things off.
   return $ do
       post (capture $ prefix opt ++ "/") $ do
                uq  <- liftIO $ newContext
                text (LT.pack $ "$.kc.session(" ++ show server_id ++ "," ++ show uq ++ ");")

       -- GET the updates to the documents (should this be an (empty) POST?)

    --   liftIO $ print $ prefix opt ++ "/act/:id/:act"
       get (capture $ prefix opt ++ "/act/" ++ server_id ++ "/:id/:act") $ do
                setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"
                -- do something and return a new list of commands to the client
                num <- captureParam "id"

                when (verbose opt >= 2) $ liftIO $ putStrLn $
                    "Kansas Comet: get .../act/" ++ show num
    --            liftIO $ print (num :: Int)

                let tryPushAction :: TMVar T.Text -> Int -> ActionM ()
                    tryPushAction var n = do
                        -- The PUSH archtecture means that we wait upto 3 seconds if there
                        -- is not javascript to push yet. This stops a busy-waiting
                        -- (or technically restricts it to once every 3 second busy)
                        ping <- liftIO $ registerDelay (3 * 1000 * 1000)
                        res <- liftIO $ atomically $ do
                                b <- readTVar ping
                                if b then return Nothing else do
                                     liftM Just (takeTMVar var)


                        when (verbose opt >= 2) $ liftIO $ putStrLn $
                                    "Kansas Comet (sending to " ++ show n ++ "):\n" ++ show res

                        case res of
                         Just js -> do
    --                            liftIO $ putStrLn $ show js
                                text $ LT.fromChunks [js]
                         Nothing  ->
                                -- give the browser something to do (approx every 3 seconds)
                                text LT.empty

                db <- liftIO $ atomically $ readTVar contextDB
                case Map.lookup num db of
                   Nothing  -> text (LT.pack $ "console.warn('Can not find act #" ++ show num ++ "');")
                   Just doc -> tryPushAction (sending doc) num


       post (capture $ prefix opt ++ "/reply/" ++ server_id ++ "/:id/:uq") $ do
               setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"
               num <- captureParam "id"
               uq :: Int <- captureParam "uq"
               --liftIO $ print (num :: Int, event :: String)

               when (verbose opt >= 2) $ liftIO $ putStrLn $
                    "Kansas Comet: post .../reply/" ++ show num ++ "/" ++ show uq

               wrappedVal :: Value <- jsonData
               -- Unwrap the data wrapped, because 'jsonData' only supports
               -- objects or arrays, but not primitive values like numbers
               -- or booleans.
               m <- case wrappedVal of
                      Object m -> return m
                      _ -> fail $ "Expected Object, received: " ++ show wrappedVal
               let val = fromJust $ lookupKM "data" m
               --liftIO $ print (val :: Value)
               db <- liftIO $ atomically $ readTVar contextDB
               case Map.lookup num db of
                   Nothing  -> do
                       text (LT.pack $ "console.warn('Ignore reply for session #" ++ show num ++ "');")
                   Just doc -> do
                       liftIO $ do
                             atomically $ do
                               mv <- readTVar (replies doc)
                               writeTVar (replies doc) $ Map.insert uq val mv
                       text $ LT.pack ""


       post (capture $ prefix opt ++ "/event/" ++ server_id ++ "/:id") $ do
               setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"
               num <- captureParam "id"

               when (verbose opt >= 2) $ liftIO $ putStrLn $
                    "Kansas Comet: post .../event/" ++ show num

               wrappedVal :: Value <- jsonData
               -- Unwrap the data wrapped, because 'jsonData' only supports
               -- objects or arrays, but not primitive values like numbers
               -- or booleans.
               m <- case wrappedVal of
                      Object m -> return m
                      _ -> fail $ "Expected Object, received: " ++ show wrappedVal
               let val = fromJust $ lookupKM "data" m
               --liftIO $ print (val :: Value)

               db <- liftIO $ atomically $ readTVar contextDB
               case Map.lookup num db of
                   Nothing  -> do
                       text (LT.pack $ "console.warn('Ignore reply for session #" ++ show num ++ "');")
                   Just doc -> do
                       liftIO $ atomically $ do
                               writeTChan (eventQueue doc) val
                       text $ LT.pack ""

  where
#if MIN_VERSION_aeson(2,0,0)
    lookupKM = KeyMap.lookup
#else
    lookupKM = HashMap.lookup
#endif

#if MIN_VERSION_scotty(0,20,0)
    captureParam = Scotty.captureParam
#else
    captureParam = Scotty.param
#endif

-- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin.
kCometPlugin :: IO String
kCometPlugin = getDataFileName "static/js/kansas-comet.js"

-- | 'send' sends a javascript fragement to a document.
-- The Text argument will be evaluated before sending (in case there is an error,
-- or some costly evaluation needs done first).
-- 'send' suspends the thread if the last javascript has not been *dispatched*
-- the the browser.
send :: Document -> T.Text -> IO ()
send doc js = atomically $ putTMVar (sending doc) $! js

-- | wait for a virtual-to-this-document's port numbers' reply.
getReply :: Document -> Int -> IO Value
getReply doc num = do
        atomically $ do
           db <- readTVar (replies doc)
           case Map.lookup num db of
              Nothing -> retry
              Just r -> do
                      writeTVar (replies doc) $ Map.delete num db
                      return r

-- | 'Document' is the Handle into a specific interaction with a web page.
data Document = Document
        { sending    :: TMVar T.Text             -- ^ Code to be sent to the browser
                                                 -- This is a TMVar to stop the generation
                                                 -- getting ahead of the rendering engine
        , replies    :: TVar (Map.Map Int Value) -- ^ This is numbered replies, to ports
        , eventQueue :: TChan Value              -- ^ Events being sent
        , _secret    :: Int                      -- ^ the (session) number of this document
        } deriving Eq

-- 'Options' for Comet.
data Options = Options
        { prefix  :: String             -- ^ what is the prefix at at start of the URL (for example \"ajax\")
        , verbose :: Int                -- ^ 0 == none (default), 1 == inits, 2 == cmds done, 3 == complete log
        } deriving (Eq, Ord, Show)

instance Default Options where
  def = Options
        { prefix = ""                   -- default to root, this assumes single page, etc.
        , verbose = 0
        }


-- Defaults for 'Options'. Or you can use the defaults package.
defaultOptions :: Options
defaultOptions = def

------------------------------------------------------------------------------------

-- | Generate a @Document@ that prints what it would send to the server.
debugDocument :: IO Document
debugDocument = do
  picture <- atomically $ newEmptyTMVar
  callbacks <- atomically $ newTVar $ Map.empty
  _ <- forkIO $ forever $ do
          res <- atomically $ takeTMVar $ picture
          putStrLn $ "Sending: " ++ show res
  q <- atomically $ newTChan
  return $ Document picture callbacks q 0

-- | Fake a specific reply on a virtual @Document@ port.
debugReplyDocument :: Document -> Int -> Value -> IO ()
debugReplyDocument doc uq val = atomically $ do
   m <- readTVar (replies doc)
   writeTVar (replies doc) $ Map.insert uq val m