Query AWS region info of IPv4/IPv6

aws-ip-info.hs

#!/usr/bin/env runhaskell
{- cabal:
build-depends:
  aeson,
  attoparsec,
  attoparsec-aeson,
  base,
  bytestring,
  conduit,
  conduit-aeson,
  conduit-extra,
  deriving-aeson,
  ip == 1.7.*,
  http-conduit,
  optparse-applicative,
  optparse-generic,
  text,
-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -rtsopts #-}

module Main (main) where

-- base
import Control.Exception.Base (displayException)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty(..))
import Data.String (fromString)

-- aeson
import Data.Aeson.Text (encodeToLazyText)
import Data.Aeson.Types qualified as Aeson

-- attoparsec
import Data.Attoparsec.ByteString.Char8 qualified as Atto8
-- attoparsec-aeson
import Data.Aeson.Parser as AA

-- bytestring
import Data.ByteString as B (ByteString)

-- conduit
import Conduit
-- conduit-extra
import Data.Conduit.Attoparsec as Atto (ParseError(..), PositionRange, conduitParser)

-- deriving-aeson
import Deriving.Aeson

-- ip
import Net.IP qualified as IP
import Net.IPv4 qualified as IPv4 (contains)
import Net.IPv6 qualified as IPv6 (contains)
import Net.Types

-- http-conduit
import Network.HTTP.Simple (Request, httpSource, getResponseBody)

-- optparse-generic
import Options.Generic as Opt
-- optparse-applicative
import Options.Applicative.Builder as Opt
import Options.Applicative.Types as Opt

-- text
import Data.Text qualified as T
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy qualified as TL

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

type family SubnetType a
type instance SubnetType IPv4 = IPv4Range
type instance SubnetType IPv6 = IPv6Range

data SubnetDatum addrfamily = SubnetDatum
  { region :: String
  , service :: String
  , network_border_group :: String
  , subnet :: SubnetType addrfamily
  }
deriving stock instance Generic (SubnetDatum addrfamily)
deriving via RenameSubnetField IPv4 instance FromJSON (SubnetDatum IPv4)
deriving via RenameSubnetField IPv6 instance FromJSON (SubnetDatum IPv6)
deriving via RenameSubnetField IPv4 instance ToJSON (SubnetDatum IPv4)
deriving via RenameSubnetField IPv6 instance ToJSON (SubnetDatum IPv6)

type family RenameSubnetField af
type instance RenameSubnetField IPv4 = CustomJSON
  '[FieldLabelModifier (Rename "subnet" "ip_prefix")] (SubnetDatum IPv4)
type instance RenameSubnetField IPv6 = CustomJSON
  '[FieldLabelModifier (Rename "subnet" "ipv6_prefix")] (SubnetDatum IPv6)

data EntireResponse = EntireResponse
  { syncToken :: String -- int, but we don't care
  , createDate :: String -- date, in weird format ofcourse, whatever
  , subnetsV4 :: [SubnetDatum IPv4]
  , subnetsV6 :: [SubnetDatum IPv6]
  }
  deriving stock Generic
  deriving FromJSON via CustomJSON '[ FieldLabelModifier
    '[ Rename "subnetsV4" "prefixes"
     , Rename "subnetsV6" "ipv6_prefixes"
     ]
   ] EntireResponse

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

instance ParseField IP where
  metavar _ = "IP_ADDR"
  readField = Opt.readerAsk >>= maybe noparse pure . IP.decode . fromString
    where noparse = readerError "Didn't parse one of arguments as IPv4 or IPv6"

main :: IO ()
main = Opt.getRecord synopsis >>= runFullInMem
  where
    synopsis = "Fetch AWS region info about IPv4 or IPv6 addresses"

-- | https://docs.aws.amazon.com/vpc/latest/userguide/aws-ip-ranges.html
dataUrl :: Request
dataUrl = "https://ip-ranges.amazonaws.com/ip-ranges.json"

-- TODO make it run in constant memory?
runFullInMem :: NonEmpty IP -> IO ()
runFullInMem args
  = runConduitRes
  $ httpSource dataUrl getResponseBody
 .| conduitParser respSubnets
 .| mapC snd -- ignore positions of succeeding parses
 .| concatC
 .| filterC (interesting . eitherSubnet)
 .| mapC (either encodeToLazyText encodeToLazyText)
 .| mapC (encodeUtf8 . TL.toStrict . (<> "\n"))
 .| stdoutC
  where
    matches :: EitherSubnet -> IP -> Bool
    matches erange = IP.case_
      (either IPv4.contains never erange)
      (either never IPv6.contains erange)
    never = const $ const False
    interesting range = any (matches range) args

respSubnets :: Atto8.Parser [EitherDatum]
respSubnets = attoParseJsonStrict <&> \EntireResponse{..} ->
  map Left subnetsV4 <> map Right subnetsV6

attoParseJsonStrict :: FromJSON j => Atto8.Parser j
attoParseJsonStrict = AA.value' >>= \v ->
  case Aeson.parse Aeson.parseJSON v of
    Aeson.Error err -> fail err
    Aeson.Success x -> pure x

eitherSubnet :: EitherDatum -> EitherSubnet
eitherSubnet = either (Left . subnet) (Right . subnet)
type EitherDatum = Either (SubnetDatum IPv4) (SubnetDatum IPv6)
type EitherSubnet = Either IPv4Range IPv6Range

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

{-
:main 13.52.171.229 2a05:d07a:a000::1:2:3
{"region":"us-west-1","service":"AMAZON","network_border_group":"us-west-1","ip_prefix":"13.52.0.0/16"}
{"region":"us-west-1","service":"EC2","network_border_group":"us-west-1","ip_prefix":"13.52.0.0/16"}
{"region":"eu-south-1","service":"AMAZON","network_border_group":"eu-south-1","ipv6_prefix":"2a05:d07a:a000::/40"}
{"region":"eu-south-1","service":"S3","network_border_group":"eu-south-1","ipv6_prefix":"2a05:d07a:a000::/40"}
-}