{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs     #-}

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

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

-- * Servant API

type API = "send" :> Capture "from" LocTm :> ReqBody '[PlainText] String :> PostNoContent

-- * Http configuration

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

type Host = String
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. 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
      { baseUrlScheme :: Scheme
baseUrlScheme = Scheme
Http
      , baseUrlHost :: LocTm
baseUrlHost = LocTm
host
      , baseUrlPort :: Port
baseUrlPort = Port
port
      , baseUrlPath :: LocTm
baseUrlPath = LocTm
""
      }

locsHttp :: HttpConfig -> [LocTm]
locsHttp :: HttpConfig -> [LocTm]
locsHttp = 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

type RecvChans = HashMap LocTm (Chan String)

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]
locsHttp 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 (m :: * -> *) a. Monad m => a -> m a
return (RecvChans -> IO RecvChans) -> RecvChans -> IO RecvChans
forall a b. (a -> b) -> a -> b
$ LocTm -> Chan LocTm -> RecvChans -> RecvChans
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HashMap.insert LocTm
l Chan LocTm
c RecvChans
hm

-- * 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
  -- liftIO $ threadDelay 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 (m :: * -> *) a. Monad m => a -> m a
return 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 a1. NetworkSig m a1 -> m a1)
-> Freer (NetworkSig m) a -> m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall a1. f a1 -> m a1) -> Freer f a -> m a
interpFreer NetworkSig m a1 -> m a1
forall a1. NetworkSig m a1 -> m a1
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
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
$ do
          Either ClientError NoContent
res <- 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. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! LocTm
l))
          case Either ClientError NoContent
res of
            Left ClientError
err -> LocTm -> IO ()
putStrLn (LocTm -> IO ()) -> LocTm -> IO ()
forall a b. (a -> b) -> a -> b
$ LocTm
"Error : " LocTm -> LocTm -> LocTm
forall a. [a] -> [a] -> [a]
++ ClientError -> LocTm
forall a. Show a => a -> LocTm
show ClientError
err
            Right NoContent
_  -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! LocTm
l)
     -- handler (Recv l)     = liftIO $ putStrLn ("Recv from " <> l) *> (read <$> readChan (chans ! l))
        handler (BCast a1
a [LocTm]
ls) = (NetworkSig m () -> m ()) -> [NetworkSig m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NetworkSig m () -> m ()
forall (m :: * -> *) a. MonadIO m => NetworkSig m a -> m a
handler ([NetworkSig m ()] -> m ()) -> [NetworkSig m ()] -> m ()
forall a b. (a -> b) -> a -> b
$ (LocTm -> NetworkSig m ()) -> [LocTm] -> [NetworkSig m ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a1 -> LocTm -> NetworkSig m ()
forall a1 (m :: * -> *). Show a1 => a1 -> LocTm -> NetworkSig m ()
Send a1
a) [LocTm]
ls

    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. (Hashable k, HasCallStack) => HashMap k v -> k -> v
! LocTm
rmt) LocTm
msg
          NoContent -> Handler NoContent
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return 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. (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
  locs :: HttpConfig -> [LocTm]
locs = HttpConfig -> [LocTm]
locsHttp
  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