urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-22 18:31:44 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #3261 from urbit/king-natpmp

Browse Source 
King should open ames ports via NAT-PMP
This commit is contained in:
Elliot Glaysher 2020-08-17 14:12:48 -04:00 committed by GitHub
commit 5ee32841d2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
22 changed files with 2161 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkg/hs/natpmp-static/LICENSE Normal file
View File

@ -0,0 +1,26 @@
Copyright (c) 2007-2011, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

5
pkg/hs/natpmp-static/README.txt Normal file
View File

@ -0,0 +1,5 @@
This is a vendored copy of libnatpmp-20150609, along with haskell bindings to
the library. Only the C code which was needed for these bindings was copied out
of the distribution.
Original code: http://miniupnp.free.fr/libnatpmp.html

2
pkg/hs/natpmp-static/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

77
pkg/hs/natpmp-static/cbits/binding.c Normal file
View File

@ -0,0 +1,77 @@
/* $Id: natpmpc.c,v 1.13 2012/08/21 17:23:38 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2011, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include "natpmp.h"
// Additional binding code in C to make this more convenient to call from
// Haskell. libnatpmp expects that code which uses it to select() on an
// internal socket, which we don't want to expose to the Haskell bindings user.
//
// This is mostly an adaptation of the code in the demo natpmpc.c to use the
// select() loop.
int readNatResponseSynchronously(natpmp_t* natpmp, natpmpresp_t * response)
{
fd_set fds;
struct timeval timeout;
int r;
int sav_errno;
do {
FD_ZERO(&fds);
FD_SET(natpmp->s, &fds);
getnatpmprequesttimeout(natpmp, &timeout);
r = select(FD_SETSIZE, &fds, NULL, NULL, &timeout);
sav_errno = errno;
if(r<0) {
fprintf(stderr, "select(): errno=%d '%s'\n",
sav_errno, strerror(sav_errno));
return 1;
}
r = readnatpmpresponseorretry(natpmp, response);
sav_errno = errno;
/* printf("readnatpmpresponseorretry returned %d (%s)\n", */
/* r, r==0?"OK":(r==NATPMP_TRYAGAIN?"TRY AGAIN":"FAILED")); */
if(r<0 && r!=NATPMP_TRYAGAIN) {
#ifdef ENABLE_STRNATPMPERR
fprintf(stderr, "readnatpmpresponseorretry() failed : %s\n",
strnatpmperr(r));
#endif
fprintf(stderr, " errno=%d '%s'\n",
sav_errno, strerror(sav_errno));
}
} while(r==NATPMP_TRYAGAIN);
return r;
}

8
pkg/hs/natpmp-static/cbits/binding.h Normal file
View File

@ -0,0 +1,8 @@
#ifndef __NATPMP_BINDING_H__
#define __NATPMP_BINDING_H__
#include "natpmp.h"
int readNatResponseSynchronously(natpmp_t* natpmp, natpmpresp_t * response);
#endif

573
pkg/hs/natpmp-static/cbits/getgateway.c Normal file
View File

