URLGenerator.hs

#! /usr/bin/env stack
-- stack --resolver lts-3.13 --install-ghc runghc --package base --package bytestring --package iso3166-country-codes --package lens --package QuickCheck --package syb --package tagged --package uri-bytestring

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module URLGenerator (main) where

-- All of the code paths, none of the access logs.™
--
--
-- % ./URLGenerator.hs | head -n4
-- http://onionoo.local:8080/summary?type=bRIdgE&country=sy&last_seen_days=0-9&order=coNsENSuS_WeigHt&limit=1
-- http://onionoo.local:8080/weights?type=reLaY&country=qA&flag=VAlID&first_seen_days=4&family=Fe1EbE2eCC6a7e9C5e35452115a2FD6DDD21EcC5&fields=middle_probability%2Cexit_addresses%2Cexit_policy_v6_summary&order=CoNSeNsuS_weIGHt
-- http://onionoo.local:8080/summary?type=relAy&family=Dd8f1f52d9E445C1afAae8f8eBAECEe7f3c43db7&limit=-26
-- http://onionoo.local:8080/summary?running=tRuE&lookup=8628e2b4A542F6825E85CB1b9aD7E822F94a5699&country=Sz&flag=V2diR&contact=6%2F%7Clt%27NfR%2F%20.XE6%20S%5E%3Dd%2F%2CX%2BE&family=EE34ab7b28cAc1A52CABaFFe75c51ACCd71ee3ba&offset=-18

import Control.Lens ((<&>), (<>~), (&), (%~), both)
import Control.Monad (forever)
import Data.ByteString.Builder (hPutBuilder)
import Data.ByteString.Char8 (pack)
import Data.Char (toUpper, toLower, chr)
import Data.Data (Proxy(..), Data)
import Data.Generics.Text (gshow)
import Data.ISO3166_CountryCodes (CountryCode(..))
import Data.Int (Int64)
import Data.List (intercalate)
import Data.Tagged (Tagged(..))
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal, Nat, KnownNat, natVal)
import System.IO (stdout)
import Test.QuickCheck
import URI.ByteString (URI(..), uriPathL, uriQueryL, queryPairsL, serializeURI, parseURI, laxURIParserOptions)

data Type = Relay | Bridge deriving (Bounded, Enum, Show)

instance Arbitrary Type where arbitrary = arbitraryBoundedEnum

-- I should implement 'search' here, but I can't be bothered right now.

newtype Fingerprint = Fingerprint { getFingerprint :: String }

instance Show Fingerprint where show = getFingerprint

instance Arbitrary Fingerprint where
  arbitrary = fmap Fingerprint . vectorOf 40 $ oneof 
    [ choose ('A', 'F')
    , choose ('1', '9')
    ]

instance Arbitrary CountryCode where arbitrary = arbitraryBoundedEnum

newtype ASN = ASN { getASN :: NonNegative Int64 }

instance Show ASN where show = ("AS" ++) . show . getNonNegative . getASN

instance Arbitrary ASN where arbitrary = ASN <$> arbitrary

data Flag = Authority
          | BadExit
          | Exit
          | Fast
          | Guard
          | HSDir
          | Running
          | Stable
          | V2Dir
          | Valid
  deriving (Bounded, Enum, Show)

instance Arbitrary Flag where arbitrary = arbitraryBoundedEnum

type Days = NonNegative Int

data XSeenDays = XSeenBetween Days Days
               | XSeenAtLeast Days
               | XSeenAtMost Days

instance Show XSeenDays where
  show (NonNegative x `XSeenBetween` NonNegative y) = show x ++ "-" ++ show y
  show (XSeenAtLeast (NonNegative x)) = show x
  show (XSeenAtMost (NonNegative y)) = "-" ++ show y

instance Arbitrary XSeenDays where
  arbitrary = oneof
    [ uncurry XSeenBetween <$> arbitrary `suchThat` \(x, y) -> x <= y
    , XSeenAtLeast <$> arbitrary
    , XSeenAtMost <$> arbitrary
    ]

newtype Contact = Contact { getContact :: String }

instance Arbitrary Contact where
  arbitrary = fmap (Contact . map chr) . listOf1 $ choose (32, 126)

instance Show Contact where show = getContact

data Field = Field_Advertised_Bandwidth
           | Field_Alleged_Family
           | Field_As_Name
           | Field_As_Number
           | Field_Bandwidth_Burst
           | Field_Bandwidth_Rate
           | Field_City_Name
           | Field_Consensus_Weight
           | Field_Consensus_Weight_Fraction
           | Field_Contact
           | Field_Country
           | Field_Country_Name
           | Field_Dir_Address
           | Field_Effective_Family
           | Field_Exit_Addresses
           | Field_Exit_Policy
           | Field_Exit_Policy_Summary
           | Field_Exit_Policy_V6_Summary
           | Field_Exit_Probability
           | Field_Family
           | Field_Fingerprint
           | Field_First_Seen
           | Field_Flags
           | Field_Guard_Probability
           | Field_Hashed_Fingerprint
           | Field_Hibernating
           | Field_Host_Name
           | Field_Indirect_Family
           | Field_Last_Changed_Address_Or_Port
           | Field_Last_Restarted
           | Field_Last_Seen
           | Field_Latitude
           | Field_Longitude
           | Field_Measured
           | Field_Middle_Probability
           | Field_Nickname
           | Field_Observed_Bandwidth
           | Field_Or_Addresses
           | Field_Platform
           | Field_Recommended_Version
           | Field_Region_Name
           | Field_Running
           | Field_Transports -- :%!gawk#<3
  deriving (Data, Bounded, Enum)

