natpmp: use MonadIO in the bindings to remove unsightly "io $"

This commit is contained in:
Elliot Glaysher 2020-08-10 13:15:03 -04:00
parent 4d8c6ad09a
commit 2e66ae10ec
3 changed files with 26 additions and 19 deletions

View File

@ -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

View File

@ -32,6 +32,7 @@ library
default-language: Haskell2010
build-depends: base
, network
, unliftio-core
build-tools: hsc2hs
Include-dirs: cbits

View File

@ -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