@ -0,0 +1,573 @@
/* $Id: getgateway.c,v 1.25 2014/04/22 10:28:57 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <ctype.h>
#ifndef WIN32
#include <netinet/in.h>
#endif
#if !defined(_MSC_VER)
#include <sys/param.h>
#endif
/* There is no portable method to get the default route gateway.
* So below are four (or five ?) differents functions implementing this.
* Parsing /proc/net/route is for linux.
* sysctl is the way to access such informations on BSD systems.
* Many systems should provide route information through raw PF_ROUTE
* sockets.
* In MS Windows, default gateway is found by looking into the registry
* or by using GetBestRoute(). */
#ifdef __linux__
#define USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#if defined(BSD) || defined(__FreeBSD_kernel__)
#undef USE_PROC_NET_ROUTE
#define USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#ifdef __APPLE__
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#define USE_SYSCTL_NET_ROUTE
#endif
#if (defined(sun) && defined(__SVR4))
#undef USE_PROC_NET_ROUTE
#define USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#endif
#ifdef WIN32
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
//#define USE_WIN32_CODE
#define USE_WIN32_CODE_2
#endif
#ifdef __CYGWIN__
#undef USE_PROC_NET_ROUTE
#undef USE_SOCKET_ROUTE
#undef USE_SYSCTL_NET_ROUTE
#define USE_WIN32_CODE
#include <stdarg.h>
#include <w32api/windef.h>
#include <w32api/winbase.h>
#include <w32api/winreg.h>
#endif
#ifdef __HAIKU__
#include <stdlib.h>
#include <unistd.h>
#include <net/if.h>
#include <sys/sockio.h>
#define USE_HAIKU_CODE
#endif
#ifdef USE_SYSCTL_NET_ROUTE
#include <stdlib.h>
#include <sys/sysctl.h>
#include <sys/socket.h>
#include <net/route.h>
#endif
#ifdef USE_SOCKET_ROUTE
#include <unistd.h>
#include <string.h>
#include <sys/socket.h>
#include <net/if.h>
#include <net/route.h>
#endif
#ifdef USE_WIN32_CODE
#include <unknwn.h>
#include <winreg.h>
#define MAX_KEY_LENGTH 255
#define MAX_VALUE_LENGTH 16383
#endif
#ifdef USE_WIN32_CODE_2
#include <windows.h>
#include <iphlpapi.h>
#endif
#include "getgateway.h"
#ifndef WIN32
#define SUCCESS (0)
#define FAILED (-1)
#endif
#ifdef USE_PROC_NET_ROUTE
/*
parse /proc/net/route which is as follow :
Iface Destination Gateway Flags RefCnt Use Metric Mask MTU Window IRTT
wlan0 0001A8C0 00000000 0001 0 0 0 00FFFFFF 0 0 0
eth0 0000FEA9 00000000 0001 0 0 0 0000FFFF 0 0 0
wlan0 00000000 0101A8C0 0003 0 0 0 00000000 0 0 0
eth0 00000000 00000000 0001 0 0 1000 00000000 0 0 0
One header line, and then one line by route by route table entry.
*/
int getdefaultgateway(in_addr_t * addr)
{
unsigned long d, g;
char buf[256];
int line = 0;
FILE * f;
char * p;
f = fopen("/proc/net/route", "r");
if(!f)
return FAILED;
while(fgets(buf, sizeof(buf), f)) {
if(line > 0) { /* skip the first line */
p = buf;
/* skip the interface name */
while(*p && !isspace(*p))
p++;
while(*p && isspace(*p))
p++;
if(sscanf(p, "%lx%lx", &d, &g)==2) {
if(d == 0 && g != 0) { /* default */
*addr = g;
fclose(f);
return SUCCESS;
}
}
}
line++;
}
/* default route not found ! */
if(f)
fclose(f);
return FAILED;
}
#endif /* #ifdef USE_PROC_NET_ROUTE */
#ifdef USE_SYSCTL_NET_ROUTE
#define ROUNDUP(a) \
((a) > 0 ? (1 + (((a) - 1) | (sizeof(long) - 1))) : sizeof(long))
int getdefaultgateway(in_addr_t * addr)
{
#if 0
/* net.route.0.inet.dump.0.0 ? */
int mib[] = {CTL_NET, PF_ROUTE, 0, AF_INET,
NET_RT_DUMP, 0, 0/*tableid*/};
#endif
/* net.route.0.inet.flags.gateway */
int mib[] = {CTL_NET, PF_ROUTE, 0, AF_INET,
NET_RT_FLAGS, RTF_GATEWAY};
size_t l;
char * buf, * p;
struct rt_msghdr * rt;
struct sockaddr * sa;
struct sockaddr * sa_tab[RTAX_MAX];
int i;
int r = FAILED;
if(sysctl(mib, sizeof(mib)/sizeof(int), 0, &l, 0, 0) < 0) {
return FAILED;
}
if(l>0) {
buf = malloc(l);
if(sysctl(mib, sizeof(mib)/sizeof(int), buf, &l, 0, 0) < 0) {
free(buf);
return FAILED;
}
for(p=buf; p<buf+l; p+=rt->rtm_msglen) {
rt = (struct rt_msghdr *)p;
sa = (struct sockaddr *)(rt + 1);
for(i=0; i<RTAX_MAX; i++) {
if(rt->rtm_addrs & (1 << i)) {
sa_tab[i] = sa;
sa = (struct sockaddr *)((char *)sa + ROUNDUP(sa->sa_len));
} else {
sa_tab[i] = NULL;
}
}
if( ((rt->rtm_addrs & (RTA_DST|RTA_GATEWAY)) == (RTA_DST|RTA_GATEWAY))
&& sa_tab[RTAX_DST]->sa_family == AF_INET
&& sa_tab[RTAX_GATEWAY]->sa_family == AF_INET) {
if(((struct sockaddr_in *)sa_tab[RTAX_DST])->sin_addr.s_addr == 0) {
*addr = ((struct sockaddr_in *)(sa_tab[RTAX_GATEWAY]))->sin_addr.s_addr;
r = SUCCESS;
}
}
}
free(buf);
}
return r;
}
#endif /* #ifdef USE_SYSCTL_NET_ROUTE */
#ifdef USE_SOCKET_ROUTE
/* Thanks to Darren Kenny for this code */
#define NEXTADDR(w, u) \
if (rtm_addrs & (w)) {\
l = sizeof(struct sockaddr); memmove(cp, &(u), l); cp += l;\
}
#define rtm m_rtmsg.m_rtm
struct {
struct rt_msghdr m_rtm;
char m_space[512];
} m_rtmsg;
int getdefaultgateway(in_addr_t *addr)
{
int s, seq, l, rtm_addrs, i;
pid_t pid;
struct sockaddr so_dst, so_mask;
char *cp = m_rtmsg.m_space;
struct sockaddr *gate = NULL, *sa;
struct rt_msghdr *msg_hdr;
pid = getpid();
seq = 0;
rtm_addrs = RTA_DST | RTA_NETMASK;
memset(&so_dst, 0, sizeof(so_dst));
memset(&so_mask, 0, sizeof(so_mask));
memset(&rtm, 0, sizeof(struct rt_msghdr));
rtm.rtm_type = RTM_GET;
rtm.rtm_flags = RTF_UP | RTF_GATEWAY;
rtm.rtm_version = RTM_VERSION;
rtm.rtm_seq = ++seq;
rtm.rtm_addrs = rtm_addrs;
so_dst.sa_family = AF_INET;
so_mask.sa_family = AF_INET;
NEXTADDR(RTA_DST, so_dst);
NEXTADDR(RTA_NETMASK, so_mask);
rtm.rtm_msglen = l = cp - (char *)&m_rtmsg;
s = socket(PF_ROUTE, SOCK_RAW, 0);
if (write(s, (char *)&m_rtmsg, l) < 0) {
close(s);
return FAILED;
}
do {
l = read(s, (char *)&m_rtmsg, sizeof(m_rtmsg));
} while (l > 0 && (rtm.rtm_seq != seq || rtm.rtm_pid != pid));
close(s);
msg_hdr = &rtm;
cp = ((char *)(msg_hdr + 1));
if (msg_hdr->rtm_addrs) {
for (i = 1; i; i <<= 1)
if (i & msg_hdr->rtm_addrs) {
sa = (struct sockaddr *)cp;
if (i == RTA_GATEWAY )
gate = sa;
cp += sizeof(struct sockaddr);
}
} else {
return FAILED;
}
if (gate != NULL ) {
*addr = ((struct sockaddr_in *)gate)->sin_addr.s_addr;
return SUCCESS;
} else {
return FAILED;
}
}
#endif /* #ifdef USE_SOCKET_ROUTE */
#ifdef USE_WIN32_CODE
LIBSPEC int getdefaultgateway(in_addr_t * addr)
{
HKEY networkCardsKey;
HKEY networkCardKey;
HKEY interfacesKey;
HKEY interfaceKey;
DWORD i = 0;
DWORD numSubKeys = 0;
TCHAR keyName[MAX_KEY_LENGTH];
DWORD keyNameLength = MAX_KEY_LENGTH;
TCHAR keyValue[MAX_VALUE_LENGTH];
DWORD keyValueLength = MAX_VALUE_LENGTH;
DWORD keyValueType = REG_SZ;
TCHAR gatewayValue[MAX_VALUE_LENGTH];
DWORD gatewayValueLength = MAX_VALUE_LENGTH;
DWORD gatewayValueType = REG_MULTI_SZ;
int done = 0;
//const char * networkCardsPath = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
//const char * interfacesPath = "SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#ifdef UNICODE
LPCTSTR networkCardsPath = L"SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
LPCTSTR interfacesPath = L"SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#define STR_SERVICENAME L"ServiceName"
#define STR_DHCPDEFAULTGATEWAY L"DhcpDefaultGateway"
#define STR_DEFAULTGATEWAY L"DefaultGateway"
#else
LPCTSTR networkCardsPath = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\NetworkCards";
LPCTSTR interfacesPath = "SYSTEM\\CurrentControlSet\\Services\\Tcpip\\Parameters\\Interfaces";
#define STR_SERVICENAME "ServiceName"
#define STR_DHCPDEFAULTGATEWAY "DhcpDefaultGateway"
#define STR_DEFAULTGATEWAY "DefaultGateway"
#endif
// The windows registry lists its primary network devices in the following location:
// HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards
//
// Each network device has its own subfolder, named with an index, with various properties:
// -NetworkCards
// -5
// -Description = Broadcom 802.11n Network Adapter
// -ServiceName = {E35A72F8-5065-4097-8DFE-C7790774EE4D}
// -8
// -Description = Marvell Yukon 88E8058 PCI-E Gigabit Ethernet Controller
// -ServiceName = {86226414-5545-4335-A9D1-5BD7120119AD}
//
// The above service name is the name of a subfolder within:
// HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces
//
// There may be more subfolders in this interfaces path than listed in the network cards path above:
// -Interfaces
// -{3a539854-6a70-11db-887c-806e6f6e6963}
// -DhcpIPAddress = 0.0.0.0
// -[more]
// -{E35A72F8-5065-4097-8DFE-C7790774EE4D}
// -DhcpIPAddress = 10.0.1.4
// -DhcpDefaultGateway = 10.0.1.1
// -[more]
// -{86226414-5545-4335-A9D1-5BD7120119AD}
// -DhcpIpAddress = 10.0.1.5
// -DhcpDefaultGateay = 10.0.1.1
// -[more]
//
// In order to extract this information, we enumerate each network card, and extract the ServiceName value.
// This is then used to open the interface subfolder, and attempt to extract a DhcpDefaultGateway value.
// Once one is found, we're done.
//
// It may be possible to simply enumerate the interface folders until we find one with a DhcpDefaultGateway value.
// However, the technique used is the technique most cited on the web, and we assume it to be more correct.
if(ERROR_SUCCESS != RegOpenKeyEx(HKEY_LOCAL_MACHINE, // Open registry key or predifined key
networkCardsPath, // Name of registry subkey to open
0, // Reserved - must be zero
KEY_READ, // Mask - desired access rights
&networkCardsKey)) // Pointer to output key
{
// Unable to open network cards keys
return -1;
}
if(ERROR_SUCCESS != RegOpenKeyEx(HKEY_LOCAL_MACHINE, // Open registry key or predefined key
interfacesPath, // Name of registry subkey to open
0, // Reserved - must be zero
KEY_READ, // Mask - desired access rights
&interfacesKey)) // Pointer to output key
{
// Unable to open interfaces key
RegCloseKey(networkCardsKey);
return -1;
}
// Figure out how many subfolders are within the NetworkCards folder
RegQueryInfoKey(networkCardsKey, NULL, NULL, NULL, &numSubKeys, NULL, NULL, NULL, NULL, NULL, NULL, NULL);
//printf( "Number of subkeys: %u\n", (unsigned int)numSubKeys);
// Enumrate through each subfolder within the NetworkCards folder
for(i = 0; i < numSubKeys && !done; i++)
{
keyNameLength = MAX_KEY_LENGTH;
if(ERROR_SUCCESS == RegEnumKeyEx(networkCardsKey, // Open registry key
i, // Index of subkey to retrieve
keyName, // Buffer that receives the name of the subkey
&keyNameLength, // Variable that receives the size of the above buffer
NULL, // Reserved - must be NULL
NULL, // Buffer that receives the class string
NULL, // Variable that receives the size of the above buffer
NULL)) // Variable that receives the last write time of subkey
{
if(RegOpenKeyEx(networkCardsKey, keyName, 0, KEY_READ, &networkCardKey) == ERROR_SUCCESS)
{
keyValueLength = MAX_VALUE_LENGTH;
if(ERROR_SUCCESS == RegQueryValueEx(networkCardKey, // Open registry key
STR_SERVICENAME, // Name of key to query
NULL, // Reserved - must be NULL
&keyValueType, // Receives value type
(LPBYTE)keyValue, // Receives value
&keyValueLength)) // Receives value length in bytes
{
// printf("keyValue: %s\n", keyValue);
if(RegOpenKeyEx(interfacesKey, keyValue, 0, KEY_READ, &interfaceKey) == ERROR_SUCCESS)
{
gatewayValueLength = MAX_VALUE_LENGTH;
if(ERROR_SUCCESS == RegQueryValueEx(interfaceKey, // Open registry key
STR_DHCPDEFAULTGATEWAY, // Name of key to query
NULL, // Reserved - must be NULL
&gatewayValueType, // Receives value type
(LPBYTE)gatewayValue, // Receives value
&gatewayValueLength)) // Receives value length in bytes
{
// Check to make sure it's a string
if((gatewayValueType == REG_MULTI_SZ || gatewayValueType == REG_SZ) && (gatewayValueLength > 1))
{
//printf("gatewayValue: %s\n", gatewayValue);
done = 1;
}
}
else if(ERROR_SUCCESS == RegQueryValueEx(interfaceKey, // Open registry key
STR_DEFAULTGATEWAY, // Name of key to query
NULL, // Reserved - must be NULL
&gatewayValueType, // Receives value type
(LPBYTE)gatewayValue,// Receives value
&gatewayValueLength)) // Receives value length in bytes
{
// Check to make sure it's a string
if((gatewayValueType == REG_MULTI_SZ || gatewayValueType == REG_SZ) && (gatewayValueLength > 1))
{
//printf("gatewayValue: %s\n", gatewayValue);
done = 1;
}
}
RegCloseKey(interfaceKey);
}
}
RegCloseKey(networkCardKey);
}
}
}
RegCloseKey(interfacesKey);
RegCloseKey(networkCardsKey);
if(done)
{
#if UNICODE
char tmp[32];
for(i = 0; i < 32; i++) {
tmp[i] = (char)gatewayValue[i];
if(!tmp[i])
break;
}
tmp[31] = '\0';
*addr = inet_addr(tmp);
#else
*addr = inet_addr(gatewayValue);
#endif
return 0;
}
return -1;
}
#endif /* #ifdef USE_WIN32_CODE */
#ifdef USE_WIN32_CODE_2
int getdefaultgateway(in_addr_t *addr)
{
MIB_IPFORWARDROW ip_forward;
memset(&ip_forward, 0, sizeof(ip_forward));
if(GetBestRoute(inet_addr("0.0.0.0"), 0, &ip_forward) != NO_ERROR)
return -1;
*addr = ip_forward.dwForwardNextHop;
return 0;
}
#endif /* #ifdef USE_WIN32_CODE_2 */
#ifdef USE_HAIKU_CODE
int getdefaultgateway(in_addr_t *addr)
{
int fd, ret = -1;
struct ifconf config;
void *buffer = NULL;
struct ifreq *interface;
if ((fd = socket(AF_INET, SOCK_DGRAM, 0)) < 0) {
return -1;
}
if (ioctl(fd, SIOCGRTSIZE, &config, sizeof(config)) != 0) {
goto fail;
}
if (config.ifc_value < 1) {
goto fail; /* No routes */
}
if ((buffer = malloc(config.ifc_value)) == NULL) {
goto fail;
}
config.ifc_len = config.ifc_value;
config.ifc_buf = buffer;
if (ioctl(fd, SIOCGRTTABLE, &config, sizeof(config)) != 0) {
goto fail;
}
for (interface = buffer;
(uint8_t *)interface < (uint8_t *)buffer + config.ifc_len; ) {
struct route_entry route = interface->ifr_route;
int intfSize;
if (route.flags & (RTF_GATEWAY | RTF_DEFAULT)) {
*addr = ((struct sockaddr_in *)route.gateway)->sin_addr.s_addr;
ret = 0;
break;
}
intfSize = sizeof(route) + IF_NAMESIZE;
if (route.destination != NULL) {
intfSize += route.destination->sa_len;
}
if (route.mask != NULL) {
intfSize += route.mask->sa_len;
}
if (route.gateway != NULL) {
intfSize += route.gateway->sa_len;
}
interface = (struct ifreq *)((uint8_t *)interface + intfSize);
}
fail:
free(buffer);
close(fd);
return ret;
}
#endif /* #ifdef USE_HAIKU_CODE */
#if !defined(USE_PROC_NET_ROUTE) && !defined(USE_SOCKET_ROUTE) && !defined(USE_SYSCTL_NET_ROUTE) && !defined(USE_WIN32_CODE) && !defined(USE_WIN32_CODE_2) && !defined(USE_HAIKU_CODE)
int getdefaultgateway(in_addr_t * addr)
{
return -1;
}
#endif

49
pkg/hs/natpmp-static/cbits/getgateway.h Normal file
View File

@ -0,0 +1,49 @@
/* $Id: getgateway.h,v 1.8 2014/04/22 09:15:40 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifndef __GETGATEWAY_H__
#define __GETGATEWAY_H__
#ifdef WIN32
#if !defined(_MSC_VER) || _MSC_VER >= 1600
#include <stdint.h>
#else
typedef unsigned long uint32_t;
typedef unsigned short uint16_t;
#endif
#define in_addr_t uint32_t
#endif
/* #include "declspec.h" */
/* getdefaultgateway() :
* return value :
* 0 : success
* -1 : failure */
/* LIBSPEC */int getdefaultgateway(in_addr_t * addr);
#endif

379
pkg/hs/natpmp-static/cbits/natpmp.c Normal file
View File