instance Show Field where show = init . drop 7 . gshow

instance Arbitrary Field where arbitrary = arbitraryBoundedEnum

newtype Fields = Fields { getFields :: [Field] }

instance Show Fields where show = intercalate "," . map show . getFields

instance Arbitrary Fields where arbitrary = Fields <$> arbitrary

data Order = AscendingConsensusWeight
           | DescendingConsensusWeight 
  deriving (Bounded, Enum)

instance Show Order where
  show AscendingConsensusWeight = "consensus_weight"
  show DescendingConsensusWeight = "-" ++ show AscendingConsensusWeight

instance Arbitrary Order where arbitrary = arbitraryBoundedEnum

newtype CaseInsensitive a = CaseInsensitive { getCaseInsensitive :: Tagged a String }

instance (Arbitrary a, Show a) => Arbitrary (CaseInsensitive a) where
  arbitrary = fmap (CaseInsensitive . Tagged) 
            . mapM (\c -> elements [toUpper c, toLower c])
          =<< show <$> (arbitrary :: Gen a) 

instance Show (CaseInsensitive a) where show = unTagged . getCaseInsensitive

newtype LowerCase a = LowerCase { getLowerCase :: Tagged a String }

instance (Arbitrary a, Show a) => Arbitrary (LowerCase a) where
  arbitrary = LowerCase . Tagged . map toLower . show
          <$> (arbitrary :: Gen a)

instance Show (LowerCase a) where show = unTagged . getLowerCase

data Param (s :: Symbol) (a :: *)
data Bias (n :: Nat) (a :: *)
data a :| b; infixr 9 :|
data (a :: k) :> (b :: *); infixr 8 :>
data Response

class Generator layout where
  generator :: Proxy layout -> (Gen URI -> Gen URI)

instance KnownSymbol path => Generator path where
  generator _ accum = accum <&> uriPathL <>~ pack (symbolVal (Proxy :: Proxy path))

instance (KnownSymbol k, Arbitrary t, Show t) => Generator (Param k t) where
  generator _ accum = arbitrary >>= \(v :: t) -> accum <&> uriQueryL . queryPairsL
    <>~ [(symbolVal (Proxy :: Proxy k), show v) & both %~ pack]

instance (Generator head, Generator tail) => Generator (head :> tail) where
  generator _ accum = generator
    (Proxy :: Proxy tail)
    (generator (Proxy :: Proxy head) accum)

instance (Generator a, Generator b) => Generator (a :| b) where
  generator _ accum = oneof
    [ generator (Proxy :: Proxy a) accum
    , generator (Proxy :: Proxy b) accum
    ]

-- Requests including many parameters are often specific enough that they'll
-- yield no results, and I assume are non-representative of regular traffic
-- and/or codepaths. Here we provide facility to dampen their frequencies..
instance (KnownNat n, Generator t) => Generator (Bias n t) where
  generator _ accum = frequency 
    [ (10-p , accum)
    , (p    , generator (Proxy :: Proxy t) accum)
    ] where p = fromInteger $ natVal (Proxy :: Proxy n)

instance Generator Response where
  generator = const id

type Onionoo = "summary" :| "details" :| "bandwidth" :| "weights" :| "clients" :| "uptime"
            :> Bias 3 (Param "type" (CaseInsensitive Type))
            :> Bias 3 (Param "running" (CaseInsensitive Bool))
            -- (search)
            :> Bias 1 (Param "lookup" (CaseInsensitive Fingerprint))
            :> Bias 1 (Param "fingerprint" (CaseInsensitive Fingerprint))
            :> Bias 3 (Param "country" (CaseInsensitive CountryCode))
            :> Bias 3 (Param "as" ASN)
            :> Bias 3 (Param "flag" (CaseInsensitive Flag))
            :> Bias 3 (Param "first_seen_days" XSeenDays)
            :> Bias 3 (Param "last_seen_days" XSeenDays)
            :> Bias 1 (Param "contact" Contact)
            :> Bias 3 (Param "family" (CaseInsensitive Fingerprint))
            :> Bias 3 (Param "fields" (CaseInsensitive Fields))
            :> Bias 3 (Param "order" (CaseInsensitive Order))
            :> Bias 3 (Param "offset" Int)
            :> Bias 3 (Param "limit" Int)
            :> Response

main :: IO ()
main = do
  let Right onionoo = parseURI laxURIParserOptions "http://onionoo.local:8080/"
      generateURL = generate $ (Proxy :: Proxy Onionoo) `generator` pure onionoo
  forever $ generateURL >>= hPutBuilder stdout . serializeURI >> putChar '\n'