{-# 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.ByteString (fromStrict)
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
import Servant.Client (ClientM, client, runClientM, BaseUrl(..), mkClientEnv, Scheme(..))
import Servant.Server (Handler, Server, serve)
import Control.Concurrent
import Control.Concurrent.Chan
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
""
      }

locs :: HttpConfig -> [LocTm]
locs :: HttpConfig -> [LocTm]
locs = forall k v. HashMap k v -> [k]
HashMap.keys 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 = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM RecvChans -> LocTm -> IO RecvChans
f 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 <- forall a. IO (Chan a)
newChan
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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

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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
  RecvChans
chans <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HttpConfig -> IO RecvChans
mkRecvChans HttpConfig
cfg
  ThreadId
recvT <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (HttpConfig -> RecvChans -> IO ()
recvThread HttpConfig
cfg RecvChans
chans)
  a
result <- forall (m :: * -> *) a.
MonadIO m =>
Manager -> RecvChans -> Network m a -> m a
runNetworkMain Manager
mgr RecvChans
chans Network m a
prog
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Port -> IO ()
threadDelay Port
1000000 -- wait until all outstanding requests to be completed
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
recvT
  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 (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall a1. f a1 -> m a1) -> Freer f a -> m a
interpFreer 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 a
a LocTm
l) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Either ClientError NoContent
res <- forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (LocTm -> LocTm -> ClientM NoContent
send LocTm
self forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> LocTm
show a
a) (Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
mgr (HttpConfig -> HashMap LocTm BaseUrl
locToUrl HttpConfig
cfg forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
l))
          case Either ClientError NoContent
res of
            Left ClientError
err -> LocTm -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ LocTm
"Error : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> LocTm
show ClientError
err
            Right NoContent
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        handler (Recv LocTm
l)   = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Read a => LocTm -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Chan a -> IO a
readChan (RecvChans
chans forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
l)
        handler (BCast a
a)  = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => NetworkSig m a -> m a
handler forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a (m :: * -> *). Show a => a -> LocTm -> NetworkSig m ()
Send a
a) (HttpConfig -> [LocTm]
locs HttpConfig
cfg)

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

    send :: LocTm -> String -> ClientM NoContent
    send :: LocTm -> LocTm -> ClientM NoContent
send = 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 = LocTm -> LocTm -> Handler NoContent
handler
      where
        handler :: LocTm -> String -> Handler NoContent
        handler :: LocTm -> LocTm -> Handler NoContent
handler LocTm
rmt LocTm
msg = do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> a -> IO ()
writeChan (RecvChans
chans forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
rmt) LocTm
msg
          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 forall a b. (a -> b) -> a -> b
$ HttpConfig -> HashMap LocTm BaseUrl
locToUrl HttpConfig
cfg forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
! LocTm
self ) (forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy API
api 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 = forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> LocTm -> Network m a -> m a
runNetworkHttp