@ -0,0 +1,379 @@
/* $Id: natpmp.c,v 1.20 2015/05/27 12:43:15 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2015, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifdef __linux__
#define _BSD_SOURCE 1
#endif
#include <string.h>
#include <time.h>
#if !defined(_MSC_VER)
#include <sys/time.h>
#endif
#ifdef WIN32
#include <errno.h>
#include <winsock2.h>
#include <ws2tcpip.h>
#include <io.h>
#define EWOULDBLOCK WSAEWOULDBLOCK
#define ECONNREFUSED WSAECONNREFUSED
#include "wingettimeofday.h"
#define gettimeofday natpmp_gettimeofday
#else
#include <errno.h>
#include <unistd.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/socket.h>
#define closesocket close
#endif
#include "natpmp.h"
#include "getgateway.h"
#include <stdio.h>
LIBSPEC int initnatpmp(natpmp_t * p, int forcegw, in_addr_t forcedgw)
{
#ifdef WIN32
u_long ioctlArg = 1;
#else
int flags;
#endif
struct sockaddr_in addr;
if(!p)
return NATPMP_ERR_INVALIDARGS;
memset(p, 0, sizeof(natpmp_t));
p->s = socket(PF_INET, SOCK_DGRAM, 0);
if(p->s < 0)
return NATPMP_ERR_SOCKETERROR;
#ifdef WIN32
if(ioctlsocket(p->s, FIONBIO, &ioctlArg) == SOCKET_ERROR)
return NATPMP_ERR_FCNTLERROR;
#else
if((flags = fcntl(p->s, F_GETFL, 0)) < 0)
return NATPMP_ERR_FCNTLERROR;
if(fcntl(p->s, F_SETFL, flags | O_NONBLOCK) < 0)
return NATPMP_ERR_FCNTLERROR;
#endif
if(forcegw) {
p->gateway = forcedgw;
} else {
if(getdefaultgateway(&(p->gateway)) < 0)
return NATPMP_ERR_CANNOTGETGATEWAY;
}
memset(&addr, 0, sizeof(addr));
addr.sin_family = AF_INET;
addr.sin_port = htons(NATPMP_PORT);
addr.sin_addr.s_addr = p->gateway;
if(connect(p->s, (struct sockaddr *)&addr, sizeof(addr)) < 0)
return NATPMP_ERR_CONNECTERR;
return 0;
}
LIBSPEC int closenatpmp(natpmp_t * p)
{
if(!p)
return NATPMP_ERR_INVALIDARGS;
if(closesocket(p->s) < 0)
return NATPMP_ERR_CLOSEERR;
return 0;
}
int sendpendingrequest(natpmp_t * p)
{
int r;
/* struct sockaddr_in addr;*/
if(!p)
return NATPMP_ERR_INVALIDARGS;
/* memset(&addr, 0, sizeof(addr));
addr.sin_family = AF_INET;
addr.sin_port = htons(NATPMP_PORT);
addr.sin_addr.s_addr = p->gateway;
r = (int)sendto(p->s, p->pending_request, p->pending_request_len, 0,
(struct sockaddr *)&addr, sizeof(addr));*/
r = (int)send(p->s, (const char *)p->pending_request, p->pending_request_len, 0);
return (r<0) ? NATPMP_ERR_SENDERR : r;
}
int sendnatpmprequest(natpmp_t * p)
{
int n;
if(!p)
return NATPMP_ERR_INVALIDARGS;
/* TODO : check if no request is already pending */
p->has_pending_request = 1;
p->try_number = 1;
n = sendpendingrequest(p);
gettimeofday(&p->retry_time, NULL); // check errors !
p->retry_time.tv_usec += 250000; /* add 250ms */
if(p->retry_time.tv_usec >= 1000000) {
p->retry_time.tv_usec -= 1000000;
p->retry_time.tv_sec++;
}
return n;
}
LIBSPEC int getnatpmprequesttimeout(natpmp_t * p, struct timeval * timeout)
{
struct timeval now;
if(!p || !timeout)
return NATPMP_ERR_INVALIDARGS;
if(!p->has_pending_request)
return NATPMP_ERR_NOPENDINGREQ;
if(gettimeofday(&now, NULL) < 0)
return NATPMP_ERR_GETTIMEOFDAYERR;
timeout->tv_sec = p->retry_time.tv_sec - now.tv_sec;
timeout->tv_usec = p->retry_time.tv_usec - now.tv_usec;
if(timeout->tv_usec < 0) {
timeout->tv_usec += 1000000;
timeout->tv_sec--;
}
return 0;
}
LIBSPEC int sendpublicaddressrequest(natpmp_t * p)
{
if(!p)
return NATPMP_ERR_INVALIDARGS;
//static const unsigned char request[] = { 0, 0 };
p->pending_request[0] = 0;
p->pending_request[1] = 0;
p->pending_request_len = 2;
// TODO: return 0 instead of sizeof(request) ??
return sendnatpmprequest(p);
}
LIBSPEC int sendnewportmappingrequest(natpmp_t * p, int protocol,
uint16_t privateport, uint16_t publicport,
uint32_t lifetime)
{
if(!p || (protocol!=NATPMP_PROTOCOL_TCP && protocol!=NATPMP_PROTOCOL_UDP))
return NATPMP_ERR_INVALIDARGS;
p->pending_request[0] = 0;
p->pending_request[1] = protocol;
p->pending_request[2] = 0;
p->pending_request[3] = 0;
/* break strict-aliasing rules :
*((uint16_t *)(p->pending_request + 4)) = htons(privateport); */
p->pending_request[4] = (privateport >> 8) & 0xff;
p->pending_request[5] = privateport & 0xff;
/* break stric-aliasing rules :
*((uint16_t *)(p->pending_request + 6)) = htons(publicport); */
p->pending_request[6] = (publicport >> 8) & 0xff;
p->pending_request[7] = publicport & 0xff;
/* break stric-aliasing rules :
*((uint32_t *)(p->pending_request + 8)) = htonl(lifetime); */
p->pending_request[8] = (lifetime >> 24) & 0xff;
p->pending_request[9] = (lifetime >> 16) & 0xff;
p->pending_request[10] = (lifetime >> 8) & 0xff;
p->pending_request[11] = lifetime & 0xff;
p->pending_request_len = 12;
return sendnatpmprequest(p);
}
LIBSPEC int readnatpmpresponse(natpmp_t * p, natpmpresp_t * response)
{
unsigned char buf[16];
struct sockaddr_in addr;
socklen_t addrlen = sizeof(addr);
int n;
if(!p)
return NATPMP_ERR_INVALIDARGS;
n = recvfrom(p->s, (char *)buf, sizeof(buf), 0,
(struct sockaddr *)&addr, &addrlen);
if(n<0)
#ifdef WIN32
switch(WSAGetLastError()) {
#else
switch(errno) {
#endif
/*case EAGAIN:*/
case EWOULDBLOCK:
n = NATPMP_TRYAGAIN;
break;
case ECONNREFUSED:
n = NATPMP_ERR_NOGATEWAYSUPPORT;
break;
default:
n = NATPMP_ERR_RECVFROM;
}
/* check that addr is correct (= gateway) */
else if(addr.sin_addr.s_addr != p->gateway)
n = NATPMP_ERR_WRONGPACKETSOURCE;
else {
response->resultcode = ntohs(*((uint16_t *)(buf + 2)));
response->epoch = ntohl(*((uint32_t *)(buf + 4)));
if(buf[0] != 0)
n = NATPMP_ERR_UNSUPPORTEDVERSION;
else if(buf[1] < 128 || buf[1] > 130)
n = NATPMP_ERR_UNSUPPORTEDOPCODE;
else if(response->resultcode != 0) {
switch(response->resultcode) {
case 1:
n = NATPMP_ERR_UNSUPPORTEDVERSION;
break;
case 2:
n = NATPMP_ERR_NOTAUTHORIZED;
break;
case 3:
n = NATPMP_ERR_NETWORKFAILURE;
break;
case 4:
n = NATPMP_ERR_OUTOFRESOURCES;
break;
case 5:
n = NATPMP_ERR_UNSUPPORTEDOPCODE;
break;
default:
n = NATPMP_ERR_UNDEFINEDERROR;
}
} else {
response->type = buf[1] & 0x7f;
if(buf[1] == 128)
//response->publicaddress.addr = *((uint32_t *)(buf + 8));
response->pnu.publicaddress.addr.s_addr = *((uint32_t *)(buf + 8));
else {
response->pnu.newportmapping.privateport = ntohs(*((uint16_t *)(buf + 8)));
response->pnu.newportmapping.mappedpublicport = ntohs(*((uint16_t *)(buf + 10)));
response->pnu.newportmapping.lifetime = ntohl(*((uint32_t *)(buf + 12)));
}
n = 0;
}
}
return n;
}
int readnatpmpresponseorretry(natpmp_t * p, natpmpresp_t * response)
{
int n;
if(!p || !response)
return NATPMP_ERR_INVALIDARGS;
if(!p->has_pending_request)
return NATPMP_ERR_NOPENDINGREQ;
n = readnatpmpresponse(p, response);
if(n<0) {
if(n==NATPMP_TRYAGAIN) {
struct timeval now;
gettimeofday(&now, NULL); // check errors !
if(timercmp(&now, &p->retry_time, >=)) {
int delay, r;
if(p->try_number >= 9) {
return NATPMP_ERR_NOGATEWAYSUPPORT;
}
/*printf("retry! %d\n", p->try_number);*/
delay = 250 * (1<<p->try_number); // ms
/*for(i=0; i<p->try_number; i++)
delay += delay;*/
p->retry_time.tv_sec += (delay / 1000);
p->retry_time.tv_usec += (delay % 1000) * 1000;
if(p->retry_time.tv_usec >= 1000000) {
p->retry_time.tv_usec -= 1000000;
p->retry_time.tv_sec++;
}
p->try_number++;
r = sendpendingrequest(p);
if(r<0)
return r;
}
}
} else {
p->has_pending_request = 0;
}
return n;
}
#ifdef ENABLE_STRNATPMPERR
LIBSPEC const char * strnatpmperr(int r)
{
const char * s;
switch(r) {
case NATPMP_ERR_INVALIDARGS:
s = "invalid arguments";
break;
case NATPMP_ERR_SOCKETERROR:
s = "socket() failed";
break;
case NATPMP_ERR_CANNOTGETGATEWAY:
s = "cannot get default gateway ip address";
break;
case NATPMP_ERR_CLOSEERR:
#ifdef WIN32
s = "closesocket() failed";
#else
s = "close() failed";
#endif
break;
case NATPMP_ERR_RECVFROM:
s = "recvfrom() failed";
break;
case NATPMP_ERR_NOPENDINGREQ:
s = "no pending request";
break;
case NATPMP_ERR_NOGATEWAYSUPPORT:
s = "the gateway does not support nat-pmp";
break;
case NATPMP_ERR_CONNECTERR:
s = "connect() failed";
break;
case NATPMP_ERR_WRONGPACKETSOURCE:
s = "packet not received from the default gateway";
break;
case NATPMP_ERR_SENDERR:
s = "send() failed";
break;
case NATPMP_ERR_FCNTLERROR:
s = "fcntl() failed";
break;
case NATPMP_ERR_GETTIMEOFDAYERR:
s = "gettimeofday() failed";
break;
case NATPMP_ERR_UNSUPPORTEDVERSION:
s = "unsupported nat-pmp version error from server";
break;
case NATPMP_ERR_UNSUPPORTEDOPCODE:
s = "unsupported nat-pmp opcode error from server";
break;
case NATPMP_ERR_UNDEFINEDERROR:
s = "undefined nat-pmp server error";
break;
case NATPMP_ERR_NOTAUTHORIZED:
s = "not authorized";
break;
case NATPMP_ERR_NETWORKFAILURE:
s = "network failure";
break;
case NATPMP_ERR_OUTOFRESOURCES:
s = "nat-pmp server out of resources";
break;
default:
s = "Unknown libnatpmp error";
}
return s;
}
#endif

221
pkg/hs/natpmp-static/cbits/natpmp.h Normal file
View File

@ -0,0 +1,221 @@
/* $Id: natpmp.h,v 1.20 2014/04/22 09:15:40 nanard Exp $ */
/* libnatpmp
Copyright (c) 2007-2014, Thomas BERNARD
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#ifndef __NATPMP_H__
#define __NATPMP_H__
/* NAT-PMP Port as defined by the NAT-PMP draft */
#define NATPMP_PORT (5351)
#define ENABLE_STRNATPMPERR
#include <time.h>
#if !defined(_MSC_VER)
#include <sys/time.h>
#endif /* !defined(_MSC_VER) */
#ifdef WIN32
#include <winsock2.h>
#if !defined(_MSC_VER) || _MSC_VER >= 1600
#include <stdint.h>
#else /* !defined(_MSC_VER) || _MSC_VER >= 1600 */
typedef unsigned long uint32_t;
typedef unsigned short uint16_t;
#endif /* !defined(_MSC_VER) || _MSC_VER >= 1600 */
#define in_addr_t uint32_t
#include "declspec.h"
#else /* WIN32 */
#define LIBSPEC
#include <netinet/in.h>
#endif /* WIN32 */
/* causes problem when installing. Maybe should it be inlined ? */
/* #include "declspec.h" */
typedef struct {
int s; /* socket */
in_addr_t gateway; /* default gateway (IPv4) */
int has_pending_request;
unsigned char pending_request[12];
int pending_request_len;
int try_number;
struct timeval retry_time;
} natpmp_t;
typedef struct {
uint16_t type; /* NATPMP_RESPTYPE_* */
uint16_t resultcode; /* NAT-PMP response code */
uint32_t epoch; /* Seconds since start of epoch */
union {
struct {
//in_addr_t addr;
struct in_addr addr;
} publicaddress;
struct {
uint16_t privateport;
uint16_t mappedpublicport;
uint32_t lifetime;
} newportmapping;
} pnu;
} natpmpresp_t;
/* possible values for type field of natpmpresp_t */
#define NATPMP_RESPTYPE_PUBLICADDRESS (0)
#define NATPMP_RESPTYPE_UDPPORTMAPPING (1)
#define NATPMP_RESPTYPE_TCPPORTMAPPING (2)
/* Values to pass to sendnewportmappingrequest() */
#define NATPMP_PROTOCOL_UDP (1)
#define NATPMP_PROTOCOL_TCP (2)
/* return values */
/* NATPMP_ERR_INVALIDARGS : invalid arguments passed to the function */
#define NATPMP_ERR_INVALIDARGS (-1)
/* NATPMP_ERR_SOCKETERROR : socket() failed. check errno for details */
#define NATPMP_ERR_SOCKETERROR (-2)
/* NATPMP_ERR_CANNOTGETGATEWAY : can't get default gateway IP */
#define NATPMP_ERR_CANNOTGETGATEWAY (-3)
/* NATPMP_ERR_CLOSEERR : close() failed. check errno for details */
#define NATPMP_ERR_CLOSEERR (-4)
/* NATPMP_ERR_RECVFROM : recvfrom() failed. check errno for details */
#define NATPMP_ERR_RECVFROM (-5)
/* NATPMP_ERR_NOPENDINGREQ : readnatpmpresponseorretry() called while
* no NAT-PMP request was pending */
#define NATPMP_ERR_NOPENDINGREQ (-6)
/* NATPMP_ERR_NOGATEWAYSUPPORT : the gateway does not support NAT-PMP */
#define NATPMP_ERR_NOGATEWAYSUPPORT (-7)
/* NATPMP_ERR_CONNECTERR : connect() failed. check errno for details */
#define NATPMP_ERR_CONNECTERR (-8)
/* NATPMP_ERR_WRONGPACKETSOURCE : packet not received from the network gateway */
#define NATPMP_ERR_WRONGPACKETSOURCE (-9)
/* NATPMP_ERR_SENDERR : send() failed. check errno for details */
#define NATPMP_ERR_SENDERR (-10)
/* NATPMP_ERR_FCNTLERROR : fcntl() failed. check errno for details */
#define NATPMP_ERR_FCNTLERROR (-11)
/* NATPMP_ERR_GETTIMEOFDAYERR : gettimeofday() failed. check errno for details */
#define NATPMP_ERR_GETTIMEOFDAYERR (-12)
/* */
#define NATPMP_ERR_UNSUPPORTEDVERSION (-14)
#define NATPMP_ERR_UNSUPPORTEDOPCODE (-15)
/* Errors from the server : */
#define NATPMP_ERR_UNDEFINEDERROR (-49)
#define NATPMP_ERR_NOTAUTHORIZED (-51)
#define NATPMP_ERR_NETWORKFAILURE (-52)
#define NATPMP_ERR_OUTOFRESOURCES (-53)
/* NATPMP_TRYAGAIN : no data available for the moment. try again later */
#define NATPMP_TRYAGAIN (-100)
#ifdef __cplusplus
extern "C" {
#endif
/* initnatpmp()
* initialize a natpmp_t object
* With forcegw=1 the gateway is not detected automaticaly.
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SOCKETERROR
* NATPMP_ERR_FCNTLERROR
* NATPMP_ERR_CANNOTGETGATEWAY
* NATPMP_ERR_CONNECTERR */
LIBSPEC int initnatpmp(natpmp_t * p, int forcegw, in_addr_t forcedgw);
/* closenatpmp()
* close resources associated with a natpmp_t object
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_CLOSEERR */
LIBSPEC int closenatpmp(natpmp_t * p);
/* sendpublicaddressrequest()
* send a public address NAT-PMP request to the network gateway
* Return values :
* 2 = OK (size of the request)
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SENDERR */
LIBSPEC int sendpublicaddressrequest(natpmp_t * p);
/* sendnewportmappingrequest()
* send a new port mapping NAT-PMP request to the network gateway
* Arguments :
* protocol is either NATPMP_PROTOCOL_TCP or NATPMP_PROTOCOL_UDP,
* lifetime is in seconds.
* To remove a port mapping, set lifetime to zero.
* To remove all port mappings to the host, set lifetime and both ports
* to zero.
* Return values :
* 12 = OK (size of the request)
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_SENDERR */
LIBSPEC int sendnewportmappingrequest(natpmp_t * p, int protocol,
uint16_t privateport, uint16_t publicport,
uint32_t lifetime);
/* getnatpmprequesttimeout()
* fills the timeval structure with the timeout duration of the
* currently pending NAT-PMP request.
* Return values :
* 0 = OK
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_GETTIMEOFDAYERR
* NATPMP_ERR_NOPENDINGREQ */
LIBSPEC int getnatpmprequesttimeout(natpmp_t * p, struct timeval * timeout);
/* readnatpmpresponseorretry()
* fills the natpmpresp_t structure if possible
* Return values :
* 0 = OK
* NATPMP_TRYAGAIN
* NATPMP_ERR_INVALIDARGS
* NATPMP_ERR_NOPENDINGREQ
* NATPMP_ERR_NOGATEWAYSUPPORT
* NATPMP_ERR_RECVFROM
* NATPMP_ERR_WRONGPACKETSOURCE
* NATPMP_ERR_UNSUPPORTEDVERSION
* NATPMP_ERR_UNSUPPORTEDOPCODE
* NATPMP_ERR_NOTAUTHORIZED
* NATPMP_ERR_NETWORKFAILURE
* NATPMP_ERR_OUTOFRESOURCES
* NATPMP_ERR_UNSUPPORTEDOPCODE
* NATPMP_ERR_UNDEFINEDERROR */
LIBSPEC int readnatpmpresponseorretry(natpmp_t * p, natpmpresp_t * response);
#ifdef ENABLE_STRNATPMPERR
LIBSPEC const char * strnatpmperr(int t);
#endif
#ifdef __cplusplus
}
#endif
#endif

266
pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc Normal file
View File

@ -0,0 +1,266 @@
{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
-- | This module is a thin wrapper above libnatpmp.h and getgateway.h.
module Network.NatPmp (Error(..),
NatPmpResponse(..),
ProtocolType(..),
NatPmpHandle,
Port,
LifetimeSeconds,
initNatPmp,
closeNatPmp,
getDefaultGateway,
getPublicAddress,
setPortMapping) where
#include <netinet/in.h>
#include <getgateway.h>
#include <natpmp.h>
#include <binding.h>
import Prelude
import Foreign
import Foreign.C
import Network.Socket
import Control.Monad.IO.Unlift (MonadIO(..))
-- Opaque type for the internals of nat pmp
data NatPmpStruct
type NatPmpHandle = Ptr NatPmpStruct
type Port = Word16
type LifetimeSeconds = Word32
-- The response type, in its internal form. This struct is a C tagged union
-- with additional data, but we need to read and write from its C form.
data NatPmpResponse
= NatPmpResponsePublicAddress HostAddress
| NatPmpResponseUdpPortMapping Port Port LifetimeSeconds
| NatPmpResponseTcpPortMapping Port Port LifetimeSeconds
deriving (Show)
instance Storable NatPmpResponse where
sizeOf _ = #{size natpmpresp_t}
alignment _ = alignment (undefined :: CString)
peek p = do
t <- uintToEnum <$> (#{peek natpmpresp_t, type} p)
case t of
RTPublicAddress ->
NatPmpResponsePublicAddress <$>
(#{peek natpmpresp_t, pnu.publicaddress.addr} p)
RTUdpPortMapping ->
NatPmpResponseUdpPortMapping
<$> (#{peek natpmpresp_t, pnu.newportmapping.privateport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.mappedpublicport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.lifetime} p)
RTTcpPortMapping ->
NatPmpResponseTcpPortMapping
<$> (#{peek natpmpresp_t, pnu.newportmapping.privateport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.mappedpublicport} p)
<*> (#{peek natpmpresp_t, pnu.newportmapping.lifetime} p)
poke _ _ = error "Responses are an output data structure; poke makes no sense"
type NatPmpResponseHandle = Ptr NatPmpResponse
foreign import ccall unsafe "getgateway.h getdefaultgateway" _get_default_gateway :: Ptr CUInt -> IO CInt
foreign import ccall unsafe "natpmp.h initnatpmp" _init_nat_pmp :: NatPmpHandle -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "natpmp.h closenatpmp" _close_nat_pmp :: NatPmpHandle -> IO CInt
foreign import ccall unsafe "natpmp.h sendpublicaddressrequest" sendPublicAddressRequest :: NatPmpHandle -> IO CInt
foreign import ccall unsafe "natpmp.h sendnewportmappingrequest" sendNewPortMappingRequest :: NatPmpHandle -> CInt -> CUShort -> CUShort -> CUInt -> IO CInt
foreign import ccall unsafe "binding.h readNatResponseSynchronously" readNatResponseSynchronously :: NatPmpHandle -> NatPmpResponseHandle -> IO CInt
-- Give the type system some help
_peekCUInt :: Ptr CUInt -> IO CUInt
_peekCUInt = peek
uintToEnum :: Enum e => CUInt -> e
uintToEnum = toEnum . fromIntegral
intToEnum :: Enum e => CInt -> e
intToEnum = toEnum . fromIntegral
-- Fetches the default gateway as an ipv4 address
getDefaultGateway :: IO (Maybe HostAddress)
getDefaultGateway =
alloca $ \(pReturnAddr :: Ptr CUInt) -> do
_get_default_gateway pReturnAddr >>= \case
0 -> (Just . fromIntegral) <$> _peekCUInt pReturnAddr
_ -> pure Nothing
data RespType
= RTPublicAddress
| RTUdpPortMapping
| RTTcpPortMapping
deriving (Eq, Show)
instance Enum RespType where
fromEnum RTPublicAddress = 0
fromEnum RTUdpPortMapping = 1
fromEnum RTTcpPortMapping = 2
toEnum 0 = RTPublicAddress
toEnum 1 = RTUdpPortMapping
toEnum 2 = RTTcpPortMapping
toEnum unmatched = error ("RespType.toEnum: Cannot match " ++ show unmatched)
data ProtocolType
= PTUdp
| PTTcp
deriving (Eq, Show)
instance Enum ProtocolType where
fromEnum PTUdp = 1
fromEnum PTTcp = 2
toEnum 1 = PTUdp
toEnum 2 = PTTcp
toEnum x = error ("ProtocolType.toEnum: Cannot match " ++ show x)
data Error
= ErrInvalidArgs
| ErrSocketError
| ErrCannotGetGateway
| ErrCloseErr
| ErrRecvFrom
| ErrNoPendingReq
| ErrNoGatewaySupport
| ErrConnectErr
| ErrWrongPacketSource
| ErrSendErr
| ErrFcntlError
| ErrGetTimeOfDayError
--
| ErrUnsuportedVersion
| ErrUnsupportedOpcode
--
| ErrUndefinedError
| ErrNotAuthorized
| ErrNetworkFailure
| ErrOutOfResources
--
| ErrTryAgain
| ErrHaskellBindings
deriving (Eq, Show)
instance Enum Error where
fromEnum ErrInvalidArgs = -1
fromEnum ErrSocketError = -2
fromEnum ErrCannotGetGateway = -3
fromEnum ErrCloseErr = -4
fromEnum ErrRecvFrom = -5
fromEnum ErrNoPendingReq = -6
fromEnum ErrNoGatewaySupport = -7
fromEnum ErrConnectErr = -8
fromEnum ErrWrongPacketSource = -9
fromEnum ErrSendErr = -10
fromEnum ErrFcntlError = -11
fromEnum ErrGetTimeOfDayError = -12
--
fromEnum ErrUnsuportedVersion = -14
fromEnum ErrUnsupportedOpcode = -15
--
fromEnum ErrUndefinedError = -49
fromEnum ErrNotAuthorized = -51
fromEnum ErrNetworkFailure = -52
fromEnum ErrOutOfResources = -53
--
fromEnum ErrTryAgain = -100
fromEnum ErrHaskellBindings = -200
toEnum (-1) = ErrInvalidArgs
toEnum (-2) = ErrSocketError
toEnum (-3) = ErrCannotGetGateway
toEnum (-4) = ErrCloseErr
toEnum (-5) = ErrRecvFrom
toEnum (-6) = ErrNoPendingReq
toEnum (-7) = ErrNoGatewaySupport
toEnum (-8) = ErrConnectErr
toEnum (-9) = ErrWrongPacketSource
toEnum (-10) = ErrSendErr
toEnum (-11) = ErrFcntlError
toEnum (-12) = ErrGetTimeOfDayError
--
toEnum (-14) = ErrUnsuportedVersion
toEnum (-15) = ErrUnsupportedOpcode
--
toEnum (-49) = ErrUndefinedError
toEnum (-51) = ErrNotAuthorized
toEnum (-52) = ErrNetworkFailure
toEnum (-53) = ErrOutOfResources
--
toEnum (-100) = ErrTryAgain
toEnum (-200) = ErrHaskellBindings
toEnum unmatched = error ("Error.toEnum: Cannot match " ++ show unmatched)
initNatPmp :: MonadIO m => m (Either Error NatPmpHandle)
initNatPmp = liftIO do
natpmp <- mallocBytes #{size natpmp_t}
ret <- _init_nat_pmp natpmp 0 0
case ret of
0 -> pure $ Right natpmp
_ -> do
free natpmp
pure $ Left $ intToEnum ret
closeNatPmp :: MonadIO m => NatPmpHandle -> m (Either Error ())
closeNatPmp handle = liftIO do
ret <- _close_nat_pmp handle
free handle
case ret of
0 -> pure $ Right ()
_ -> pure $ Left $ intToEnum ret
-- | Public interface for getting the public IPv4 address
getPublicAddress :: MonadIO m => NatPmpHandle -> m (Either Error HostAddress)
getPublicAddress natpmp = liftIO do
sendRetcode <- sendPublicAddressRequest natpmp
case sendRetcode of
2 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
respRetcode <- readNatResponseSynchronously natpmp pResponse
case respRetcode of
0 -> peek pResponse >>= \case
NatPmpResponsePublicAddress addr -> pure $ Right addr
_ -> pure $ Left ErrHaskellBindings
_ -> pure $ Left $ intToEnum respRetcode
_ -> pure $ Left $ intToEnum sendRetcode
-- | Requests that the router maps the privatePort on our local computer in our
-- private network to publicPort on the public internet.
setPortMapping :: MonadIO m
=> NatPmpHandle
-> ProtocolType
-> Port
-> Port
-> LifetimeSeconds
-> m (Either Error ())
setPortMapping natpmp protocol privatePort publicPort lifetime = liftIO do
let protocolNum = fromEnum protocol
sendResp <-
sendNewPortMappingRequest natpmp
(fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort)
(CUInt lifetime)
case sendResp of
12 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
respRetcode <- readNatResponseSynchronously natpmp pResponse
case respRetcode of
0 -> peek pResponse >>= \case
NatPmpResponseUdpPortMapping _ _ _ -> pure $ Right ()
NatPmpResponseTcpPortMapping _ _ _ -> pure $ Right ()
_ -> pure $ Left ErrHaskellBindings
_ -> pure $ Left $ intToEnum respRetcode
x -> pure $ Left $ intToEnum x

89
pkg/hs/natpmp-static/natpmp-static.cabal Normal file
View File

@ -0,0 +1,89 @@
cabal-version: >=1.10
-- Initial package description 'natpmp-static.cabal' generated by 'cabal
-- init'. For further documentation, see
-- http://haskell.org/cabal/users-guide/
name: natpmp-static
version: 0.1.0.0
synopsis: Haskell bindings to libnatpmp
description:
libnatpmp is a C library to communicate with routers and request
that they port forward traffic from the outside internet to your
program.
.
natpmp-static has Haskell bindings to libnatpmp to allow Haskell
programs to punch NAT holes in routers, containing a vendored copy
of the libnatpmp code so that we build Urbit's "almost static"
builds which we distribute.
.
See <http://miniupnp.free.fr/libnatpmp.html> for upstream source.
-- bug-reports:
license: BSD3
license-file: LICENSE
author: Elliot Glaysher
maintainer: elliot@tlon.io
copyright: (c) 2020 Tlon.
stability: experimental
build-type: Simple
library
hs-Source-Dirs: hsrc_lib
default-language: Haskell2010
build-depends: base
, network
, unliftio-core
build-tools: hsc2hs
Include-dirs: cbits
Includes: natpmp.h getgateway.h
C-Sources: cbits/natpmp.c cbits/getgateway.c cbits/binding.c
cc-options: -Wall -Os -g -fPIC
ghc-options: -Wall -fprof-auto -fPIC
exposed-modules: Network.NatPmp
-- other-modules:
-- other-extensions:
default-extensions: ApplicativeDo
, BangPatterns
, BlockArguments
, DataKinds
, DefaultSignatures
, DeriveAnyClass
, DeriveDataTypeable
, DeriveFoldable
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, EmptyCase
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, GeneralizedNewtypeDeriving
, LambdaCase
, MagicHash
, MultiParamTypeClasses
, NamedFieldPuns
, NoImplicitPrelude
, NumericUnderscores
, OverloadedStrings
, PartialTypeSignatures
, PatternSynonyms
, QuasiQuotes
, Rank2Types
, RankNTypes
, RecordWildCards
, ScopedTypeVariables
, StandaloneDeriving
, TemplateHaskell
, TupleSections
, TypeApplications
, TypeFamilies
, TypeOperators
, UnboxedTuples
, UnicodeSyntax
, ViewPatterns

1
pkg/hs/stack.yaml
View File

@ -2,6 +2,7 @@ resolver: lts-14.21
packages: packages:
- lmdb-static - lmdb-static
- natpmp-static
- proto - proto
- racquire - racquire
- terminal-progress-bar - terminal-progress-bar

84
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -9,6 +9,8 @@ module Urbit.King.App
, kingEnvKillSignal , kingEnvKillSignal
, killKingActionL , killKingActionL
, onKillKingSigL , onKillKingSigL
, HostEnv
, runHostEnv
, PierEnv , PierEnv
, runPierEnv , runPierEnv
, killPierActionL , killPierActionL
@ -17,6 +19,8 @@ module Urbit.King.App
, HasKingId(..) , HasKingId(..)
, HasProcId(..) , HasProcId(..)
, HasKingEnv(..) , HasKingEnv(..)
, HasMultiEyreApi(..)
, HasHostEnv(..)
, HasPierEnv(..) , HasPierEnv(..)
, module Urbit.King.Config , module Urbit.King.Config
) )
@ -30,7 +34,8 @@ import System.Posix.Internals (c_getpid)
import System.Posix.Types (CPid(..)) import System.Posix.Types (CPid(..))
import System.Random (randomIO) import System.Random (randomIO)
import Urbit.King.App.Class (HasStderrLogFunc(..)) import Urbit.King.App.Class (HasStderrLogFunc(..))
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
import Urbit.Vere.Ports (PortControlApi, HasPortControlApi(..))
-- KingEnv --------------------------------------------------------------------- -- KingEnv ---------------------------------------------------------------------
@ -70,7 +75,6 @@ instance HasProcId KingEnv where
instance HasKingId KingEnv where instance HasKingId KingEnv where
kingIdL = kingEnvKingId kingIdL = kingEnvKingId
-- Running KingEnvs ------------------------------------------------------------ -- Running KingEnvs ------------------------------------------------------------
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
@ -121,14 +125,69 @@ killKingActionL :: HasKingEnv e => Getter e (STM ())
killKingActionL = killKingActionL =
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ())) kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
-- HostEnv ------------------------------------------------------------------
-- The host environment is everything in King, eyre configuration shared
-- across ships, and nat punching data.
class HasMultiEyreApi a where
multiEyreApiL :: Lens' a MultiEyreApi
class (HasKingEnv a, HasMultiEyreApi a, HasPortControlApi a) =>
HasHostEnv a where
hostEnvL :: Lens' a HostEnv
data HostEnv = HostEnv
{ _hostEnvKingEnv :: !KingEnv
, _hostEnvMultiEyreApi :: !MultiEyreApi
, _hostEnvPortControlApi :: !PortControlApi
}
makeLenses ''HostEnv
instance HasKingEnv HostEnv where
kingEnvL = hostEnvKingEnv
instance HasLogFunc HostEnv where
logFuncL = kingEnvL . logFuncL
instance HasStderrLogFunc HostEnv where
stderrLogFuncL = kingEnvL . stderrLogFuncL
instance HasProcId HostEnv where
procIdL = kingEnvL . procIdL
instance HasKingId HostEnv where
kingIdL = kingEnvL . kingEnvKingId
instance HasMultiEyreApi HostEnv where
multiEyreApiL = hostEnvMultiEyreApi
instance HasPortControlApi HostEnv where
portControlApiL = hostEnvPortControlApi
-- Running Running Envs --------------------------------------------------------
runHostEnv :: MultiEyreApi -> PortControlApi -> RIO HostEnv a
-> RIO KingEnv a
runHostEnv multi ports action = do
king <- ask
let hostEnv = HostEnv { _hostEnvKingEnv = king
, _hostEnvMultiEyreApi = multi
, _hostEnvPortControlApi = ports
}
io (runRIO hostEnv action)
-- PierEnv --------------------------------------------------------------------- -- PierEnv ---------------------------------------------------------------------
class (HasKingEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where class (HasKingEnv a, HasHostEnv a, HasPierConfig a, HasNetworkConfig a) =>
HasPierEnv a where
pierEnvL :: Lens' a PierEnv pierEnvL :: Lens' a PierEnv
data PierEnv = PierEnv data PierEnv = PierEnv
{ _pierEnvKingEnv :: !KingEnv { _pierEnvHostEnv :: !HostEnv
, _pierEnvPierConfig :: !PierConfig , _pierEnvPierConfig :: !PierConfig
, _pierEnvNetworkConfig :: !NetworkConfig , _pierEnvNetworkConfig :: !NetworkConfig
, _pierEnvKillSignal :: !(TMVar ()) , _pierEnvKillSignal :: !(TMVar ())
@ -137,7 +196,16 @@ data PierEnv = PierEnv
makeLenses ''PierEnv makeLenses ''PierEnv
instance HasKingEnv PierEnv where instance HasKingEnv PierEnv where
kingEnvL = pierEnvKingEnv kingEnvL = pierEnvHostEnv . kingEnvL
instance HasHostEnv PierEnv where
hostEnvL = pierEnvHostEnv
instance HasMultiEyreApi PierEnv where
multiEyreApiL = pierEnvHostEnv . multiEyreApiL
instance HasPortControlApi PierEnv where
portControlApiL = pierEnvHostEnv . portControlApiL
instance HasPierEnv PierEnv where instance HasPierEnv PierEnv where
pierEnvL = id pierEnvL = id
@ -180,11 +248,11 @@ killPierActionL =
-- Running Pier Envs ----------------------------------------------------------- -- Running Pier Envs -----------------------------------------------------------
runPierEnv runPierEnv
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a :: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO HostEnv a
runPierEnv pierConfig networkConfig vKill action = do runPierEnv pierConfig networkConfig vKill action = do
app <- ask host <- ask
let pierEnv = PierEnv { _pierEnvKingEnv = app let pierEnv = PierEnv { _pierEnvHostEnv = host
, _pierEnvPierConfig = pierConfig , _pierEnvPierConfig = pierConfig
, _pierEnvNetworkConfig = networkConfig , _pierEnvNetworkConfig = networkConfig
, _pierEnvKillSignal = vKill , _pierEnvKillSignal = vKill

8
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs
View File

@ -18,6 +18,7 @@ import System.Environment (getProgName)
data KingOpts = KingOpts data KingOpts = KingOpts
{ koSharedHttpPort :: Maybe Word16 { koSharedHttpPort :: Maybe Word16
, koSharedHttpsPort :: Maybe Word16 , koSharedHttpsPort :: Maybe Word16
, koUseNatPmp :: Bool
} }
deriving (Show) deriving (Show)
@ -195,6 +196,11 @@ pillFromURL = PillSourceURL <$> strOption
<> value defaultPillURL <> value defaultPillURL
<> help "URL to pill file") <> help "URL to pill file")
enableNat :: Parser Bool
enableNat = not <$> switch
( long "no-port-forwarding"
<> help "Disable trying to ask the router to forward ames ports")
pierPath :: Parser FilePath pierPath :: Parser FilePath
pierPath = strArgument (metavar "PIER" <> help "Path to pier") pierPath = strArgument (metavar "PIER" <> help "Path to pier")
@ -347,6 +353,8 @@ runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df
kingOpts :: Parser KingOpts kingOpts :: Parser KingOpts
kingOpts = do kingOpts = do
koUseNatPmp <- enableNat
koSharedHttpPort <- koSharedHttpPort <-
optional optional
$ option auto $ option auto

121
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -82,7 +82,8 @@ import Urbit.Arvo
import Urbit.King.Config import Urbit.King.Config
import Urbit.Vere.Dawn import Urbit.Vere.Dawn
import Urbit.Vere.Pier import Urbit.Vere.Pier
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..)) import Urbit.Vere.Ports
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreConf(..))
import Urbit.Vere.Pier.Types import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf import Urbit.Vere.Serf
import Urbit.King.App import Urbit.King.App
@ -91,6 +92,7 @@ import Control.Concurrent (myThreadId)
import Control.Exception (AsyncException(UserInterrupt)) import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&)) import Control.Lens ((&))
import System.Process (system) import System.Process (system)
import System.IO (hPutStrLn)
import Text.Show.Pretty (pPrint) import Text.Show.Pretty (pPrint)
import Urbit.Noun.Conversions (cordToUW) import Urbit.Noun.Conversions (cordToUW)
import Urbit.Noun.Time (Wen) import Urbit.Noun.Time (Wen)
@ -184,12 +186,11 @@ tryBootFromPill
-> Bool -> Bool
-> Ship -> Ship
-> LegacyBootEvent -> LegacyBootEvent
-> MultiEyreApi
-> RIO PierEnv () -> RIO PierEnv ()
tryBootFromPill oExit pill lite ship boot multi = do tryBootFromPill oExit pill lite ship boot = do
mStart <- newEmptyMVar mStart <- newEmptyMVar
vSlog <- logSlogs vSlog <- logSlogs
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart
where where
bootedPier vSlog = do bootedPier vSlog = do
view pierPathL >>= lockFile view pierPathL >>= lockFile
@ -203,9 +204,8 @@ runOrExitImmediately
-> RAcquire PierEnv (Serf, Log.EventLog) -> RAcquire PierEnv (Serf, Log.EventLog)
-> Bool -> Bool
-> MVar () -> MVar ()
-> MultiEyreApi
-> RIO PierEnv () -> RIO PierEnv ()
runOrExitImmediately vSlog getPier oExit mStart multi = do runOrExitImmediately vSlog getPier oExit mStart = do
rwith getPier (if oExit then shutdownImmediately else runPier) rwith getPier (if oExit then shutdownImmediately else runPier)
where where
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv () shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
@ -216,19 +216,18 @@ runOrExitImmediately vSlog getPier oExit mStart multi = do
runPier :: (Serf, Log.EventLog) -> RIO PierEnv () runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
runPier serfLog = do runPier serfLog = do
runRAcquire (Pier.pier serfLog vSlog mStart multi) runRAcquire (Pier.pier serfLog vSlog mStart)
tryPlayShip tryPlayShip
:: Bool :: Bool
-> Bool -> Bool
-> Maybe Word64 -> Maybe Word64
-> MVar () -> MVar ()
-> MultiEyreApi
-> RIO PierEnv () -> RIO PierEnv ()
tryPlayShip exitImmediately fullReplay playFrom mStart multi = do tryPlayShip exitImmediately fullReplay playFrom mStart = do
when fullReplay wipeSnapshot when fullReplay wipeSnapshot
vSlog <- logSlogs vSlog <- logSlogs
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart
where where
wipeSnapshot = do wipeSnapshot = do
shipPath <- view pierPathL shipPath <- view pierPathL
@ -444,7 +443,7 @@ validateNounVal inpVal = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO KingEnv Pill pillFrom :: CLI.PillSource -> RIO HostEnv Pill
pillFrom = \case pillFrom = \case
CLI.PillSourceFile pillPath -> do CLI.PillSourceFile pillPath -> do
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text) logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
@ -475,7 +474,12 @@ newShip CLI.New{..} opts = do
-} -}
multi <- multiEyre (MultiEyreConf Nothing Nothing True) multi <- multiEyre (MultiEyreConf Nothing Nothing True)
case nBootType of -- TODO: We hit the same problem as above: we need a host env to boot a ship
-- because it may autostart the ship, so build an inactive port configuration.
let ports = buildInactivePorts
-- here we are with a king env, and we now need a multi env.
runHostEnv multi ports $ case nBootType of
CLI.BootComet -> do CLI.BootComet -> do
pill <- pillFrom nPillSource pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets" putStrLn "boot: retrieving list of stars currently accepting comets"
@ -486,12 +490,12 @@ newShip CLI.New{..} opts = do
eny <- io $ Sys.randomIO eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed)) putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed multi pill seed bootFromSeed pill seed
CLI.BootFake name -> do CLI.BootFake name -> do
pill <- pillFrom nPillSource pill <- pillFrom nPillSource
ship <- shipFrom name ship <- shipFrom name
runTryBootFromPill multi pill name ship (Fake ship) runTryBootFromPill pill name ship (Fake ship)
CLI.BootFromKeyfile keyFile -> do CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile text <- readFileUtf8 keyFile
@ -506,10 +510,10 @@ newShip CLI.New{..} opts = do
pill <- pillFrom nPillSource pill <- pillFrom nPillSource
bootFromSeed multi pill seed bootFromSeed pill seed
where where
shipFrom :: Text -> RIO KingEnv Ship shipFrom :: Text -> RIO HostEnv Ship
shipFrom name = case Ob.parsePatp name of shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name" Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
@ -519,7 +523,7 @@ newShip CLI.New{..} opts = do
Just x -> x Just x -> x
Nothing -> "./" <> unpack name Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO KingEnv Text nameFromShip :: HasKingEnv e => Ship -> RIO e Text
nameFromShip s = name nameFromShip s = name
where where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@ -527,8 +531,8 @@ newShip CLI.New{..} opts = do
Nothing -> error "Urbit.ob didn't produce string with ~" Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x Just x -> pure x
bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO KingEnv () bootFromSeed :: Pill -> Seed -> RIO HostEnv ()
bootFromSeed multi pill seed = do bootFromSeed pill seed = do
ethReturn <- dawnVent seed ethReturn <- dawnVent seed
case ethReturn of case ethReturn of
@ -536,19 +540,23 @@ newShip CLI.New{..} opts = do
Right dawn -> do Right dawn -> do
let ship = sShip $ dSeed dawn let ship = sShip $ dSeed dawn
name <- nameFromShip ship name <- nameFromShip ship
runTryBootFromPill multi pill name ship (Dawn dawn) runTryBootFromPill pill name ship (Dawn dawn)
-- Now that we have all the information for running an application with a -- Now that we have all the information for running an application with a
-- PierConfig, do so. -- PierConfig, do so.
runTryBootFromPill multi pill name ship bootEvent = do runTryBootFromPill :: Pill
vKill <- view kingEnvKillSignal -> Text
-> Ship
-> LegacyBootEvent
-> RIO HostEnv ()
runTryBootFromPill pill name ship bootEvent = do
vKill <- view (kingEnvL . kingEnvKillSignal)
let pierConfig = toPierConfig (pierPath name) opts let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts let networkConfig = toNetworkConfig opts
runPierEnv pierConfig networkConfig vKill $ runPierEnv pierConfig networkConfig vKill $
tryBootFromPill True pill nLite ship bootEvent multi tryBootFromPill True pill nLite ship bootEvent
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO HostEnv a
runShipEnv (CLI.Run pierPath) opts vKill act = do runShipEnv (CLI.Run pierPath) opts vKill act = do
runPierEnv pierConfig netConfig vKill act runPierEnv pierConfig netConfig vKill act
where where
@ -556,8 +564,8 @@ runShipEnv (CLI.Run pierPath) opts vKill act = do
netConfig = toNetworkConfig opts netConfig = toNetworkConfig opts
runShip runShip
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv () :: CLI.Run -> CLI.Opts -> Bool -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon multi = do runShip (CLI.Run pierPath) opts daemon = do
mStart <- newEmptyMVar mStart <- newEmptyMVar
if daemon if daemon
then runPier mStart then runPier mStart
@ -580,9 +588,15 @@ runShip (CLI.Run pierPath) opts daemon multi = do
(CLI.oFullReplay opts) (CLI.oFullReplay opts)
(CLI.oDryFrom opts) (CLI.oDryFrom opts)
mStart mStart
multi
buildPortHandler :: HasLogFunc e => Bool -> RIO e PortControlApi
buildPortHandler False = pure buildInactivePorts
-- TODO: Figure out what to do about logging here. The "port: " messages are
-- the sort of thing that should be put on the muxed terminal log, but we don't
-- have that at this layer.
buildPortHandler True = buildNatPorts (io . hPutStrLn stderr . unpack)
startBrowser :: HasLogFunc e => FilePath -> RIO e () startBrowser :: HasLogFunc e => FilePath -> RIO e ()
startBrowser pierPath = runRAcquire $ do startBrowser pierPath = runRAcquire $ do
-- lockFile pierPath -- lockFile pierPath
@ -674,15 +688,15 @@ main = do
TODO Use logging system instead of printing. TODO Use logging system instead of printing.
-} -}
runShipRestarting runShipRestarting
:: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv () :: CLI.Run -> CLI.Opts -> RIO HostEnv ()
runShipRestarting r o multi = do runShipRestarting r o = do
let pier = pack (CLI.rPierPath r) let pier = pack (CLI.rPierPath r)
loop = runShipRestarting r o multi loop = runShipRestarting r o
onKill <- view onKillKingSigL onKill <- view onKillKingSigL
vKillPier <- newEmptyTMVarIO vKillPier <- newEmptyTMVarIO
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True
let onShipExit = Left <$> waitCatchSTM tid let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill onKillRequ = Right <$> onKill
@ -707,10 +721,11 @@ runShipRestarting r o multi = do
TODO This is messy and shared a lot of logic with `runShipRestarting`. TODO This is messy and shared a lot of logic with `runShipRestarting`.
-} -}
runShipNoRestart runShipNoRestart
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv () :: CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv ()
runShipNoRestart r o d multi = do runShipNoRestart r o d = do
vKill <- view kingEnvKillSignal -- killing ship same as killing king -- killing ship same as killing king
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d multi) vKill <- view (kingEnvL . kingEnvKillSignal)
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d)
onKill <- view onKillKingSigL onKill <- view onKillKingSigL
let pier = pack (CLI.rPierPath r) let pier = pack (CLI.rPierPath r)
@ -740,31 +755,23 @@ runShips CLI.KingOpts {..} ships = do
-- a king-wide option. -- a king-wide option.
} }
{-
TODO Need to rework RIO environment to fix this. Should have a
bunch of nested contexts:
- King has started. King has Id. Logging available.
- In running environment. MultiEyre and global config available.
- In pier environment: pier path and config available.
- In running ship environment: serf state, event queue available.
-}
multi <- multiEyre meConf multi <- multiEyre meConf
go multi ships ports <- buildPortHandler koUseNatPmp
runHostEnv multi ports (go ships)
where where
go :: MultiEyreApi -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv () go :: [(CLI.Run, CLI.Opts, Bool)] -> RIO HostEnv ()
go me = \case go = \case
[] -> pure () [] -> pure ()
[rod] -> runSingleShip rod me [rod] -> runSingleShip rod
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o))
-- TODO Duplicated logic. -- TODO Duplicated logic.
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> MultiEyreApi -> RIO KingEnv () runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> RIO HostEnv ()
runSingleShip (r, o, d) multi = do runSingleShip (r, o, d) = do
shipThread <- async (runShipNoRestart r o d multi) shipThread <- async (runShipNoRestart r o d)
{- {-
Wait for the ship to go down. Wait for the ship to go down.
@ -784,10 +791,10 @@ runSingleShip (r, o, d) multi = do
pure () pure ()
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv () runMultipleShips :: [(CLI.Run, CLI.Opts)] -> RIO HostEnv ()
runMultipleShips ships multi = do runMultipleShips ships = do
shipThreads <- for ships $ \(r, o) -> do shipThreads <- for ships $ \(r, o) -> do
async (runShipRestarting r o multi) async (runShipRestarting r o)
{- {-
Since `spin` never returns, this will run until the main Since `spin` never returns, this will run until the main

8
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs
View File

@ -10,6 +10,7 @@ import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake) import Urbit.Arvo hiding (Fake)
import Urbit.King.Config import Urbit.King.Config
import Urbit.Vere.Pier.Types import Urbit.Vere.Pier.Types
import Urbit.Vere.Ports
import Urbit.King.App (HasKingId(..), HasPierEnv(..)) import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..)) import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
@ -105,7 +106,10 @@ udpPort isFake who = do
mPort <- view (networkConfigL . ncAmesPort) mPort <- view (networkConfigL . ncAmesPort)
pure $ maybe (listenPort mode who) fromIntegral mPort pure $ maybe (listenPort mode who) fromIntegral mPort
udpServ :: (HasLogFunc e, HasNetworkConfig e) => Bool -> Ship -> RIO e UdpServ udpServ :: (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e)
=> Bool
-> Ship
-> RIO e UdpServ
udpServ isFake who = do udpServ isFake who = do
mode <- netMode isFake mode <- netMode isFake
port <- udpPort isFake who port <- udpPort isFake who
@ -170,7 +174,7 @@ ames' who isFake stderr = do
-} -}
ames ames
:: forall e :: forall e
. (HasLogFunc e, HasNetworkConfig e, HasKingId e) . (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e, HasKingId e)
=> e => e
-> Ship -> Ship
-> Bool -> Bool

