{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant bracket" #-}

module WebServer (runWebServer) where

import ClassyPrelude hiding (decodeUtf8)
import Data.Text.Encoding
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Types.AppTypes
  ( Env (..),
    HasConnectedClientState (..),
  )
import Types.RoomsState
  ( HasRoomsState (getRoomsState),
    roomStateDiffers,
    updateRoomState,
  )
import WebSocket (broadCastToClients)

newtype WebApp env a = WebApp {unWebApp :: env -> IO a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadReader env,
      MonadIO
    )
    via ReaderT env IO

data WebEnv = WebEnv
  { appEnv :: Env,
    request :: Request,
    respond :: Response -> IO ResponseReceived
  }

instance HasConnectedClientState WebEnv where
  getConnectedClientState = connectedClientsState . appEnv

instance HasRoomsState WebEnv where
  getRoomsState = roomsState . appEnv

class HasWebEnv a where
  getRequest :: a -> Request
  getRespond :: a -> (Response -> IO ResponseReceived)

instance HasWebEnv WebEnv where
  getRequest = request
  getRespond = respond

getRequestBody ::
  ( MonadIO m,
    HasWebEnv env,
    MonadReader env m
  ) =>
  m Text
getRequestBody = do
  request <- getRequest <$> ask
  liftIO $ (decodeUtf8 . toStrict) <$> consumeRequestBodyStrict request

app ::
  ( MonadIO m,
    HasWebEnv env,
    HasConnectedClientState env,
    MonadReader env m,
    HasRoomsState env
  ) =>
  m ResponseReceived
app =
  do
    liftIO $ putStrLn "I've done some IO here"
    getRequestBody >>= broadCastToClients
    respond' <- getRespond <$> ask
    shouldAct <- roomStateDiffers []
    case shouldAct of
      True -> do
        updateRoomState []
        ans respond'
      False -> ans respond'
  where
    ans respond' = liftIO $ respond' $ responseLBS status200 [("Content-Type", "text/plain")] ""

runWebApp ::
  ( MonadIO m,
    MonadReader Env m
  ) =>
  m Application
runWebApp = do
  env <- ask
  return
    ( \req res -> do
        let webEnv = WebEnv {appEnv = env, request = req, respond = res}
        unWebApp app webEnv
    )

runWebServer ::
  ( MonadIO m,
    MonadReader Env m
  ) =>
  m ()
runWebServer = do
  putStrLn "http://localhost:8081/"
  runWebApp >>= liftIO . run 8081
  return ()