content: module Web.Hyperbole.Server.Socket where
  
  import Control.Monad (void)
  import Data.Bifunctor (first)
  import Data.List qualified as L
  import Data.Maybe (fromMaybe)
  import Data.String.Conversions (cs)
  import Data.Text (Text)
  import Effectful
  import Effectful.Concurrent.Async
  import Effectful.Exception
  import Network.HTTP.Types as HTTP (parseQuery)
  import Network.Wai qualified as Wai
  import Network.WebSockets (Connection)
  import Network.WebSockets qualified as WS
  import Web.Cookie qualified
  import Web.Hyperbole.Data.Cookie qualified as Cookie
  import Web.Hyperbole.Data.URI (URI, path)
  import Web.Hyperbole.Effect.Hyperbole
  import Web.Hyperbole.Server.Message
  import Web.Hyperbole.Server.Options
  import Web.Hyperbole.Types.Request
  import Web.Hyperbole.Types.Response
  import Web.Hyperbole.View (View, addContext, renderLazyByteString)
  
  
  data SocketRequest = SocketRequest
    { request :: Maybe Request
    }
  
  
  handleRequestSocket
    :: (IOE :> es, Concurrent :> es)
    => ServerOptions
    -> Wai.Request
    -> Connection
    -> Eff (Hyperbole : es) Response
    -> Eff es ()
  handleRequestSocket opts wreq conn actions = do
    flip catch onMessageError $ do
      msg <- receiveMessage
      req <- parseMessageRequest msg
  
      void $ async $ do
        res <- trySync $ runHyperbole req actions
        case res of
          -- TODO: catch socket errors separately from SomeException?
          Left (ex :: SomeException) -> do
            -- It's not safe to send any exception over the wire
            -- log it to the console and send the error to the client
            liftIO $ print ex
            res2 <- trySync $ sendError conn (requestMetadata req) (opts.serverError ErrInternal)
            case res2 of
              Left e -> liftIO $ putStrLn $ "Socket Error while sending previous error to client: " <> show e
              Right _ -> pure ()
          Right (resp, clnt, rmts) -> do
            let meta = requestMetadata req <> responseMetadata req.path clnt rmts
            case resp of
              (Response _ vw) -> do
                sendUpdateView conn meta vw
              -- (Err (ErrServer m)) -> sendError conn meta (opts.serverError m)
              (Err err) -> sendError conn meta (opts.serverError err)
              (Redirect url) -> sendRedirect conn meta url
   where
    onMessageError :: (IOE :> es) => MessageError -> Eff es a
    onMessageError e = do
      liftIO $ do
        putStrLn "Socket Message Error"
      throwIO e
  
    receiveMessage :: (IOE :> es) => Eff es Message
    receiveMessage = do
      t <- receiveText conn
      case parseActionMessage t of
        Left e -> throwIO $ InvalidMessage e t
        Right msg -> pure msg
  
    receiveText :: (IOE :> es) => Connection -> Eff es Text
    receiveText _ = do
      -- c <- ask @Connection
      liftIO $ WS.receiveData conn
  
    parseMessageRequest :: (IOE :> es) => Message -> Eff es Request
    parseMessageRequest msg =
      case messageRequest msg of
        Left e -> throwIO e
        Right a -> pure a
  
    messageRequest :: Message -> Either MessageError Request
    messageRequest msg = do
      let pth = path $ cs $ Wai.rawPathInfo wreq
          host = Host $ fromMaybe "" $ L.lookup "Host" headers
          headers = Wai.requestHeaders wreq
          method = "POST"
  
          body = msg.body.value
  
      query <- HTTP.parseQuery . cs <$> requireMeta "Query" msg.metadata
      cookie <- cs <$> requireMeta "Cookie" msg.metadata
  
      cookies <- first (InvalidCookie cookie) <$> Cookie.parse $ Web.Cookie.parseCookies cookie
  
      pure $
        Request
          { path = pth
          , event = Just msg.event
          , host
          , query
          , body
          , method
          , cookies
          , requestId = msg.requestId
          }
     where
      requireMeta :: MetaKey -> Metadata -> Either MessageError Text
      requireMeta key m =
        maybe (Left $ MissingMeta (cs key)) pure $ lookupMetadata key m
  
  
  sendUpdateView :: (IOE :> es) => Connection -> Metadata -> View Body () -> Eff es ()
  sendUpdateView conn meta vw = do
    sendMessage conn meta (RenderedHtml $ renderLazyByteString $ addContext Body vw)
  
  
  sendRedirect :: (IOE :> es) => Connection -> Metadata -> URI -> Eff es ()
  sendRedirect conn meta u = do
    sendMessage conn (metaRedirect u <> meta) mempty
  
  
  sendError :: (IOE :> es) => Connection -> Metadata -> ServerError -> Eff es ()
  sendError conn meta (ServerError err body) = do
    sendMessage conn (metadata "Error" err <> meta) (RenderedHtml $ renderLazyByteString $ addContext Body body)
  
  
  -- low level message. Use sendResponse
  sendMessage :: (MonadIO m) => Connection -> Metadata -> RenderedHtml -> m ()
  sendMessage conn meta' (RenderedHtml html) = do
    let out = "|UPDATE|\n" <> cs (renderMetadata meta') <> "\n\n" <> html
    liftIO $ WS.sendTextData conn out
  