17
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs
View File

@ -33,6 +33,7 @@ module Urbit.Vere.Ames.UDP
where where
import Urbit.Prelude import Urbit.Prelude
import Urbit.Vere.Ports
import Network.Socket hiding (recvFrom, sendTo) import Network.Socket hiding (recvFrom, sendTo)
@ -151,7 +152,11 @@ fakeUdpServ = do
Real UDP server. See module-level docs. Real UDP server. See module-level docs.
-} -}
realUdpServ realUdpServ
:: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ :: forall e
. (HasLogFunc e, HasPortControlApi e)
=> PortNumber
-> HostAddress
-> RIO e UdpServ
realUdpServ por hos = do realUdpServ por hos = do
logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.") logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
@ -198,11 +203,21 @@ realUdpServ por hos = do
tOpen <- async $ forever $ do tOpen <- async $ forever $ do
sk <- forceBind por hos sk <- forceBind por hos
sn <- io $ getSocketName sk
let waitForRelease = do
atomically (writeTVar vSock (Just sk)) atomically (writeTVar vSock (Just sk))
broken <- atomically (takeTMVar vFail) broken <- atomically (takeTMVar vFail)
logWarn "AMES: UDP: Closing broken socket." logWarn "AMES: UDP: Closing broken socket."
io (close broken) io (close broken)
case sn of
(SockAddrInet boundPort _) ->
-- When we're on IPv4, maybe port forward at the NAT.
rwith (requestPortAccess $ fromIntegral boundPort) $
\() -> waitForRelease
_ -> waitForRelease
tSend <- async $ forever $ join $ atomically $ do tSend <- async $ forever $ join $ atomically $ do
(adr, byt) <- readTBQueue qSend (adr, byt) <- readTBQueue qSend
readTVar vSock <&> \case readTVar vSock <&> \case

