{-# LANGUAGE OverloadedStrings #-}

module Web.Minion.Examples.ServerEvent (app) where

import Control.Concurrent (Chan, forkIO, newChan, readChan, writeChan)
import Control.Monad (forever)
import Control.Monad.Trans.Reader
import Data.Binary.Builder as Binary
import Web.Minion
import Web.Minion.Response.ServerEvent

{- FOURMOLU_DISABLE -}
-- The server accepts strings from the console and sends them to clients via SSE.
-- $ cabal run minion-wai-extra-sse-example -v0 |
--                                              | $ curl localhost:9001/api/sse
-- hello                                        |
--                                              | event:typed_string
--                                              | data:hello
-- how are you                                  |
--                                              | event:typed_string
--                                              | data:how are you
-- ^C                                           |
--                                              | curl: (18) transfer closed with outstanding read data remaining
{- FOURMOLU_ENABLE -}
app :: IO (ApplicationM IO)
app :: IO (ApplicationM IO)
app = do
  Chan String
chan <- forall a. IO (Chan a)
newChan @String
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
    IO String
getLine IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chan String -> String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan String
chan
  ApplicationM IO -> IO (ApplicationM IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApplicationM IO -> IO (ApplicationM IO))
-> ApplicationM IO -> IO (ApplicationM IO)
forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
resp -> ReaderT (Chan String) IO ResponseReceived
-> Chan String -> IO ResponseReceived
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Router' Void Void (ReaderT (Chan String) IO)
-> ApplicationM (ReaderT (Chan String) IO)
forall (m :: * -> *) i.
(MonadIO m, MonadCatch m) =>
Router' i Void m -> ApplicationM m
serve Router' Void Void (ReaderT (Chan String) IO)
api Request
req Response -> IO ResponseReceived
resp) Chan String
chan

api :: Router Void (ReaderT (Chan String) IO)
api :: Router' Void Void (ReaderT (Chan String) IO)
api = Router' Void Void (ReaderT (Chan String) IO)
-> Router' Void Void (ReaderT (Chan String) IO)
"api" (Router' Void Void (ReaderT (Chan String) IO)
 -> Router' Void Void (ReaderT (Chan String) IO))
-> Router' Void Void (ReaderT (Chan String) IO)
-> Router' Void Void (ReaderT (Chan String) IO)
forall i ts (r :: * -> *).
(Router' i ts r -> Router' i ts r)
-> Router' i ts r -> Router' i ts r
/> Router' Void Void (ReaderT (Chan String) IO)
-> Router' Void Void (ReaderT (Chan String) IO)
"sse" (Router' Void Void (ReaderT (Chan String) IO)
 -> Router' Void Void (ReaderT (Chan String) IO))
-> Router' Void Void (ReaderT (Chan String) IO)
-> Router' Void Void (ReaderT (Chan String) IO)
forall i ts (r :: * -> *).
(Router' i ts r -> Router' i ts r)
-> Router' i ts r -> Router' i ts r
/> Method
-> (DelayedArgs '[]
    ~> ReaderT (Chan String) IO (EventSource ServerEvent))
-> Router' Void Void (ReaderT (Chan String) IO)
forall o (m :: * -> *) ts i (st :: [*]).
(HandleArgs ts st m, ToResponse m o, CanRespond o,
 Introspection i 'Response o) =>
Method -> (DelayedArgs st ~> m o) -> Router' i ts m
handle Method
GET DelayedArgs '[]
~> ReaderT (Chan String) IO (EventSource ServerEvent)
ReaderT (Chan String) IO (EventSource ServerEvent)
sse

sse :: ReaderT (Chan String) IO (EventSource ServerEvent)
sse :: ReaderT (Chan String) IO (EventSource ServerEvent)
sse = do
  Chan String
chan <- ReaderT (Chan String) IO (Chan String)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  EventSource ServerEvent
-> ReaderT (Chan String) IO (EventSource ServerEvent)
forall a. a -> ReaderT (Chan String) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EventSource ServerEvent
 -> ReaderT (Chan String) IO (EventSource ServerEvent))
-> EventSource ServerEvent
-> ReaderT (Chan String) IO (EventSource ServerEvent)
forall a b. (a -> b) -> a -> b
$ IO ServerEvent -> EventSource ServerEvent
forall a. IO a -> EventSource a
EventSource do
    Maybe Builder -> Maybe Builder -> [Builder] -> ServerEvent
ServerEvent (Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ String -> Builder
Binary.putStringUtf8 String
"typed_string") Maybe Builder
forall a. Maybe a
Nothing
      ([Builder] -> ServerEvent)
-> (String -> [Builder]) -> String -> ServerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Builder -> [Builder])
-> (String -> Builder) -> String -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
Binary.putStringUtf8
      (String -> ServerEvent) -> IO String -> IO ServerEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chan String -> IO String
forall a. Chan a -> IO a
readChan Chan String
chan