vpn-router (empty) → 0.0.1
raw patch · 17 files changed
+1001/−0 lines, 17 filesdep +QuickCheckdep +basedep +blaze-markup
Dependencies added: QuickCheck, base, blaze-markup, conduit, conduit-extra, network, optparse-applicative, regex-tdfa, relude, tagged, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, template-haskell, trace-embrace, typelits-printf, unliftio, vpn-router, wai, yesod-core
Files
- LICENSE +32/−0
- app/VpnRouter.hs +8/−0
- changelog.md +4/−0
- src/VpnRouter/App.hs +9/−0
- src/VpnRouter/Bash.hs +27/−0
- src/VpnRouter/CmdArgs.hs +123/−0
- src/VpnRouter/CmdRun.hs +24/−0
- src/VpnRouter/Net.hs +81/−0
- src/VpnRouter/Net/IpTool.hs +121/−0
- src/VpnRouter/Net/Iptables.hs +74/−0
- src/VpnRouter/Net/Types.hs +82/−0
- src/VpnRouter/Page.hs +138/−0
- src/VpnRouter/Prelude.hs +6/−0
- test/Discovery.hs +1/−0
- test/Driver.hs +13/−0
- test/VpnRouter/Test/Net.hs +50/−0
- vpn-router.cabal +208/−0
+ LICENSE view
@@ -0,0 +1,32 @@+This module is under this "3 clause" BSD license:++Copyright (c) 2025-2025, Daniil Iaitskov+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 names of the contributors 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.
+ app/VpnRouter.hs view
@@ -0,0 +1,8 @@+module Main where++import VpnRouter.CmdArgs+import VpnRouter.CmdRun+import VpnRouter.Prelude++main :: IO ()+main = execWithArgs runCmd
+ changelog.md view
@@ -0,0 +1,4 @@+# vpn-router changelog++## Version 0.0.1 2026-02-02+ * init
+ src/VpnRouter/App.hs view
@@ -0,0 +1,9 @@+module VpnRouter.App where++import VpnRouter.Prelude+import UnliftIO.Exception ( stringException, throwIO )++type NetM m = (HasCallStack, MonadIO m)++ex :: NetM m => String -> m a+ex em = throwIO $ stringException em
+ src/VpnRouter/Bash.hs view
@@ -0,0 +1,27 @@+module VpnRouter.Bash where++import VpnRouter.Prelude+ ( ($),+ pure,+ Monad((>>=)),+ Maybe(Just, Nothing),+ (<$>),+ trIo,+ printf,+ MonadIO(liftIO),+ ToString(toString),+ Text )+import VpnRouter.App ( ex, NetM )+import UnliftIO.Process ( callProcess )+import UnliftIO.Directory ( findExecutable )++checkAppOnPath :: NetM m => Text -> m ()+checkAppOnPath cmd =+ findExecutable (toString cmd) >>= \case+ Nothing -> ex $ printf "Tool [%s] is not on PATH" cmd+ Just _ -> pure ()++bash :: NetM m => Text -> [Text] -> m ()+bash cmd args = do+ liftIO $(trIo "/cmd args")+ callProcess (toString cmd) (toString <$> args)
+ src/VpnRouter/CmdArgs.hs view
@@ -0,0 +1,123 @@+module VpnRouter.CmdArgs where++import Options.Applicative+import System.IO.Unsafe ( unsafePerformIO )+import VpnRouter.Net.IpTool+ ( mainRoutingTableName, listDefaultsOfRoutingTable )+import VpnRouter.Net.Types+ ( RoutingTableId(RoutingTableId),+ PacketMark(..),+ HostIp,+ Gateway,+ IspNic,+ parseIpV4 )+import VpnRouter.Prelude+ ( ($),+ Eq,+ untag,+ Monad((>>=)),+ Show,+ Semigroup((<>)),+ Int,+ Tagged(Tagged),+ (=<<),+ fst,+ snd,+ putStrLn,+ show,+ MonadIO(..),+ Text )+++data HttpPort++data CmdArgs+ = RunService+ { ispNic :: Tagged IspNic Text+ , gatewayHost :: Tagged Gateway HostIp+ , routingTableId :: RoutingTableId+ , packetMark :: PacketMark+ , httpPortToListen :: Tagged HttpPort Int+ }+ | VpnRouterVersion+ deriving (Eq, Show)++execWithArgs :: MonadIO m => (CmdArgs -> m a) -> m a+execWithArgs a = a =<< liftIO (execParser $ info (cmdp <**> helper) phelp)+ where+ routingTableOp = RoutingTableId <$>+ option auto+ ( long "routing-table"+ <> short 't'+ <> value 7+ <> showDefault+ <> help "routing table id"+ )+ packetMarkOp = PacketMark <$>+ option auto+ ( long "packet-mark"+ <> short 'm'+ <> value 2+ <> showDefault+ <> help "packet mark"+ )+ serviceP =+ RunService+ <$> (Tagged @IspNic <$> ispNicOp)+ <*> (Tagged @Gateway <$> gatewayHostOp)+ <*> routingTableOp+ <*> packetMarkOp+ <*> portOption+ cmdp =+ hsubparser+ ( command "run" (infoP serviceP $ "launch the service exposed over HTTP")+ <> command "version" (infoP (pure VpnRouterVersion) "print program version"))++ infoP p h = info p (progDesc h <> fullDesc)+ phelp =+ progDesc+ "HTML interface for VPN bypass"++ispNicOp :: Parser Text+ispNicOp =+ strOption (long "dev" <> short 'd' <>+ value (untag $ snd defaultGwNic) <>+ showDefault <>+ help "network device name connected to the Internet")++-- default via 192.168.1.1 dev wlp2s0 proto dhcp src 192.168.1.103 metric 600+defaultGwNic :: (Tagged Gateway HostIp, Tagged IspNic Text)+defaultGwNic = unsafePerformIO go+ where+ defDef = ("192.168.1.1", "wlp2s0")+ go = do+ listDefaultsOfRoutingTable mainRoutingTableName >>= \case+ [(gw, nic)] ->+ pure (gw, nic)+ [] -> do+ putStrLn $ "No default route in the main routing table"+ pure defDef+ o -> do+ putStrLn $ "Multiple default routes in the main routing table: " <> show o+ pure defDef++portOption :: Parser (Tagged HttpPort Int)+portOption = Tagged <$>+ option auto+ ( long "port"+ <> short 'p'+ <> showDefault+ <> value 3000+ <> help "HTTP port to listen"+ <> metavar "PORT"+ )++gatewayHostOp :: Parser HostIp+gatewayHostOp =+ option (maybeReader parseIpV4)+ ( long "gateway"+ <> short 'g'+ <> value (untag $ fst defaultGwNic)+ <> showDefault+ <> help "network device name connected to the Internet"+ )
+ src/VpnRouter/CmdRun.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedRecordDot #-}+module VpnRouter.CmdRun where++import Data.Version (showVersion)+import Paths_vpn_router ( version )+import VpnRouter.Bash ( checkAppOnPath )+import VpnRouter.Page ( Ypp(Ypp) )+import VpnRouter.CmdArgs ( CmdArgs(..) )+import VpnRouter.Net ( manualInit, cleanup )+import VpnRouter.Net.Iptables ( iptables )+import VpnRouter.Net.IpTool ( ip )+import VpnRouter.Prelude+import Yesod.Core ( warp )++runCmd :: CmdArgs -> IO ()+runCmd = \case+ rs@(RunService {}) -> do+ $(trIo "start/rs")+ mapM_ checkAppOnPath [ip, iptables]+ cleanup rs.routingTableId rs.packetMark+ manualInit rs.routingTableId rs.packetMark rs.ispNic rs.gatewayHost+ warp (untag rs.httpPortToListen) =<< Ypp rs.packetMark rs.routingTableId <$> newMVar ()+ VpnRouterVersion ->+ putStrLn $ "Version" <> showVersion version
+ src/VpnRouter/Net.hs view
@@ -0,0 +1,81 @@+module VpnRouter.Net where++import Network.Socket ( SockAddr(SockAddrInet) )+import Network.Wai ( Request(remoteHost) )+import VpnRouter.App ( NetM )+import VpnRouter.Net.Types+ ( RoutingTableId,+ PacketMark,+ ClientAdr(..),+ HostIp(..),+ LineNumber,+ Gateway,+ IspNic )+import VpnRouter.Net.Iptables+ ( listMarkedSources, rmMarkingRule, addMarkingRule )+import VpnRouter.Net.IpTool+ ( addDefaultRouteToRoutingTable,+ flushRouteCache,+ unmarkRoutingTable,+ deleteDefaultRoute,+ listDefaultsOfRoutingTable,+ addMarkToRoutingTable )+import VpnRouter.Prelude+import Yesod.Core ( HandlerFor, waiRequest )+import UnliftIO.Exception ( stringException, throwIO )++isVpnOff :: NetM m => (PacketMark, ClientAdr) -> m Bool+isVpnOff pmca = do+ markedSources <- $(tw "/pmca") <$> listMarkedSources+ pure $ (pmca `elem` (projPmCa <$> markedSources))+ where+ projPmCa (_, pm, ca) = (pm, ca)++getClientAdr :: HandlerFor a ClientAdr+getClientAdr =+ waiRequest >>= \r ->+ case remoteHost r of+ SockAddrInet _port hip -> pure . ClientAdr $ HostIp hip+ _ -> throwIO $ stringException "Unsupported socket addr"++manualInit :: NetM m => RoutingTableId -> PacketMark -> Tagged IspNic Text -> Tagged Gateway HostIp -> m ()+manualInit rt pm isp gw = do+ addMarkToRoutingTable rt pm+ addDefaultRouteToRoutingTable rt isp gw+ flushRouteCache++clearMarkingLines :: NetM m => PacketMark -> m ()+clearMarkingLines pm = do+ mapM_ rmMarkingRule =<< fmap oneOf3 . reverse . sort . filter matchPm . $(tw "/pm" ) <$> listMarkedSources+ where+ matchPm (_, lpm, _) = lpm == pm++clearDefaultRoute :: NetM m => RoutingTableId -> m ()+clearDefaultRoute rt =+ mapM_ (\(_, _) -> deleteDefaultRoute rt) . $(tw "/rt") =<< listDefaultsOfRoutingTable rt++cleanup :: NetM m => RoutingTableId -> PacketMark -> m ()+cleanup rt pm = do+ clearMarkingLines pm+ clearDefaultRoute rt+ unmarkRoutingTable rt pm+ flushRouteCache++oneOf3 :: (a, b, c) -> a+oneOf3 (a, _, _) = a++findMarkingLine :: NetM m => ClientAdr -> PacketMark -> m (Maybe LineNumber)+findMarkingLine ca pm = fmap oneOf3 . find lineP <$> listMarkedSources+ where+ lineP (_, lpm, lca) = pm == lpm && ca == lca++turnOffVpnFor :: NetM m => ClientAdr -> PacketMark -> m ()+turnOffVpnFor ca pm =+ findMarkingLine ca pm >>= \case+ Just _ -> pure () --+ Nothing ->+ addMarkingRule ca pm++turnOnVpnFor :: NetM m => ClientAdr -> PacketMark -> m ()+turnOnVpnFor ca pm =+ findMarkingLine ca pm >>= mapM_ rmMarkingRule
+ src/VpnRouter/Net/IpTool.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -freduction-depth=0 #-} -- workaround for printf+module VpnRouter.Net.IpTool where++import Data.Conduit.Process ( sourceCmdWithConsumer )+import System.Exit ( ExitCode(ExitFailure, ExitSuccess) )+import Text.Regex.TDFA ( AllTextSubmatches(getAllTextSubmatches), (=~) )+import VpnRouter.Prelude+import VpnRouter.Net.Types+ ( RoutingTableId(..),+ PacketMark(..),+ RuleId(..),+ HostIp,+ Gateway,+ IspNic,+ pipeline,+ parseIpV4,+ hostIpToDec )+import VpnRouter.App ( NetM, ex )+import VpnRouter.Bash ( bash )++ip :: IsString s => s+ip = "ip"++mainRoutingTableName :: RoutingTableId+mainRoutingTableName = RoutingTableName "main"+{-+delete rule by id from routing table 3+ip rule del pref 32765 table 3+-}+{-+list rules in routing table 3+ip rule list table 3+32765: from all fwmark 0x2 lookup 3+-}+-- 32765: from all fwmark 0x2 lookup 7+ruleListLinePat :: String+ruleListLinePat = "^([0-9]+):[[:space:]]+from[[:space:]]+all[[:space:]]+fwmark[[:space:]]+(0x[0-9a-fA-F]+)[[:space:]]+lookup"+++parseRoutingTableMarkLine :: Text -> Maybe (RuleId, PacketMark)+parseRoutingTableMarkLine l =+ case getAllTextSubmatches (l =~ ruleListLinePat) of+ ([_full, riGroup, pmGroup] :: [Text]) ->+ case readEither $ toString riGroup of+ Left e -> error . toText @String $ printf "failed to parse rule id in: %s due %s" l e+ Right ri ->+ case readEither $ toString pmGroup of+ Left e -> error . toText @String $ printf "failed to parse packet mark in: %s due %s" l e+ Right pm -> pure (RuleId ri, PacketMark pm)+ _ -> Nothing++routingTableMarks :: NetM m => RoutingTableId -> m [(RuleId, PacketMark)]+routingTableMarks rt = do+ (ec, l) <- sourceCmdWithConsumer bashCmd (pipeline parseRoutingTableMarkLine)+ case ec of+ ExitSuccess -> pure l+ ExitFailure erc -> ex $ printf "Failed to list ip rules for routingi table %s; error code %d" rt erc+ where+ bashCmd = printf "%s rule list table %s" (ip :: Text) rt++addDefaultRouteToRoutingTable :: NetM m => RoutingTableId -> Tagged IspNic Text -> Tagged Gateway HostIp -> m ()+addDefaultRouteToRoutingTable rt (Tagged isp) (Tagged gw) =+ bash ip [ "route", "add", "default"+ , "via", hostIpToDec gw+ , "dev", isp+ , "table", printf "%s" rt+ ]++flushRouteCache :: NetM m => m ()+flushRouteCache = bash ip [ "route", "flush", "cache" ]++unmarkRoutingTable :: NetM m => RoutingTableId -> PacketMark -> m ()+unmarkRoutingTable rt pm = do+ mapM_ unmark =<< (reverse . sort . fmap fst . filter ((pm ==) . snd) <$> routingTableMarks rt)+ where+ unmark (RuleId rid) = bash ip ["rule", "del", "pref", show rid]++deleteDefaultRoute :: NetM m => RoutingTableId -> m ()+deleteDefaultRoute rt =+ bash ip [ "route", "del", "default", "table", printf "%s" rt]++-- default via 192.168.1.1 dev wlp2s0 table 3+defaultRoutePat :: String+defaultRoutePat =+ "^default[[:space:]]+" <>+ "via[[:space:]]+" <>+ "([[:digit:].]+)[[:space:]]+" <> -- gateway+ "dev[[:space:]]+" <>+ "([^[:space:]]+)[[:space:]]+" <> -- nic+ "(table[[:space:]]+" <>+ "([[:digit:]]+))?" -- table id is not printed for the main table++parseDefaultRoutingLine :: RoutingTableId -> Text -> Maybe (Tagged Gateway HostIp, Tagged IspNic Text)+parseDefaultRoutingLine rt l =+ case getAllTextSubmatches (l =~ defaultRoutePat) of+ ([_full, gwGr, nicGr, "", ""] :: [Text]) | rt == mainRoutingTableName ->+ case parseIpV4 $ toString gwGr of+ Nothing -> Nothing+ Just gw -> pure (Tagged @Gateway gw, Tagged @IspNic nicGr)+ ([_full, gwGr, nicGr, _rt, rtGr] :: [Text]) ->+ case readMaybe $ toString rtGr of+ Nothing -> Nothing+ Just lrt | RoutingTableId lrt == rt ->+ case parseIpV4 $ toString gwGr of+ Nothing -> Nothing+ Just gw -> pure (Tagged @Gateway gw, Tagged @IspNic nicGr)+ | otherwise -> Nothing+ _ -> Nothing++listDefaultsOfRoutingTable :: NetM m => RoutingTableId -> m [(Tagged Gateway HostIp, Tagged IspNic Text)]+listDefaultsOfRoutingTable rt = do+ (ec, l) <- sourceCmdWithConsumer bashCmd (pipeline (parseDefaultRoutingLine rt))+ case ec of+ ExitSuccess -> pure l+ ExitFailure erc -> ex $ printf "Failed to list ip routes for routing table %s; error code %d" rt erc+ where+ bashCmd = (ip :: String) <> " route show table all"++addMarkToRoutingTable :: NetM m => RoutingTableId -> PacketMark -> m ()+addMarkToRoutingTable rt (PacketMark pm) =+ bash ip ["rule", "add", "fwmark", show pm, "table", printf "%s" rt]
+ src/VpnRouter/Net/Iptables.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -freduction-depth=0 #-}+module VpnRouter.Net.Iptables where++import Data.Conduit.Process ( sourceCmdWithConsumer )+import System.Exit ( ExitCode(ExitFailure, ExitSuccess) )+import Text.Regex.TDFA ( AllTextSubmatches(getAllTextSubmatches), (=~) )+import VpnRouter.App ( NetM, ex )+import VpnRouter.Bash ( bash )+import VpnRouter.Net.Types+ ( PacketMark(..),+ ClientAdr(..),+ LineNumber,+ clientAdrToDec4,+ pipeline,+ parseIpV4 )+import VpnRouter.Prelude++iptables :: IsString s => s+iptables = "iptables"++listMarkedSources :: NetM m => m [(LineNumber, PacketMark, ClientAdr)]+listMarkedSources = do+ (ec, l) <- sourceCmdWithConsumer bashCmd (pipeline parseIptablesLine)+ case ec of+ ExitSuccess -> pure l+ ExitFailure erc -> ex $ printf "Failed to list marking rules; due %d" erc+ where+ bashCmd = iptables <> " -t mangle -L PREROUTING -n --line-numbers"++rmMarkingRule :: NetM m => LineNumber -> m ()+rmMarkingRule ln =+ bash iptables [ "-t", "mangle", "-D", "PREROUTING", show ln]++addMarkingRule :: NetM m => ClientAdr -> PacketMark -> m ()+addMarkingRule ca (PacketMark pm) =+ bash iptables [ "-t", "mangle", "-I", "PREROUTING"+ , "-s", clientAdrToDec4 ca+ , "-j", "MARK"+ , "--set-mark", show pm+ ]++{-+iptables -t mangle -L PREROUTING -n+Chain PREROUTING (policy ACCEPT)+num target prot opt source destination+1 MARK all -- 192.168.11.14 0.0.0.0/0 MARK set 0x2+-}+mangleLinePattern :: String+mangleLinePattern =+ "^([[:digit:]]+)" <> -- "num" column+ "[[:space:]]+MARK" <> -- "target" column+ "[[:space:]]+[^[:space:]]+" <> -- skip "prot" column+ "[[:space:]]+[^[:space:]]+" <> -- skip "opt" column+ "[[:space:]]+([[:digit:].]+)" <> -- source column+ "[[:space:]]+[^[:space:]]+" <> -- skip "destination" column+ "[[:space:]]+MARK set (0x[[:digit:]]+)" -- extra column++parseIptablesLine :: Text -> Maybe (LineNumber, PacketMark, ClientAdr)+parseIptablesLine l =+ case getAllTextSubmatches (l =~ mangleLinePattern) of+ ([_full, lnGr, sourceIp, pmGroup] :: [Text]) ->+ case readEither $ toString lnGr of+ Left e -> error . toText $ printf "failed to parse line number (%s) in: %s due %s" lnGr l e+ Right lineNum ->+ case parseIpV4 $ toString sourceIp of+ Nothing -> error . toText @String $ printf "failed to parse client IP in: %s" l+ Just clientSourceIp ->+ case readEither $ toString pmGroup of+ Left e -> error . toText @String $ printf "failed to parse packet mark in: %s due %s" l e+ Right pm -> pure ( lineNum+ , PacketMark pm+ , ClientAdr clientSourceIp+ )+ _ -> Nothing
+ src/VpnRouter/Net/Types.hs view
@@ -0,0 +1,82 @@+module VpnRouter.Net.Types where++import Conduit ( (.|), mapC, ConduitT)+import Data.Conduit.Combinators (concatMap, sinkList)+import Data.Conduit.Text ( lines )+import Data.Text (intercalate)+import Network.Socket (hostAddressToTuple, tupleToHostAddress, HostAddress)+import Text.Blaze ( text, ToMarkup(toMarkup) )+import Text.Regex.TDFA ( AllTextSubmatches(getAllTextSubmatches), (=~) )+import Text.Show qualified as TS+import VpnRouter.Prelude hiding (decodeUtf8, lines, concatMap)++data IspNic+data Gateway++newtype LineNumber = LineNumber Int deriving newtype (Eq, Ord, Show, Read)++newtype HostIp = HostIp HostAddress deriving newtype (Eq, Ord)+instance Show HostIp where+ show = toString . hostIpToDec+instance IsString HostIp where+ fromString s =+ fromMaybe (error . toText @String $ printf "Failed to parse [%s] as IPv4 address" s) $ parseIpV4 s++newtype ClientAdr = ClientAdr HostIp deriving (Eq, Ord)++instance Show ClientAdr where+ show = show . clientAdrToDec4+instance FormatType 's' ClientAdr where+ formatArg pt v ff = formatArg pt (clientAdrToDec4 v) ff++instance ToMarkup ClientAdr where+ toMarkup = text . clientAdrToDec4++clientAdrToDec4 :: ClientAdr -> Text+clientAdrToDec4 (ClientAdr sa) = hostIpToDec sa+++newtype RuleId = RuleId Int deriving (Show, Eq, Ord, FormatType 'd')+newtype PacketMark = PacketMark Int deriving (Show, Eq, Ord, FormatType 'd')++data RoutingTableId+ = RoutingTableId Int+ | RoutingTableName String+ deriving (Show, Eq, Ord)++instance FormatType 's' RoutingTableId where+ formatArg pt v ff = formatArg pt vs ff+ where+ vs :: Text+ vs = case v of+ RoutingTableId i -> show i+ RoutingTableName n -> show n++pipeline :: (Monad m) => (Text -> Maybe a) -> ConduitT ByteString c m [a]+pipeline f = mapC (fromRight "" . decodeUtf8') .| lines .| concatMap f .| sinkList++parseIpV4 :: String -> Maybe HostIp+parseIpV4 s =+ case getAllTextSubmatches (s =~ ipPat) of+ [_full, a, b, c, d] ->+ case readEither a of+ Left _ -> Nothing+ Right ai ->+ case readEither b of+ Left _ -> Nothing+ Right bi ->+ case readEither c of+ Left _ -> Nothing+ Right ci ->+ case readEither d of+ Left _ -> Nothing+ Right di ->+ pure . HostIp $ tupleToHostAddress (ai, bi, ci, di)+ _ -> Nothing+ where+ ipPat :: String = "([[:digit:]]+)[.]([[:digit:]]+)[.]([[:digit:]]+)[.]([[:digit:]]+)"++hostIpToDec :: HostIp -> Text+hostIpToDec (HostIp hip) =+ case hostAddressToTuple hip of+ (a, b, c, d) -> intercalate "." $ fmap show [a, b, c, d]
+ src/VpnRouter/Page.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}+module VpnRouter.Page where++import UnliftIO.MVar ( MVar, withMVar )+import VpnRouter.Net.Types ( RoutingTableId, PacketMark )+import VpnRouter.Net+ ( getClientAdr,+ isVpnOff,+ turnOffVpnFor,+ turnOnVpnFor )+import VpnRouter.Prelude+ ( ($), Monad((>>=)), Bool(False, True), printf )+import Yesod.Core+ ( logInfo,+ lucius,+ julius,+ getYesod,+ redirect,+ mkYesod,+ setTitle,+ whamlet,+ parseRoutes,+ Html,+ Yesod(defaultLayout),+ HandlerFor,+ ToWidget(toWidget),+ RenderRoute(renderRoute) )++data Ypp+ = Ypp+ { packetMark :: PacketMark+ , routingTable :: RoutingTableId+ , netLock :: MVar ()+ }+++mkYesod "Ypp" [parseRoutes|+/ HomeR GET+/off OffR POST+/on OnR POST+|]++instance Yesod Ypp+++getHomeR :: Handler Html -- For Ypp Html+getHomeR = do+ cdr <- getClientAdr+ $(logInfo) $ printf "Client %s visited home page" cdr+ app <- getYesod+ isVpnOff (app.packetMark, cdr) >>= \case+ True ->+ layout+ [whamlet|+ <form method=post action=@{OnR}>+ <div class=ipaddr>#{cdr}+ <div class=butdiv>+ <button class=green>Turn VPN on+ |]+ False ->+ layout+ [whamlet|+ <form method=post action=@{OffR}>+ <div class=ipaddr>#{cdr}+ <div class=butdiv>+ <button class=red>Turn VPN off+ |]+ where+ layout body = do+ defaultLayout $ do+ setTitle "VPN Router"+ toWidget+ [julius|+ document.addEventListener("visibilitychange", (event) => {+ if (document.visibilityState == "visible") {+ window.location.reload();+ }+ });+ |]+ css+ body+ css =+ toWidget [lucius|+ body { overflow: hidden; }+ .butdiv {+ display: flex;+ justify-content: center;+ align-items: center;+ height: 100vh;+ background: radial-gradient(circle, rgba(34, 193, 195, 1) 0%, rgba(253, 187, 45, 1) 100%);+ }+ button {+ font-weight: bold;+ font-size: xxx-large;+ border-radius: 4vh;+ padding: 2vh 3vh;+ border: 8px black solid;+ }+ button.red {+ color: #fc2c2c;+ border-color: #fc2c2c;+ background: linear-gradient(33deg, rgb(124 133 167) 0%, rgb(182 182 236) 12%, rgb(136 246 143) 99%);+ }+ button.green {+ color: green;+ border-color: green;+ background: linear-gradient(33deg, rgb(124 133 167) 0%, rgb(182 182 236) 12%, rgb(136 246 143) 99%);+ }+ .ipaddr {+ display: block;+ position: fixed;+ right: 4vh;+ bottom: 3vh;+ opacity: 0.5;+ font-size: xxx-large;+ background: transparent;+ }+ |]++postOffR :: HandlerFor Ypp Html+postOffR = do+ ca <- getClientAdr+ ap <- getYesod+ $(logInfo) $ printf "Client %s asked to disable VPN" ca+ withMVar ap.netLock $ \() ->+ turnOffVpnFor ca ap.packetMark+ redirect HomeR++postOnR :: HandlerFor Ypp Html+postOnR = do+ ca <- getClientAdr+ ap <- getYesod+ $(logInfo) $ printf "Client %s asked to enable VPN" ca+ withMVar ap.netLock $ \() ->+ turnOnVpnFor ca ap.packetMark+ redirect HomeR
+ src/VpnRouter/Prelude.hs view
@@ -0,0 +1,6 @@+module VpnRouter.Prelude (module X) where++import GHC.TypeLits.Printf as X+import Data.Tagged as X+import Relude as X hiding (Handle, intercalate)+import Debug.TraceEmbrace as X hiding (a)
+ test/Discovery.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-}
+ test/Driver.hs view
@@ -0,0 +1,13 @@+module Driver where++import qualified Discovery+import Relude+import Test.Tasty++main :: IO ()+main = defaultMain =<< testTree+ where+ testTree :: IO TestTree+ testTree = do+ tests <- Discovery.tests+ pure $ testGroup "vpn-router" [ tests ]
+ test/VpnRouter/Test/Net.hs view
@@ -0,0 +1,50 @@+module VpnRouter.Test.Net where++import Test.Tasty ( TestTree, testGroup )+import Test.Tasty.HUnit ( assertEqual, testCase, (@?=) )+import VpnRouter.Net.Iptables ( parseIptablesLine )+import VpnRouter.Net.IpTool+ ( mainRoutingTableName,+ parseDefaultRoutingLine,+ parseRoutingTableMarkLine )+import VpnRouter.Net.Types+ ( parseIpV4,+ ClientAdr(ClientAdr),+ HostIp(HostIp),+ LineNumber(LineNumber),+ PacketMark(PacketMark),+ RoutingTableId(RoutingTableId),+ RuleId(RuleId) )+import VpnRouter.Prelude+ ( ($), Maybe(Just, Nothing), IO, Tagged(Tagged) )++unit_parseIpV4 :: IO ()+unit_parseIpV4 = do+ assertEqual "4 zeros" (Just $ HostIp 0x0) (parseIpV4 "0.0.0.0")+ assertEqual "all 255" (Just $ HostIp 0xff_ff_ff_ff) (parseIpV4 "255.255.255.255")++test_line_parsers :: TestTree+test_line_parsers =+ testGroup "line parsers"+ [ testCase "parseIptablesLine"+ $ parseIptablesLine iptl @?= Just (LineNumber 1, PacketMark 2, ClientAdr $ HostIp 0x10_01_00_FE)+ , testGroup "parseDefaultRoutingLine"+ [ testCase "table match"+ $ parseDefaultRoutingLine rt3 rt3l @?= Just (Tagged $ HostIp 0x01_01_01_01, Tagged "wlp2s0")+ , testCase "table don't match" $ parseDefaultRoutingLine rt3 rt33l @?= Nothing+ , testCase "main table match"+ $ parseDefaultRoutingLine mainRoutingTableName mtl+ @?= Just (Tagged $ HostIp 0x01_01_01_01, Tagged "wlp2s0")+ ]+ , testGroup "ip rules"+ [ testCase "ok"+ $ parseRoutingTableMarkLine ruleL @?= Just (RuleId 32765, PacketMark 2)+ ]+ ]+ where+ ruleL = "32765:\tfrom all fwmark 0x2 lookup 7"+ iptl = "1 MARK all -- 254.0.1.16 0.0.0.0/0 MARK set 0x2"+ rt3l = "default via 1.1.1.1 dev wlp2s0 table 3"+ rt33l = "default via 1.1.1.1 dev wlp2s0 table 33"+ mtl = "default via 1.1.1.1 dev wlp2s0 ee"+ rt3 = RoutingTableId 3
+ vpn-router.cabal view
@@ -0,0 +1,208 @@+cabal-version: 3.0+name: vpn-router+version: 0.0.1++synopsis: Switch VPN with web interface for LAN+description:+ vpn-router is a service with the web interface allowing users of a local+ network to control VPN bypass from their devices. The service is tested+ with AmneziaVPN 4.8.10.++ == Motivation+ #motivation#++ It is convinient if the whole WiFi network is connected through VPN, but+ user might not access some resources sometimes. Having two networks+ deployed might be an option, though destop stations usually connect+ through the Ethernet cable, and such approch doubles the number of WiFi+ routers. Hopping between WiFi networks might not be as ergonomic as it+ should be due to bugs in the connectivity check in Android and Windows.++ == Installation+ #installation#++ There are several ways to install the app: - with conventional Haskell+ tools directly - nix-build - download the statically link version of+ <https://github.com/yaitskov/vpn-router/releases/download/v0.0.1/vpn-router vpn-router>+ from github - nixos module++ === NixOS module+ #nixos-module#++ 1. Copy+ <https://github.com/yaitskov/vpn-router/blob/v0.0.1/nixos/vpn-router.nix vpn-router.nix>+ to @\/etc\/nixos@.+ 2. Modify @\/etc\/nixos\/configuration.nix@ as follows:++ > imports =+ > [ # ... ./hardware-configuration.nix+ > ./vpn-router.nix+ > ];++ > programs = {+ > vpn-router = {+ > # the service will try to detect gateway and dev automatically if not specified+ > # gateway = "192.168.1.1";+ > # dev = "wlp2s0";+ > # port = 3000;+ > enable = true;+ > };+ > };++ Update configuration and check the new service:++ > nixos-rebuild switch+ > systemctl status "vpn-router.service"++ Once the service is running open link http:\/\/my-router:3000\/ on+ device other than the router. There is a simple UI available with a+ toggle button to control the VPN bypass.++ +----------------------------------+-----------------------------------++ | on | off |+ +==================================+===================================++ | | |+ +----------------------------------+-----------------------------------+++ The service can be stopped, because it only adjusts routing options in+ the Linux kernel, but at every start all settings related to the routing+ table and the packet mark specified in configuration will be cleared.++ === Manual configuration+ #manual-configuration#++ NixOS module provides a service ready to go, but the standalone binary+ can launched without configuration under sudo or by a regular user after+ setting proper <https://unix.stackexchange.com/a/768693 capabilities> to+ access @ip@ and @iptables@. The nixified version is shipped with these+ tools, but static elf assumes that host has these networking apps+ pre-installed.++ > Usage: vpn-router run [-d|--dev ARG] [-g|--gateway ARG] [-t|--routing-table ARG]+ > [-m|--packet-mark ARG] [-p|--port PORT]+ >+ > launch the service exposed over HTTP+ >+ > Available options:+ > -d,--dev ARG network device name connected to the Internet+ > (default: "wlp2s0")+ > -g,--gateway ARG network device name connected to the Internet+ > (default: 192.168.1.1)+ > -t,--routing-table ARG routing table id (default: 7)+ > -m,--packet-mark ARG packet mark (default: 2)+ > -p,--port PORT HTTP port to listen (default: 3000)+ > -h,--help Show this help text++ Default values for gateway and device are dynamically detected.++ == Development environment+ #development-environment#++ HLS should be available inside the dev environment.++ > $ nix-shell+ > $ emacs src/VpnRouter/Net.hs &+ > $ cabal build+ > $ cabal test++ > $ nix-build+ > $ sudo ./result/bin/vpn-router run++ == Static linking+ #static-linking#++ Static is not enabled by default, because GitHub CI job times out.++ > nix-build --arg staticBuild true+ > # faster build on beefy machine+ > nix-build --cores 20 -j 20 --arg staticBuild true+homepage: http://github.com/yaitskov/vpn-router+license: BSD-3-Clause+license-file: LICENSE+author: Daniil Iaitskov+maintainer: dyaitskov@gmail.com+copyright: Daniil Iaitkov 2026+category: System+build-type: Simple+bug-reports: https://github.com/yaitskov/vpn-router/issues+extra-doc-files:+ changelog.md+tested-with:+ GHC == 9.12.2++source-repository head+ type:+ git+ location:+ https://github.com/yaitskov/vpn-router.git++common base+ default-language: GHC2024+ ghc-options: -Wall+ default-extensions:+ DefaultSignatures+ NoImplicitPrelude+ OverloadedStrings+ TemplateHaskell+ build-depends:+ base >=4.7 && < 5+ , optparse-applicative < 1+ , relude >= 1.2.2 && < 2+ , tagged < 1+ , unliftio < 1+ , yesod-core < 1.8++library+ import: base+ hs-source-dirs: src+ exposed-modules:+ VpnRouter.App+ VpnRouter.Bash+ VpnRouter.CmdArgs+ VpnRouter.CmdRun+ VpnRouter.Net+ VpnRouter.Net.Iptables+ VpnRouter.Net.IpTool+ VpnRouter.Net.Types+ VpnRouter.Page+ VpnRouter.Prelude+ other-modules:+ Paths_vpn_router+ autogen-modules:+ Paths_vpn_router+ build-depends:+ , blaze-markup < 1+ , conduit < 2+ , conduit-extra < 2+ , network < 4+ , regex-tdfa < 2+ , template-haskell < 3+ , trace-embrace < 2+ , typelits-printf < 1+ , wai < 4++test-suite test+ import: base+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ VpnRouter.Test.Net+ Discovery+ hs-source-dirs:+ test+ ghc-options: -Wall -main-is Driver+ build-depends:+ , vpn-router+ , QuickCheck+ , tasty+ , tasty-discover+ , tasty-hunit+ , tasty-quickcheck++executable vpn-router+ import: base+ ghc-options: -Wall+ main-is: VpnRouter.hs+ hs-source-dirs: app+ build-depends:+ , vpn-router