-- | This module implments the HTTP message transport backend for the `Network`
-- monad.
module Choreography.Network.Http where

import Choreography.Locations
import Choreography.Network hiding (run, send)
import Control.Concurrent
import Control.Monad
import Control.Monad.Freer
import Control.Monad.IO.Class
import Data.Either (lefts)
import Data.HashMap.Strict (HashMap, (!))
import Data.HashMap.Strict qualified as HashMap
import Data.Proxy (Proxy (..))
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
import Network.Wai.Handler.Warp (run)
import Servant.API
import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM)
import Servant.Server (Handler, Server, serve)

-- * Http configuration

-- | A backend for running `Network` behaviors over HTTP.
--   The configuration specifies how locations are mapped to network hosts and ports.
newtype HttpConfig = HttpConfig
  { HttpConfig -> HashMap LocTm BaseUrl
locToUrl :: HashMap LocTm BaseUrl
  }

-- | The address of a party/location.
type Host = String

-- | The port of a party/location.
type Port = Int

-- | Create a HTTP backend configuration from a association list that maps
--   locations to network hosts and ports.
mkHttpConfig :: [(LocTm, (Host, Port))] -> HttpConfig
mkHttpConfig :: [(LocTm, (LocTm, Port))] -> HttpConfig
mkHttpConfig = HashMap LocTm BaseUrl -> HttpConfig
HttpConfig (HashMap LocTm BaseUrl -> HttpConfig)
-> ([(LocTm, (LocTm, Port))] -> HashMap LocTm BaseUrl)
-> [(LocTm, (LocTm, Port))]
-> HttpConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(LocTm, BaseUrl)] -> HashMap LocTm BaseUrl
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(LocTm, BaseUrl)] -> HashMap LocTm BaseUrl)
-> ([(LocTm, (LocTm, Port))] -> [(LocTm, BaseUrl)])
-> [(LocTm, (LocTm, Port))]
-> HashMap LocTm BaseUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LocTm, (LocTm, Port)) -> (LocTm, BaseUrl))
-> [(LocTm, (LocTm, Port))] -> [(LocTm, BaseUrl)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((LocTm, Port) -> BaseUrl)
-> (LocTm, (LocTm, Port)) -> (LocTm, BaseUrl)
forall a b. (a -> b) -> (LocTm, a) -> (LocTm, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LocTm, Port) -> BaseUrl
f)
  where
    f :: (Host, Port) -> BaseUrl
    f :: (LocTm, Port) -> BaseUrl
f (LocTm
host, Port
port) =
      BaseUrl
        { $sel:baseUrlScheme:BaseUrl :: Scheme
baseUrlScheme = Scheme
Http,
          $sel:baseUrlHost:BaseUrl :: LocTm
baseUrlHost = LocTm
host,
          $sel:baseUrlPort:BaseUrl :: Port
baseUrlPort = Port
port,
          $sel:baseUrlPath:BaseUrl :: LocTm
baseUrlPath = LocTm
""
        }

-- | The list of locations known to a backend.
locs :: HttpConfig -> [LocTm]
locs :: HttpConfig -> [LocTm]
locs = HashMap LocTm BaseUrl -> [LocTm]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap LocTm BaseUrl -> [LocTm])
-> (HttpConfig -> HashMap LocTm BaseUrl) -> HttpConfig -> [LocTm]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpConfig -> HashMap LocTm BaseUrl
locToUrl

-- * Receiving channels

-- | The channels a location uses to recieve messages from various peers.
type RecvChans = HashMap LocTm (Chan String)

-- | Make the channels that will be used to recieve messages.
mkRecvChans :: HttpConfig -> IO RecvChans
mkRecvChans :: HttpConfig -> IO RecvChans
mkRecvChans HttpConfig
cfg = (RecvChans -> LocTm -> IO RecvChans)
-> RecvChans -> [LocTm] -> IO RecvChans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM RecvChans -> LocTm -> IO RecvChans
f RecvChans
forall k v. HashMap k v
HashMap.empty (HttpConfig -> [LocTm]
locs HttpConfig
cfg)
  where
    f ::
      HashMap LocTm (Chan String) ->
      LocTm ->
      IO (HashMap LocTm (Chan String))
    f :: RecvChans -> LocTm -> IO RecvChans
f RecvChans
hm LocTm
l = do
      Chan LocTm
c <- IO (Chan LocTm)
forall a. IO (Chan a)
newChan
      RecvChans -> IO RecvChans
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecvChans -> IO RecvChans) -> RecvChans -> IO RecvChans
forall a b. (a -> b) -> a -> b
$ LocTm -> Chan LocTm -> RecvChans -> RecvChans
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert LocTm
l Chan LocTm
c RecvChans
hm

-- * HTTP backend

-- | A "Servant.API" API.
type API = "send" :> Capture "from" LocTm :> ReqBody '[PlainText] String :> PostNoContent

-- | Run a `Network` behavior, using the provided HTTP backend.
runNetworkHttp :: (MonadIO m) => HttpConfig -> LocTm -> Network m a -> m a
runNetworkHttp :: forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> LocTm -> Network m a -> m a
runNetworkHttp HttpConfig
cfg LocTm
self Network m a
prog = do
  Manager