27
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs
View File

@ -11,7 +11,7 @@ where
import Urbit.Prelude hiding (Builder) import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure) import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.King.App (HasKingId(..), HasPierEnv(..)) import Urbit.King.App (HasKingId(..), HasMultiEyreApi(..), HasPierEnv(..))
import Urbit.King.Config import Urbit.King.Config
import Urbit.Vere.Eyre.Multi import Urbit.Vere.Eyre.Multi
import Urbit.Vere.Eyre.PortsFile import Urbit.Vere.Eyre.PortsFile
@ -170,17 +170,18 @@ execRespActs (Drv v) who reqId ev = readMVar v >>= \case
atomically (routeRespAct who (sLiveReqs sv) reqId act) atomically (routeRespAct who (sLiveReqs sv) reqId act)
startServ startServ
:: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e) :: (HasPierConfig e, HasLogFunc e, HasMultiEyreApi e, HasNetworkConfig e)
=> MultiEyreApi => Ship
-> Ship
-> Bool -> Bool
-> HttpServerConf -> HttpServerConf
-> (EvErr -> STM ()) -> (EvErr -> STM ())
-> (Text -> RIO e ()) -> (Text -> RIO e ())
-> RIO e Serv -> RIO e Serv
startServ multi who isFake conf plan stderr = do startServ who isFake conf plan stderr = do
logDebug (displayShow ("EYRE", "startServ")) logDebug (displayShow ("EYRE", "startServ"))
multi <- view multiEyreApiL
let vLive = meaLive multi let vLive = meaLive multi
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32) srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
@ -286,18 +287,18 @@ _bornFailed env _ = runRIO env $ do
pure () -- TODO What should this do? pure () -- TODO What should this do?
eyre' eyre'
:: HasPierEnv e :: (HasPierEnv e, HasMultiEyreApi e)
=> MultiEyreApi => Ship
-> Ship
-> Bool -> Bool
-> (Text -> RIO e ()) -> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf)) -> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
eyre' multi who isFake stderr = do
eyre' who isFake stderr = do
ventQ :: TQueue EvErr <- newTQueueIO ventQ :: TQueue EvErr <- newTQueueIO
env <- ask env <- ask
let (bornEvs, startDriver) = let (bornEvs, startDriver) =
eyre env multi who (writeTQueue ventQ) isFake stderr eyre env who (writeTQueue ventQ) isFake stderr
let runDriver = do let runDriver = do
diOnEffect <- startDriver diOnEffect <- startDriver
@ -322,15 +323,15 @@ eyre
:: forall e :: forall e
. (HasPierEnv e) . (HasPierEnv e)
=> e => e
-> MultiEyreApi
-> Ship -> Ship
-> (EvErr -> STM ()) -> (EvErr -> STM ())
-> Bool -> Bool
-> (Text -> RIO e ()) -> (Text -> RIO e ())
-> ([Ev], RAcquire e (HttpServerEf -> IO ())) -> ([Ev], RAcquire e (HttpServerEf -> IO ()))
eyre env multi who plan isFake stderr = (initialEvents, runHttpServer) eyre env who plan isFake stderr = (initialEvents, runHttpServer)
where where
king = fromIntegral (env ^. kingIdL) king = fromIntegral (env ^. kingIdL)
multi = env ^. multiEyreApiL
initialEvents :: [Ev] initialEvents :: [Ev]
initialEvents = [bornEv king] initialEvents = [bornEv king]
@ -351,7 +352,7 @@ eyre env multi who plan isFake stderr = (initialEvents, runHttpServer)
restart :: Drv -> HttpServerConf -> RIO e Serv restart :: Drv -> HttpServerConf -> RIO e Serv
restart (Drv var) conf = do restart (Drv var) conf = do
logDebug "Restarting http server" logDebug "Restarting http server"
let startAct = startServ multi who isFake conf plan stderr let startAct = startServ who isFake conf plan stderr
res <- fromEither =<< restartService var startAct kill res <- fromEither =<< restartService var startAct kill
logDebug "Done restating http server" logDebug "Done restating http server"
pure res pure res

