{-# LANGUAGE QuasiQuotes #-}

-- | This module provides functionality for retrieving network connection
-- information using ip utility.
--
-- @since 0.1
module Pythia.Services.NetInterface.Ip
  ( -- * Query
    netInterfaceShellApp,
    supported,

    -- * Misc
    IpParseError (..),
    parseInterfaces,
  )
where

import Data.Char qualified as Char
import Data.Set qualified as Set
import Data.Text qualified as T
import Pythia.Internal.ShellApp
  ( SimpleShell
      ( MkSimpleShell,
        command,
        isSupported,
        parser
      ),
  )
import Pythia.Internal.ShellApp qualified as ShellApp
import Pythia.Prelude
import Pythia.Services.NetInterface.Types
  ( NetInterface
      ( MkNetInterface,
        device,
        ipv4s,
        ipv6s,
        name,
        ntype,
        state
      ),
    NetInterfaceState (NetStateDown, NetStateUnknown, NetStateUp),
    NetInterfaces (MkNetInterfaces),
  )
import Pythia.Services.Types.Network
  ( Device (MkDevice),
    IpAddress (MkIpAddress),
    IpAddresses (MkIpAddresses),
    IpType (Ipv4, Ipv6),
  )
import Pythia.Utils qualified as U
import Refined (Predicate, Refined)
import Refined qualified as R
import Text.Megaparsec (ErrorFancy (ErrorFail), Parsec, (<?>))
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Char qualified as MPC

-- $setup
-- >>> import Control.Exception (displayException)
-- >>> import Pythia.Prelude

-- | Error parsing ip output.
--
-- ==== __Examples__
--
-- >>> displayException $ MkIpParseError "parse error"
-- "Ip parse error: parse error"
--
-- @since 0.1
type IpParseError :: Type
newtype IpParseError = MkIpParseError Text
  deriving stock
    ( -- | @since 0.1
      IpParseError -> IpParseError -> Bool
(IpParseError -> IpParseError -> Bool)
-> (IpParseError -> IpParseError -> Bool) -> Eq IpParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IpParseError -> IpParseError -> Bool
== :: IpParseError -> IpParseError -> Bool
$c/= :: IpParseError -> IpParseError -> Bool
/= :: IpParseError -> IpParseError -> Bool
Eq,
      -- | @since 0.1
      Int -> IpParseError -> ShowS
[IpParseError] -> ShowS
IpParseError -> String
(Int -> IpParseError -> ShowS)
-> (IpParseError -> String)
-> ([IpParseError] -> ShowS)
-> Show IpParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IpParseError -> ShowS
showsPrec :: Int -> IpParseError -> ShowS
$cshow :: IpParseError -> String
show :: IpParseError -> String
$cshowList :: [IpParseError] -> ShowS
showList :: [IpParseError] -> ShowS
Show
    )

-- | @since 0.1
instance Exception IpParseError where
  displayException :: IpParseError -> String
displayException (MkIpParseError Text
e) =
    (String
"Ip parse error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)
      ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
e

-- | Ip query for 'NetInterface'.
--
-- @since 0.1
netInterfaceShellApp ::
  ( MonadPathReader m,
    MonadThrow m,
    MonadTypedProcess m
  ) =>
  m NetInterfaces
netInterfaceShellApp :: forall (m :: Type -> Type).
(MonadPathReader m, MonadThrow m, MonadTypedProcess m) =>
m NetInterfaces
netInterfaceShellApp = SimpleShell m IpParseError NetInterfaces -> m NetInterfaces
forall (m :: Type -> Type) err result.
(Exception err, MonadThrow m, MonadTypedProcess m) =>
SimpleShell m err result -> m result
ShellApp.runSimple SimpleShell m IpParseError NetInterfaces
shell
  where
    shell :: SimpleShell m IpParseError NetInterfaces
shell =
      MkSimpleShell
        { $sel:command:MkSimpleShell :: Command
command = Command
"ip address",
          $sel:isSupported:MkSimpleShell :: m Bool
isSupported = m Bool
forall (m :: Type -> Type). MonadPathReader m => m Bool
supported,
          $sel:parser:MkSimpleShell :: Text -> Either IpParseError NetInterfaces
parser = Text -> Either IpParseError NetInterfaces
parseInterfaces
        }
{-# INLINEABLE netInterfaceShellApp #-}

-- | Returns a boolean determining if this program is supported on the
-- current system.
--
-- @since 0.1
supported :: (MonadPathReader m) => m Bool
supported :: forall (m :: Type -> Type). MonadPathReader m => m Bool
supported = OsPath -> m Bool
forall (m :: Type -> Type). MonadPathReader m => OsPath -> m Bool
U.exeSupported [osp|ip|]
{-# INLINEABLE supported #-}

type MParser :: Type -> Type
type MParser = Parsec Void Text

-- | Attempts to parse the output of IP.
--
-- @since 0.1
parseInterfaces :: Text -> Either IpParseError NetInterfaces
parseInterfaces :: Text -> Either IpParseError NetInterfaces
parseInterfaces Text
txt = case Parsec Void Text NetInterfaces
-> String
-> Text
-> Either (ParseErrorBundle Text Void) NetInterfaces
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text NetInterfaces
mparseInterfaces String
"" Text
txt of
  Left ParseErrorBundle Text Void
ex ->
    let prettyErr :: String
prettyErr = ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
MP.errorBundlePretty ParseErrorBundle Text Void
ex
     in IpParseError -> Either IpParseError NetInterfaces
forall a b. a -> Either a b
Left (IpParseError -> Either IpParseError NetInterfaces)
-> IpParseError -> Either IpParseError NetInterfaces
forall a b. (a -> b) -> a -> b
$ Text -> IpParseError
MkIpParseError (Text -> IpParseError) -> Text -> IpParseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
prettyErr
  Right NetInterfaces
ifs -> NetInterfaces -> Either IpParseError NetInterfaces
forall a b. b -> Either a b
Right NetInterfaces
ifs
{-# INLINEABLE parseInterfaces #-}

mparseInterfaces :: MParser NetInterfaces
mparseInterfaces :: Parsec Void Text NetInterfaces
mparseInterfaces = [NetInterface] -> NetInterfaces
MkNetInterfaces ([NetInterface] -> NetInterfaces)
-> ParsecT Void Text Identity [NetInterface]
-> Parsec Void Text NetInterfaces
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity NetInterface
-> ParsecT Void Text Identity [NetInterface]
forall (m :: Type -> Type) a. MonadPlus m => m a -> m [a]
MP.many ParsecT Void Text Identity NetInterface
parseInterface
{-# INLINEABLE mparseInterfaces #-}

parseInterface :: MParser NetInterface
parseInterface :: ParsecT Void Text Identity NetInterface
parseInterface = do
  Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"device num") Char -> Bool
Token Text -> Bool
Char.isDigit
  Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MPC.char Char
Token Text
':'
  ParsecT Void Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space
  Text
device' <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"device") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
':')
  Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MPC.char Char
Token Text
':'
  ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity [Token Text]
forall (m :: Type -> Type) a end.
MonadPlus m =>
m a -> m end -> m [a]
MP.manyTill ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type). MonadParsec e s m => m (Token s)
MP.anySingle (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"state ")
  NetInterfaceState
state' <- MParser NetInterfaceState
parseNetInterfaceState
  ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s.
(Ord e, Stream s, Token s ~ Char) =>
Parsec e s (Tokens s)
U.takeLine
  ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Maybe ())
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
MP.optional ParsecT Void Text Identity ()
parseLink
  [IpAddress 'Ipv4]
ipv4s' <- MParser [IpAddress 'Ipv4]
parseIpv4s
  [IpAddress 'Ipv6]
ipv6s' <- MParser [IpAddress 'Ipv6]
parseIpv6s

  pure
    $ MkNetInterface
      { $sel:device:MkNetInterface :: Device
device = Text -> Device
MkDevice Text
device',
        $sel:ntype:MkNetInterface :: Maybe NetInterfaceType
ntype = Maybe NetInterfaceType
forall a. Maybe a
Nothing,
        $sel:state:MkNetInterface :: NetInterfaceState
state = NetInterfaceState
state',
        $sel:name:MkNetInterface :: Maybe Text
name = Maybe Text
forall a. Maybe a
Nothing,
        $sel:ipv4s:MkNetInterface :: IpAddresses 'Ipv4
ipv4s = [IpAddress 'Ipv4] -> IpAddresses 'Ipv4
forall (a :: IpType). [IpAddress a] -> IpAddresses a
MkIpAddresses [IpAddress 'Ipv4]
ipv4s',
        $sel:ipv6s:MkNetInterface :: IpAddresses 'Ipv6
ipv6s = [IpAddress 'Ipv6] -> IpAddresses 'Ipv6
forall (a :: IpType). [IpAddress a] -> IpAddresses a
MkIpAddresses [IpAddress 'Ipv6]
ipv6s'
      }
{-# INLINEABLE parseInterface #-}

parseLink :: MParser ()
parseLink :: ParsecT Void Text Identity ()
parseLink = ParsecT Void Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"link" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
forall e s. (Ord e, Stream s, Token s ~ Char) => Parsec e s ()
U.takeLine_
{-# INLINEABLE parseLink #-}

parseIpv4s :: MParser [IpAddress Ipv4]
parseIpv4s :: MParser [IpAddress 'Ipv4]
parseIpv4s = Text
-> (Refined Ipv4Refinement Text -> IpAddress 'Ipv4)
-> MParser [IpAddress 'Ipv4]
forall p a.
Predicate p Text =>
Text -> (Refined p Text -> a) -> MParser [a]
parseIps Text
"inet " Refined Ipv4Refinement Text -> IpAddress 'Ipv4
Refined (IpRefinement 'Ipv4) Text -> IpAddress 'Ipv4
forall (a :: IpType). Refined (IpRefinement a) Text -> IpAddress a
MkIpAddress
{-# INLINEABLE parseIpv4s #-}

parseIpv6s :: MParser [IpAddress Ipv6]
parseIpv6s :: MParser [IpAddress 'Ipv6]
parseIpv6s = Text
-> (Refined Ipv6Refinement Text -> IpAddress 'Ipv6)
-> MParser [IpAddress 'Ipv6]
forall p a.
Predicate p Text =>
Text -> (Refined p Text -> a) -> MParser [a]
parseIps Text
"inet6 " Refined Ipv6Refinement Text -> IpAddress 'Ipv6
Refined (IpRefinement 'Ipv6) Text -> IpAddress 'Ipv6
forall (a :: IpType). Refined (IpRefinement a) Text -> IpAddress a
MkIpAddress
{-# INLINEABLE parseIpv6s #-}

parseIps :: (Predicate p Text) => Text -> (Refined p Text -> a) -> MParser [a]
parseIps :: forall p a.
Predicate p Text =>
Text -> (Refined p Text -> a) -> MParser [a]
parseIps Text
p Refined p Text -> a
cons = do
  [Text]
addrs <- Text -> MParser [Text]
parseAddresses Text
p
  let xs :: Either RefineException [Refined p Text]
xs = (Text -> Either RefineException (Refined p Text))
-> [Text] -> Either RefineException [Refined p Text]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either RefineException (Refined p Text)
forall {k} (p :: k) x.
Predicate p x =>
x -> Either RefineException (Refined p x)
R.refine [Text]
addrs
  case Either RefineException [Refined p Text]
xs of
    Left RefineException
ex ->
      let errMsg :: String
          errMsg :: String
errMsg =
            Text -> String
T.unpack
              (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Malformed ipv"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" address found: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showt [Text]
addrs
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Error: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RefineException -> Text
forall a. Show a => a -> Text
showt RefineException
ex
       in Set (ErrorFancy Void) -> MParser [a]
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
Set (ErrorFancy e) -> m a
MP.fancyFailure (Set (ErrorFancy Void) -> MParser [a])
-> Set (ErrorFancy Void) -> MParser [a]
forall a b. (a -> b) -> a -> b
$ [ErrorFancy Void] -> Set (ErrorFancy Void)
forall a. Ord a => [a] -> Set a
Set.fromList [String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail String
errMsg]
    Right [Refined p Text]
xss -> [a] -> MParser [a]
forall a. a -> ParsecT Void Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Refined p Text -> a
cons (Refined p Text -> a) -> [Refined p Text] -> [a]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Refined p Text]
xss)
{-# INLINEABLE parseIps #-}

parseAddresses :: Text -> MParser [Text]
parseAddresses :: Text -> MParser [Text]
parseAddresses = ParsecT Void Text Identity Text -> MParser [Text]
forall (m :: Type -> Type) a. MonadPlus m => m a -> m [a]
MP.many (ParsecT Void Text Identity Text -> MParser [Text])
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> MParser [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
address
  where
    address :: Tokens Text -> ParsecT Void Text Identity (Tokens Text)
address Tokens Text
p = do
      -- 'many' will fail if we partially consume any input. We do not want
      -- a failure because we may be able to parse it with a later parser
      -- (i.e. ipv4 partially matches, fails, but ipv6 would succeed). Thus
      -- we include try to backtrack and give the ipv6 parser a chance.
      ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity (Tokens Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
p
      ParsecT Void Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space
      Tokens Text
addr <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"address") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'/')
      Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MPC.char Char
Token Text
'/'
      ParsecT Void Text Identity ()
forall e s. (Ord e, Stream s, Token s ~ Char) => Parsec e s ()
U.takeLine_
      ParsecT Void Text Identity ()
lft
      pure Tokens Text
addr
{-# INLINEABLE parseAddresses #-}

lft :: MParser ()
lft :: ParsecT Void Text Identity ()
lft = do
  ParsecT Void Text Identity ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space
  Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"valid_lft"
  ParsecT Void Text Identity ()
forall e s. (Ord e, Stream s, Token s ~ Char) => Parsec e s ()
U.takeLine_
{-# INLINEABLE lft #-}

parseNetInterfaceState :: MParser NetInterfaceState
parseNetInterfaceState :: MParser NetInterfaceState
parseNetInterfaceState = do
  MParser NetInterfaceState -> MParser NetInterfaceState
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.try MParser NetInterfaceState
up
    MParser NetInterfaceState
-> MParser NetInterfaceState -> MParser NetInterfaceState
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> MParser NetInterfaceState
down
    MParser NetInterfaceState
-> MParser NetInterfaceState -> MParser NetInterfaceState
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> MParser NetInterfaceState
unknown
    MParser NetInterfaceState -> String -> MParser NetInterfaceState
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"state"
  where
    up :: MParser NetInterfaceState
up = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"UP" ParsecT Void Text Identity (Tokens Text)
-> NetInterfaceState -> MParser NetInterfaceState
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> NetInterfaceState
NetStateUp
    down :: MParser NetInterfaceState
down = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"DOWN" ParsecT Void Text Identity (Tokens Text)
-> NetInterfaceState -> MParser NetInterfaceState
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> NetInterfaceState
NetStateDown
    unknown :: MParser NetInterfaceState
unknown = Text -> NetInterfaceState
NetStateUnknown (Text -> NetInterfaceState)
-> ParsecT Void Text Identity Text -> MParser NetInterfaceState
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"type") (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace)
{-# INLINEABLE parseNetInterfaceState #-}