mgr <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
  RecvChans
chans <- IO RecvChans -> m RecvChans
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecvChans -> m RecvChans) -> IO RecvChans -> m RecvChans
forall a b. (a -> b) -> a -> b
$ HttpConfig -> IO RecvChans
mkRecvChans HttpConfig
cfg
  ThreadId
recvT <- IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (HttpConfig -> RecvChans -> IO ()
recvThread HttpConfig
cfg RecvChans
chans)
  a
result <- Manager -> RecvChans -> Network m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Manager -> RecvChans -> Network m a -> m a
runNetworkMain Manager
mgr RecvChans
chans Network m a
prog
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Port -> IO ()
threadDelay Port
1000000 -- wait until all outstanding requests to be completed
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
recvT
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
  where
    runNetworkMain :: (MonadIO m) => Manager -> RecvChans -> Network m a -> m a
    runNetworkMain :: forall (m :: * -> *) a.
MonadIO m =>
Manager -> RecvChans -> Network m a -> m a
runNetworkMain Manager
mgr RecvChans
chans = (forall b. NetworkSig m b -> m b) -> Freer (NetworkSig m) a -> m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall b. f b -> m b) -> Freer f a -> m a
interpFreer NetworkSig m b -> m b
forall b. NetworkSig m b -> m b
forall (m :: * -> *) a. MonadIO m => NetworkSig m a -> m a
handler
      where
        handler :: (MonadIO m) => NetworkSig m a -> m a
        handler :: forall (m :: * -> *) a. MonadIO m => NetworkSig m a -> m a
handler (Run m a
m) = m a
m
        handler (Send a1
a [LocTm]
ls) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
          [Either ClientError NoContent]
res <- (LocTm -> IO (Either ClientError NoContent))
-> [LocTm] -> IO [Either ClientError NoContent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\LocTm
l -> ClientM NoContent -> ClientEnv -> IO (Either ClientError NoContent)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (LocTm -> LocTm -> ClientM NoContent
send LocTm
self (LocTm -> ClientM NoContent) -> LocTm -> ClientM NoContent
forall a b. (a -> b) -> a -> b
$ a1 -> LocTm
forall a. Show a => a -> LocTm
show a1
a) (Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
mgr (HttpConfig -> HashMap LocTm BaseUrl
locToUrl HttpConfig
cfg HashMap LocTm BaseUrl -> LocTm -> BaseUrl
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
l))) [LocTm]
ls
          case [Either ClientError NoContent] -> [ClientError]
forall a b. [Either a b] -> [a]
lefts [Either ClientError NoContent]
res of
            [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [ClientError]
errors -> LocTm -> IO ()
putStrLn (LocTm -> IO ()) -> LocTm -> IO ()
forall a b. (a -> b) -> a -> b
$ LocTm
"Errors : " LocTm -> LocTm -> LocTm
forall a. Semigroup a => a -> a -> a
<> [ClientError] -> LocTm
forall a. Show a => a -> LocTm
show [ClientError]
errors
        handler (Recv LocTm
l) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ LocTm -> a
forall a. Read a => LocTm -> a
read (LocTm -> a) -> IO LocTm -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chan LocTm -> IO LocTm
forall a. Chan a -> IO a
readChan (RecvChans
chans RecvChans -> LocTm -> Chan LocTm
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
l)

    api :: Proxy API
    api :: Proxy API
api = Proxy API
forall {k} (t :: k). Proxy t
Proxy

    send :: LocTm -> String -> ClientM NoContent
    send :: LocTm -> LocTm -> ClientM NoContent
send = Proxy API -> Client ClientM API
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client Proxy API
api

    server :: RecvChans -> Server API
    server :: RecvChans -> Server API
server RecvChans
chans = Server API
LocTm -> LocTm -> Handler NoContent
handler
      where
        handler :: LocTm -> String -> Handler NoContent
        handler :: LocTm -> LocTm -> Handler NoContent
handler LocTm
rmt LocTm
msg = do
          IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ Chan LocTm -> LocTm -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (RecvChans
chans RecvChans -> LocTm -> Chan LocTm
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
rmt) LocTm
msg
          NoContent -> Handler NoContent
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent

    recvThread :: HttpConfig -> RecvChans -> IO ()
    recvThread :: HttpConfig -> RecvChans -> IO ()
recvThread HttpConfig
cfg' RecvChans
chans = Port -> Application -> IO ()
run (BaseUrl -> Port
baseUrlPort (BaseUrl -> Port) -> BaseUrl -> Port
forall a b. (a -> b) -> a -> b
$ HttpConfig -> HashMap LocTm BaseUrl
locToUrl HttpConfig
cfg' HashMap LocTm BaseUrl -> LocTm -> BaseUrl
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
self) (Proxy API -> Server API -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy API
api (Server API -> Application) -> Server API -> Application
forall a b. (a -> b) -> a -> b
$ RecvChans -> Server API
server RecvChans
chans)

instance Backend HttpConfig where
  runNetwork :: forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> LocTm -> Network m a -> m a
runNetwork = HttpConfig -> LocTm -> Network m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> LocTm -> Network m a -> m a
runNetworkHttp