mirror of
https://github.com/ilyakooo0/urbit.git
synced 2025-01-01 19:46:36 +03:00
natpmp: use MonadIO in the bindings to remove unsightly "io $"
This commit is contained in:
parent
4d8c6ad09a
commit
2e66ae10ec
@ -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
|
||||
|
@ -32,6 +32,7 @@ library
|
||||
default-language: Haskell2010
|
||||
build-depends: base
|
||||
, network
|
||||
, unliftio-core
|
||||
build-tools: hsc2hs
|
||||
|
||||
Include-dirs: cbits
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user