{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
module LabyrinthServer where

import Control.Applicative
import Control.Concurrent
import Control.Exception (bracket, fromException, handleJust)
import Control.Lens hiding ((.=))
import Control.Monad
import Control.Monad.IO.Class

import Data.Acid ( AcidState
                 , EventResult
                 , EventState
                 , openLocalStateFrom
                 , QueryEvent
                 , UpdateEvent
                 )
import Data.Acid.Advanced (query', update')
import Data.Acid.Local (createCheckpointAndClose)
import Data.Aeson
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString.Lazy as BS
import Data.Function
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.String as S

import Network.Wai.Handler.Warp
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS

import System.Environment
import System.FilePath.Posix
import System.Random

import Text.Hamlet (hamletFile)
import Text.Julius (juliusFile)
import Text.Lucius (luciusFile)

import Yesod hiding (delete, update)
import Yesod.Static

import Labyrinth hiding (performMove)

import LabyrinthServer.Data
import LabyrinthServer.JSON

newId :: (MonadIO m) => m String
newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z')

envVar :: String -> IO (Maybe String)
envVar var = do
    env <- liftM M.fromList getEnvironment
    return $ M.lookup var env

envVarWithDefault :: String -> String -> IO String
envVarWithDefault def var =
    liftM (fromMaybe def) (envVar var)

getDataPath :: IO String
getDataPath = do
    dataDir <- envVarWithDefault "." "OPENSHIFT_DATA_DIR"
    return $ dataDir </> "state"

data WatchTarget = GameList | GameLog GameId
                   deriving (Eq, Ord)

data ConnectionInfo = ConnectionInfo { ciId   :: String
                                     , ciConn :: WS.Connection
                                     }
instance Eq ConnectionInfo where
    (==) = (==) `on` ciId

mkConnInfo :: WS.Connection -> IO ConnectionInfo
mkConnInfo conn = do
    id <- newId
    return $ ConnectionInfo id conn

type Watchers = M.Map WatchTarget [ConnectionInfo]

data LabyrinthServer = LabyrinthServer { lsGames    :: AcidState Games
                                       , lsStatic   :: Static
                                       , lsWatchers :: MVar Watchers
                                       }

staticFiles "static"

mkYesod "LabyrinthServer" [parseRoutes|
/                    HomeR          GET
/games               GamesR         GET
/game                NewGameR       POST
/game/#GameId        GameR          GET
/game/#GameId/move   MakeMoveR      POST
/game/#GameId/delete DeleteGameR    DELETE
/examples            ExampleMovesR  GET
/static              StaticR        Static lsStatic
|]

instance Yesod LabyrinthServer where
    defaultLayout = mainLayout

makeServer :: FilePath -> (LabyrinthServer -> IO a) -> IO a
makeServer dataPath cont = do
    static <- static "static"
    bracket
        (openLocalStateFrom dataPath noGames)
        createCheckpointAndClose $
        \acid -> do
            watchers <- newMVar M.empty
            cont $ LabyrinthServer acid static watchers

labyrinthMain :: IO ()
labyrinthMain = do
    dataPath <- getDataPath
    makeServer dataPath $ \server -> do
        port <- liftM read $ envVarWithDefault "8080" "PORT"
        ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP"
        app <- toWaiApp server
        let intercept = WaiWS.intercept $ wsHandler server
        let settings = defaultSettings { settingsPort      = port
                                       , settingsHost      = Host ip
                                       , settingsIntercept = intercept
                                       }
        runSettings settings app

instance RenderMessage LabyrinthServer FormMessage where
    renderMessage _ _ = defaultFormMessage

wsHandler :: LabyrinthServer -> WS.PendingConnection -> IO ()
wsHandler site rq = do
    let path = T.unpack $ E.decodeUtf8 $ WS.requestPath $ WS.pendingRequest rq
    -- TODO: parse path better
    let watch = if path == "/games" then GameList else GameLog $ drop 6 path
    conn <- WS.acceptRequest rq
    ci <- mkConnInfo conn
    addWatcher site watch ci
    forever $ handleConnError (removeWatcher site watch ci) $ do
        -- Ignore all received messages
        WS.receive conn
        return ()

handleConnError :: IO a -> IO a -> IO a
handleConnError handler = handleJust whenWSError (const handler)
                         . handleJust whenIOError (const handler)
    where whenWSError e = fromException e :: Maybe WS.ConnectionException
          whenIOError e = fromException e :: Maybe IOError

withWatchers :: LabyrinthServer -> (Watchers -> IO Watchers) -> IO ()
withWatchers site = modifyMVar_ $ lsWatchers site

addWatcher :: LabyrinthServer -> WatchTarget -> ConnectionInfo -> IO ()
addWatcher site watch ci = withWatchers site $ \watchers ->
        return $ M.insertWith (++) watch [ci] watchers

removeWatcher :: LabyrinthServer -> WatchTarget -> ConnectionInfo -> IO ()
removeWatcher site watch ci = withWatchers site $ \watchers ->
        return $ removeWatcher' watch ci watchers

removeWatcher' :: WatchTarget -> ConnectionInfo -> Watchers -> Watchers
removeWatcher' watch ci = M.update (nullMaybe . delete ci) watch
    where nullMaybe [] = Nothing
          nullMaybe x  = Just x

query :: (QueryEvent event, EventState event ~ Games)
      => event
      -> Handler (EventResult event)
query ev = do
    site <- getYesod
    let acid = lsGames site
    query' acid ev

update :: (UpdateEvent event, EventState event ~ Games)
       => WatchTarget
       -> event
       -> Handler (EventResult event)
update watch ev = do
    site <- getYesod
    let acid = lsGames site
    res <- update' acid ev
    notifyWatchers site watch
    return res

notifyWatchers :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m ()
notifyWatchers site watch = liftIO $ withWatchers site $ \watchersMap -> do
    let watchers = fromMaybe [] $ M.lookup watch watchersMap
    value <- watchTargetValue site watch
    let notifyOne watchersMap ci = handleConnError
            (return $ removeWatcher' watch ci watchersMap)
            $ do
                WS.sendTextData (ciConn ci) (encode value)
                return watchersMap
    foldM notifyOne watchersMap watchers

watchTargetValue :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m Value
watchTargetValue site GameList = do
    let acid = lsGames site
    result <- query' acid GetGames
    return $ toJSON result
watchTargetValue site (GameLog gameId) = do
    let acid = lsGames site
    result <- query' acid $ GetGame gameId
    return $ toJSON result

immediateResponse :: WatchTarget -> Handler Value
immediateResponse target = do
    site <- getYesod
    result <- watchTargetValue site target
    returnCORSJson result

postForm :: (Html -> MForm Handler (FormResult a, Widget))
         -> (a -> Handler Value)
         -> Handler Value
postForm form handler = do
    ((result, _), _) <- runFormPostNoToken form
    case result of
        FormSuccess value -> handler value
        FormFailure errors -> returnCORSJson errors

addCORSHeader :: MonadHandler m => m ()
addCORSHeader = addHeader "Access-Control-Allow-Origin" "*"

returnCORSJson :: (MonadHandler m, ToJSON a) => a -> m Value
returnCORSJson v = do
    addCORSHeader
    returnJson v

mainLayout :: Widget -> Handler Html
mainLayout widget = do
    p <- widgetToPageContent widget
    giveUrlRenderer $(hamletFile "templates/layout.hamlet")

getHomeR :: Handler Html
getHomeR = defaultLayout $ do
    addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/jquery/2.0.3/jquery.min.js"
    addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/handlebars.js/1.0.0/handlebars.min.js"
    toWidget $(juliusFile "templates/index.julius")
    toWidget $(luciusFile "templates/index.lucius")
    $(whamletFile "templates/index.hamlet")

getGamesR :: Handler Value
getGamesR = immediateResponse GameList

named :: T.Text -> FieldSettings LabyrinthServer
named name = FieldSettings "" Nothing Nothing (Just name) []

newGameForm :: Html
            -> MForm Handler (FormResult LabyrinthParams, Widget)
newGameForm = renderDivs $ LabyrinthParams
    <$> (LabyrinthFeatures <$> areq checkBoxField (named "pits") (Just True)
                           <*> areq checkBoxField (named "rivers") (Just True))
    <*> areq intField (named "width") Nothing
    <*> areq intField (named "height") Nothing
    <*> areq intField (named "players") Nothing

postNewGameR :: Handler Value
postNewGameR = postForm newGameForm $ \params -> do
    lab <- createLabyrinth params
    gameId <- newId
    res <- update GameList $ AddGame gameId lab
    returnCORSJson (if res then "ok" else "bad game" :: String)

getGameR :: GameId -> Handler Value
getGameR gameId = immediateResponse (GameLog gameId)

data PlayerMove = PlayerMove { pmplayer :: PlayerId
                             , pmmove   :: T.Text
                             }

makeMoveForm :: Html
             -> MForm Handler (FormResult PlayerMove, Widget)
makeMoveForm = renderDivs $ PlayerMove
    <$> areq intField (named "player") Nothing
    <*> areq textField (named "move") Nothing

parseMove' :: T.Text -> Either String Move
parseMove' str = case eitherDecode (BS.fromStrict $ E.encodeUtf8 str) of
    Left err -> parseMove (T.unpack str)
    Right m -> Right m

postMakeMoveR :: GameId -> Handler Value
postMakeMoveR gameId = postForm makeMoveForm $ \playerMove -> do
    let PlayerMove playerId moveStr = playerMove
    case parseMove' moveStr of
        Left err   -> returnCORSJson $ object ["error" .= err]
        Right move -> do
            res <- update (GameLog gameId) $ PerformMove gameId playerId move
            returnCORSJson res

deleteDeleteGameR :: GameId -> Handler Value
deleteDeleteGameR gameId = do
    update GameList $ RemoveGame gameId
    returnCORSJson ("ok" :: String)

getExampleMovesR :: Handler Value
getExampleMovesR = returnCORSJson $ Sensitive True exampleMoves