From 2e66ae10ec825aea914e8bb7b4517974570647ec Mon Sep 17 00:00:00 2001
From: Elliot Glaysher <glaysher@umich.edu>
Date: Mon, 10 Aug 2020 13:15:03 -0400
Subject: [PATCH] natpmp: use MonadIO in the bindings to remove unsightly "io
 $"

---
 .../natpmp-static/hsrc_lib/Network/NATPMP.hsc | 34 +++++++++++--------
 pkg/hs/natpmp-static/natpmp-static.cabal      |  1 +
 pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs     | 10 +++---
 3 files changed, 26 insertions(+), 19 deletions(-)

diff --git a/pkg/hs/natpmp-static/hsrc_lib/Network/NATPMP.hsc b/pkg/hs/natpmp-static/hsrc_lib/Network/NATPMP.hsc
index c48dd2a234..74a947a1e9 100644
--- a/pkg/hs/natpmp-static/hsrc_lib/Network/NATPMP.hsc
+++ b/pkg/hs/natpmp-static/hsrc_lib/Network/NATPMP.hsc
@@ -12,6 +12,8 @@ module Network.NATPMP (Error(..),
                        getPublicAddress,
                        setPortMapping) where
 
+import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO, withRunInIO)
+
 #include <netinet/in.h>
 
 #include <getgateway.h>
@@ -210,31 +212,34 @@ instance Enum Error where
   toEnum unmatched = error ("Error.toEnum: Cannot match " ++ show unmatched)
 
 
-initNatPmp :: IO (Either Error NatPmpHandle)
+initNatPmp :: (MonadIO m)
+           => m (Either Error NatPmpHandle)
 initNatPmp = do
-  natpmp  <- mallocBytes #{size natpmp_t}
-  ret <- _init_nat_pmp natpmp 0 0
+  natpmp <- liftIO $ mallocBytes #{size natpmp_t}
+  ret    <- liftIO $ _init_nat_pmp natpmp 0 0
   case ret of
     0 -> pure $ Right natpmp
     _ -> do
-      free natpmp
+      liftIO $ free natpmp
       pure $ Left $ intToEnum ret
 
-closeNatPmp :: NatPmpHandle -> IO (Either Error ())
+closeNatPmp :: (MonadIO m)
+            => NatPmpHandle -> m (Either Error ())
 closeNatPmp handle = do
-  ret <- _close_nat_pmp handle
-  free handle
+  ret <- liftIO $ _close_nat_pmp handle
+  liftIO $ free handle
   case ret of
     0 -> pure $ Right ()
     _ -> pure $ Left $ intToEnum ret
 
 
 -- Public interface for getting the public IPv4 address
-getPublicAddress :: NatPmpHandle -> IO (Either Error HostAddress)
+getPublicAddress :: (MonadIO m)
+                 => NatPmpHandle -> m (Either Error HostAddress)
 getPublicAddress natpmp = do
-  sendRetcode <- sendPublicAddressRequest natpmp
+  sendRetcode <- liftIO $ sendPublicAddressRequest natpmp
   case sendRetcode of
-    2 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
+    2 -> liftIO $ alloca $ \(pResponse :: NatPmpResponseHandle) -> do
       respRetcode <- readNatResponseSynchronously natpmp pResponse
       case respRetcode of
         0 -> peek pResponse >>= \case
@@ -244,17 +249,18 @@ getPublicAddress natpmp = do
     _ -> pure $ Left $ intToEnum sendRetcode
 
 
-setPortMapping :: NatPmpHandle -> ProtocolType -> Word16 -> Word16 -> Word32
-               -> IO (Either Error ())
+setPortMapping :: (MonadIO m)
+               => NatPmpHandle -> ProtocolType -> Word16 -> Word16 -> Word32
+               -> m (Either Error ())
 setPortMapping natpmp protocol privatePort publicPort lifetime = do
   let protocolNum = fromEnum protocol
   sendResp <-
-    sendNewPortMappingRequest natpmp
+    liftIO $ sendNewPortMappingRequest natpmp
     (fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort)
     (CUInt lifetime)
 
   case sendResp of
-    12 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
+    12 -> liftIO $ alloca $ \(pResponse :: NatPmpResponseHandle) -> do
       respRetcode <- readNatResponseSynchronously natpmp pResponse
       case respRetcode of
         0 -> peek pResponse >>= \case
diff --git a/pkg/hs/natpmp-static/natpmp-static.cabal b/pkg/hs/natpmp-static/natpmp-static.cabal
index 2f8dfaadbc..5c0baf5072 100644
--- a/pkg/hs/natpmp-static/natpmp-static.cabal
+++ b/pkg/hs/natpmp-static/natpmp-static.cabal
@@ -32,6 +32,7 @@ library
   default-language: Haskell2010
   build-depends:       base
                      , network
+                     , unliftio-core
   build-tools: hsc2hs
 
   Include-dirs: cbits
diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs
index dcec5f3c7e..046bdb138b 100644
--- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs
+++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs
@@ -84,7 +84,7 @@ portThread :: forall e. (HasLogFunc e)
            -> (Text -> RIO e ())
            -> RIO e ()
 portThread q stderr = do
-  pmp <- io $ initNatPmp
+  pmp <- initNatPmp
   --pmp <- pure $ Left ErrNoGatewaySupport
   case pmp of
     Left err -> do
@@ -105,7 +105,7 @@ portThread q stderr = do
   where
     foundRouter :: NatPmpHandle -> RIO e ()
     foundRouter pmp = do
-      pubAddr <- io $ getPublicAddress pmp
+      pubAddr <- getPublicAddress pmp
       case pubAddr of
         Left _ -> pure ()
         Right addr -> do
@@ -142,7 +142,7 @@ portThread q stderr = do
       PTMInitialRequestOpen p notifyComplete -> do
         logInfo $
           displayShow ("port: sending initial request to NAT-PMP for port ", p)
-        ret <- io $ setPortMapping pmp PTUDP p p portLeaseLifetime
+        ret <- setPortMapping pmp PTUDP p p portLeaseLifetime
         case ret of
           Left err -> do
             logError $
@@ -163,7 +163,7 @@ portThread q stderr = do
         logInfo $
           displayShow ("port: sending renewing request to NAT-PMP for port ",
                        p)
-        ret <- io $ setPortMapping pmp PTUDP p p portLeaseLifetime
+        ret <- setPortMapping pmp PTUDP p p portLeaseLifetime
         case ret of
           Left err -> do
             logError $
@@ -180,7 +180,7 @@ portThread q stderr = do
       PTMRequestClose p -> do
         logInfo $
           displayShow ("port: releasing lease for ", p)
-        io $ setPortMapping pmp PTUDP p p 0
+        setPortMapping pmp PTUDP p p 0
         let removed = filterPort p nextRenew
         loop pmp removed