UPNP port requests (requires miniupnpc).

1 files changed, 39 insertions, 0 deletions

diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs
new file mode 100644
index 00000000..fff1ba5b
--- /dev/null
+++ b/src/Network/UPNP.hs
@@ -0,0 +1,39 @@
+module Network.UPNP where
+
+import Data.Maybe
+import Network.Address (sockAddrPort)
+import Network.Socket
+import System.Directory
+import System.IO
+import System.Process  as Process
+
+protocols :: SocketType -> [String]
+protocols Stream   = ["tcp"]
+protocols Datagram = ["udp"]
+protocols _        = ["udp","tcp"]
+
+upnpc :: FilePath
+upnpc = "/usr/bin/upnpc"
+
+-- | Invokes the miniupnpc command line program to request ports from a UPNP
+-- wifi router.  Returns the process handle on success.
+requestPorts :: String -- ^ Description stored on router, currently ignored.
+                -> [(SocketType, SockAddr)] -- ^ Protocol-port pairs to request.
+                -> IO (Maybe ProcessHandle)
+requestPorts description binds = do
+    let requests = do
+            (stype,saddr) <- binds
+            proto <- protocols stype
+            port <- maybeToList (sockAddrPort saddr)
+            [ show port, proto ]
+        bail = return Nothing
+    case requests of
+        [] -> bail
+        _  -> do
+            gotMiniUPNPC <- doesFileExist upnpc
+            if gotMiniUPNPC then do
+                phandle <- spawnProcess upnpc $ "-r" : requests
+                return $ Just phandle
+            else do
+                hPutStrLn stderr $ "Warning: unable to find miniupnpc client at "++upnpc++"."
+                bail