11
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -32,7 +32,6 @@ import Urbit.EventLog.LMDB (EventLog)
import Urbit.King.API (TermConn) import Urbit.King.API (TermConn)
import Urbit.Noun.Time (Wen) import Urbit.Noun.Time (Wen)
import Urbit.TermSize (TermSize(..)) import Urbit.TermSize (TermSize(..))
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
import Urbit.Vere.Serf (Serf) import Urbit.Vere.Serf (Serf)
import qualified Data.Text as T import qualified Data.Text as T
@ -270,9 +269,8 @@ pier
:: (Serf, EventLog) :: (Serf, EventLog)
-> TVar (Text -> IO ()) -> TVar (Text -> IO ())
-> MVar () -> MVar ()
-> MultiEyreApi
-> RAcquire PierEnv () -> RAcquire PierEnv ()
pier (serf, log) vSlog startedSig multi = do pier (serf, log) vSlog startedSig = do
let logId = Log.identity log :: LogIdentity let logId = Log.identity log :: LogIdentity
let ship = who logId :: Ship let ship = who logId :: Ship
@ -321,7 +319,7 @@ pier (serf, log) vSlog startedSig multi = do
let err = atomically . Term.trace muxed . (<> "\r\n") let err = atomically . Term.trace muxed . (<> "\r\n")
let siz = TermSize { tsWide = 80, tsTall = 24 } let siz = TermSize { tsWide = 80, tsTall = 24 }
let fak = isFake logId let fak = isFake logId
drivers env multi ship fak compute (siz, muxed) err sigint drivers env ship fak compute (siz, muxed) err sigint
scrySig <- newEmptyTMVarIO scrySig <- newEmptyTMVarIO
onKill <- view onKillPierSigL onKill <- view onKillPierSigL
@ -422,7 +420,6 @@ data Drivers = Drivers
drivers drivers
:: HasPierEnv e :: HasPierEnv e
=> e => e
-> MultiEyreApi
-> Ship -> Ship
-> Bool -> Bool
-> (RunReq -> STM ()) -> (RunReq -> STM ())
@ -430,11 +427,11 @@ drivers
-> (Text -> RIO e ()) -> (Text -> RIO e ())
-> IO () -> IO ()
-> RAcquire e ([Ev], RAcquire e Drivers) -> RAcquire e ([Ev], RAcquire e Drivers)
drivers env multi who isFake plan termSys stderr serfSIGINT = do drivers env who isFake plan termSys stderr serfSIGINT = do
(behnBorn, runBehn) <- rio Behn.behn' (behnBorn, runBehn) <- rio Behn.behn'
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT) (termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr) (amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
(httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake stderr) (httpBorn, runEyre) <- rio (Eyre.eyre' who isFake stderr)
(clayBorn, runClay) <- rio Clay.clay' (clayBorn, runClay) <- rio Clay.clay'
(irisBorn, runIris) <- rio Iris.client' (irisBorn, runIris) <- rio Iris.client'

239
pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs Normal file
View File

@ -0,0 +1,239 @@
module Urbit.Vere.Ports (HasPortControlApi(..),
PortControlApi,
buildInactivePorts,
buildNatPorts,
requestPortAccess) where
import Control.Monad.STM (check)
import Urbit.Prelude
import Network.NatPmp
import Data.Time.Clock.POSIX
import Network.Socket
import qualified Data.Heap as DH
-- This module deals with ports and port requests. When a component wants to
-- ensure that it is externally reachable, possibly from outside a NAT, it
-- makes a request to this module to hole-punch.
class HasPortControlApi a where
portControlApiL :: Lens' a PortControlApi
data PortControlApi = PortControlApi
{ pAddPortRequest :: Word16 -> IO ()
, pRemovePortRequest :: Word16 -> IO ()
}
-- | Builds a PortControlApi struct which does nothing when called.
buildInactivePorts :: PortControlApi
buildInactivePorts = PortControlApi noop noop
where
noop x = pure ()
-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
-- NAT gateway over NAT-PMP.
buildNatPorts :: (HasLogFunc e)
=> (Text -> RIO e ())
-> RIO e PortControlApi
buildNatPorts stderr = do
q <- newTQueueIO
async $ portThread q stderr
let addRequest port = do
resp <- newEmptyTMVarIO
atomically $
writeTQueue q (PTMOpen port (putTMVar resp True))
atomically $ takeTMVar resp
pure ()
let removeRequest port = atomically $ writeTQueue q (PTMClose port)
pure $ PortControlApi addRequest removeRequest
portLeaseLifetime :: Word32
portLeaseLifetime = 15 * 60
-- Be paranoid and renew leases a full minute before they would naturally expire.
portRenewalTime :: Word32
portRenewalTime = portLeaseLifetime - 60
-- Messages sent from the main thread to the port mapping communication thread.
data PortThreadMsg
= PTMOpen Word16 (STM ())
-- ^ Does the open request, and then runs the passed in stm action to
-- signal completion to the main thread. We want to block on the initial
-- setting opening because we want the forwarding set up before we actually
-- start using the port.
| PTMClose Word16
-- ^ Close command. No synchronization because there's nothing we can do if
-- it fails.
-- We get requests to acquire a port as an RAII condition, but the actual APIs
-- are timeout based, so we have to maintain a heap of the next timer to
-- rerequest port access.
data RenewAction = RenewAction Word16
-- The port thread is an async which reads commands from an STM queue and then
-- executes them. This thread is here to bind the semantics that we want to how
-- NAT-PMP sees the world. We want for an RAcquire to be able to start a
-- request for port forwarding and then to release it when it goes out of
-- scope. OTOH, NAT-PMP is all timeout based, and we want that timeout to be
-- fairly short, such as 15 minutes, so the portThread needs to keep track of
-- the time of the next port request.
portThread :: forall e. (HasLogFunc e)
=> TQueue PortThreadMsg
-> (Text -> RIO e ())
-> RIO e ()
portThread q stderr = do
initNatPmp >>= \case
Left err -> do
likelyIPAddress >>= \case
Just ip@(192, 168, _, _) -> warnBehindRouterAndErr ip err
Just ip@(10, _, _, _) -> warnBehindRouterAndErr ip err
_ -> assumeOnPublicInternet
Right pmp -> foundRouter pmp
where
warnBehindRouterAndErr (a, b, c, d) err = do
stderr $ "port: you appear to be behind a router since your ip " ++
"is " ++ (tshow a) ++ "." ++ (tshow b) ++ "." ++ (tshow c) ++
"." ++ (tshow d) ++ ", but " ++
"we could not request port forwarding (NAT-PMP error: " ++
(tshow err) ++ ")"
stderr $ "port: urbit performance will be degregaded unless you " ++
"manually forward your ames port."
loopErr q
assumeOnPublicInternet = do
stderr $ "port: couldn't find router; assuming on public internet"
loopErr q
foundRouter :: NatPmpHandle -> RIO e ()
foundRouter pmp = do
getPublicAddress pmp >>= \case
Left _ -> pure ()
Right addr -> do
let (a, b, c, d) = hostAddressToTuple addr
stderr $ "port: router reports that our public IP is " ++ (tshow a) ++
"." ++ (tshow b) ++ "." ++ (tshow c) ++ "." ++ (tshow d)
loop pmp mempty
loop :: NatPmpHandle -> DH.MinPrioHeap POSIXTime RenewAction -> RIO e ()
loop pmp nextRenew = do
now <- io $ getPOSIXTime
delay <- case DH.viewHead nextRenew of
Nothing -> newTVarIO False
Just (fireTime, _) -> do
let timeTo = fireTime - now
let ms = round $ timeTo * 1000000
registerDelay ms
command <- atomically $
(Left <$> fini delay) <|> (Right <$> readTQueue q)
case command of
Left () -> handleRenew pmp nextRenew
Right msg -> handlePTM pmp msg nextRenew
handlePTM :: NatPmpHandle
-> PortThreadMsg
-> DH.MinPrioHeap POSIXTime RenewAction
-> RIO e ()
handlePTM pmp msg nextRenew = case msg of
PTMOpen p notifyComplete -> do
logInfo $
displayShow ("port: sending initial request to NAT-PMP for port ", p)
setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case
Left err -> do
logError $
displayShow ("port: failed to request NAT-PMP for port ", p,
":", err, ", disabling NAT-PMP")
loopErr q
Right _ -> do
-- Filter any existing references to this port on the heap to ensure
-- we don't double up on tasks.
let filteredHeap = filterPort p nextRenew
now <- io $ getPOSIXTime
let withRenew =
DH.insert (now + fromIntegral portRenewalTime, RenewAction p)
filteredHeap
atomically notifyComplete
loop pmp withRenew
PTMClose p -> do
logInfo $
displayShow ("port: releasing lease for ", p)
setPortMapping pmp PTUdp p p 0
let removed = filterPort p nextRenew
loop pmp removed
handleRenew :: NatPmpHandle
-> DH.MinPrioHeap POSIXTime RenewAction
-> RIO e ()
handleRenew pmp nextRenew = do
case (DH.view nextRenew) of
Nothing -> error "Internal heap managing error."
Just ((_, RenewAction p), rest) -> do
logInfo $
displayShow ("port: sending renewing request to NAT-PMP for port ",
p)
setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case
Left err -> do
logError $
displayShow ("port: failed to request NAT-PMP for port ", p,
":", err, ", disabling NAT-PMP")
loopErr q
Right _ -> do
-- We don't need to filter the port because we just did.
now <- io $ getPOSIXTime
let withRenew =
DH.insert (now + fromIntegral portRenewalTime, RenewAction p)
rest
loop pmp withRenew
filterPort :: Word16
-> DH.MinPrioHeap POSIXTime RenewAction
-> DH.MinPrioHeap POSIXTime RenewAction
filterPort p = DH.filter okPort
where
okPort (_, RenewAction x) = p /= x
-- block (retry) until the delay TVar is set to True
fini :: TVar Bool -> STM ()
fini = check <=< readTVar
-- The NAT system is considered "off" but we still need to signal back to
-- the main thread that blocking actions are complete.
loopErr q = forever $ do
(atomically $ readTQueue q) >>= \case
PTMOpen _ onComplete -> atomically onComplete
PTMClose _ -> pure ()
-- When we were unable to connect to a router, get the ip address on the
-- default ipv4 interface to check if we look like we're on an internal network
-- or not.
likelyIPAddress :: MonadIO m => m (Maybe (Word8, Word8, Word8, Word8))
likelyIPAddress = liftIO do
-- Try opening a socket to 1.1.1.1 to get our own IP address. Since UDP is
-- stateless and we aren't sending anything, we aren't actually contacting
-- them in any way.
sock <- socket AF_INET Datagram 0
connect sock (SockAddrInet 53 (tupleToHostAddress (1, 1, 1, 1)))
sockAddr <- getSocketName sock
case sockAddr of
SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr
_ -> pure $ Nothing
-- Acquire a port for the duration of the RAcquire.
requestPortAccess :: forall e. (HasPortControlApi e) => Word16 -> RAcquire e ()
requestPortAccess port = do
mkRAcquire request release
where
request :: RIO e ()
request = do
api <- view portControlApiL
io $ pAddPortRequest api port
release :: () -> RIO e ()
release _ = do
api <- view portControlApiL
io $ pRemovePortRequest api port

2
pkg/hs/urbit-king/package.yaml
View File

@ -50,6 +50,7 @@ dependencies:
- Glob - Glob
- hashable - hashable
- hashtables - hashtables
- heap
- http-client - http-client
- http-client-tls - http-client-tls
- http-types - http-types
@ -64,6 +65,7 @@ dependencies:
- mtl - mtl
- multimap - multimap
- murmur3 - murmur3
- natpmp-static
- network - network
- optparse-applicative - optparse-applicative
- para - para

24
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -15,6 +15,7 @@ import Urbit.Noun.Time
import Urbit.Prelude import Urbit.Prelude
import Urbit.Vere.Ames import Urbit.Vere.Ames
import Urbit.Vere.Pier.Types import Urbit.Vere.Pier.Types
import Urbit.Vere.Ports
import Control.Concurrent (runInBoundThread) import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..)) import Data.LargeWord (LargeKey(..))
@ -27,7 +28,11 @@ import qualified Urbit.EventLog.LMDB as Log
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e) type HasAmes e =
( HasLogFunc e
, HasNetworkConfig e
, HasKingId e
, HasPortControlApi e)
-- Utils ----------------------------------------------------------------------- -- Utils -----------------------------------------------------------------------
@ -43,6 +48,7 @@ sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs
data NetworkTestApp = NetworkTestApp data NetworkTestApp = NetworkTestApp
{ _ntaLogFunc :: !LogFunc { _ntaLogFunc :: !LogFunc
, _ntaNetworkConfig :: !NetworkConfig , _ntaNetworkConfig :: !NetworkConfig
, _ntaPortControlApi :: !PortControlApi
, _ntaKingId :: !Word16 , _ntaKingId :: !Word16
} }
@ -57,10 +63,15 @@ instance HasNetworkConfig NetworkTestApp where
instance HasKingId NetworkTestApp where instance HasKingId NetworkTestApp where
kingIdL = ntaKingId kingIdL = ntaKingId
instance HasPortControlApi NetworkTestApp where
portControlApiL = ntaPortControlApi
runNetworkApp :: RIO NetworkTestApp a -> IO a runNetworkApp :: RIO NetworkTestApp a -> IO a
runNetworkApp = runRIO NetworkTestApp runNetworkApp =
runRIO NetworkTestApp
{ _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) { _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ())
, _ntaKingId = 34 , _ntaKingId = 34
, _ntaPortControlApi = buildInactivePorts
, _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal , _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal
, _ncAmesPort = Nothing , _ncAmesPort = Nothing
, _ncNoAmes = False , _ncNoAmes = False
@ -110,8 +121,7 @@ sendThread cb (to, val) = void $ mkRAcquire start cancel
zodSelfMsg :: Property zodSelfMsg :: Property
zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest) zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where where
runTest runTest :: (HasAmes e) => Bytes -> RIO e Bool
:: (HasLogFunc e, HasNetworkConfig e, HasKingId e) => Bytes -> RIO e Bool
runTest val = runRAcquire $ do runTest val = runRAcquire $ do
env <- ask env <- ask
(zodQ, zod) <- runGala 0 (zodQ, zod) <- runGala 0
@ -121,15 +131,13 @@ zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
twoTalk :: Property twoTalk :: Property
twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest) twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where where
runTest :: (HasLogFunc e, HasNetworkConfig e, HasKingId e) runTest :: (HasAmes e) => (Word8, Word8, Bytes) -> RIO e Bool
=> (Word8, Word8, Bytes) -> RIO e Bool
runTest (aliceShip, bobShip, val) = runTest (aliceShip, bobShip, val) =
if aliceShip == bobShip if aliceShip == bobShip
then pure True then pure True
else go aliceShip bobShip val else go aliceShip bobShip val
go :: (HasLogFunc e, HasNetworkConfig e, HasKingId e) go :: (HasAmes e) => Word8 -> Word8 -> Bytes -> RIO e Bool
=> Word8 -> Word8 -> Bytes -> RIO e Bool
go aliceShip bobShip val = runRAcquire $ do go aliceShip bobShip val = runRAcquire $ do
(aliceQ, alice) <- runGala aliceShip (aliceQ, alice) <- runGala aliceShip
(bobQ, bob) <- runGala bobShip (bobQ, bob) <- runGala bobShip