{-# Language PatternSynonyms #-}
{-|
Module      : Hookup.Socks5
Description : SOCKS5 network protocol implementation
Copyright   : (c) Eric Mertens, 2018
License     : ISC
Maintainer  : emertens@gmail.com

This module provides types, parsers, and builders for the messages
used in the SOCKS5 protocol. See <https://tools.ietf.org/html/rfc1928>
-}
module Hookup.Socks5

  ( -- * Client hello message
    ClientHello(..)
  , buildClientHello
  , parseClientHello

  -- * Server hello message
  , ServerHello(..)
  , buildServerHello
  , parseServerHello

  -- * Command request message
  , Request(..)
  , buildRequest
  , parseRequest

  -- * Command response message
  , Response(..)
  , buildResponse
  , parseResponse

  -- * Network address types
  , Address(..)
  , Host(..)

  -- * Authentication methods
  , AuthMethod
      ( AuthNoAuthenticationRequired
      , AuthGssApi
      , AuthUsernamePassword
      , AuthNoAcceptableMethods )

  -- * Commands
  , Command
      ( Connect
      , Bind
      , UdpAssociate )

  -- * Command reply codes
  , CommandReply
      ( CommandReply
      , Succeeded
      , GeneralFailure
      , NotAllowed
      , NetUnreachable
      , HostUnreachable
      , ConnectionRefused
      , TTLExpired
      , CmdNotSupported
      , AddrNotSupported )

  )
  where

import           Control.Monad              (replicateM)
import           Data.Attoparsec.ByteString (Parser)
import           Data.ByteString            (ByteString)
import           Data.ByteString.Builder    (Builder)
import           Data.Word                  (Word8, Word16)
import           Network.Socket             (HostAddress, HostAddress6, PortNumber,
                                             hostAddressToTuple, hostAddress6ToTuple,
                                             tupleToHostAddress, tupleToHostAddress6)
import qualified Data.Attoparsec.ByteString as Parser
import qualified Data.ByteString            as B
import qualified Data.ByteString.Builder    as Builder
import qualified Data.ByteString.Lazy       as L

-- | SOCKS authentication methods
newtype AuthMethod                      = AuthMethod Word8 deriving (AuthMethod -> AuthMethod -> Bool
(AuthMethod -> AuthMethod -> Bool)
-> (AuthMethod -> AuthMethod -> Bool) -> Eq AuthMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthMethod -> AuthMethod -> Bool
$c/= :: AuthMethod -> AuthMethod -> Bool
== :: AuthMethod -> AuthMethod -> Bool
$c== :: AuthMethod -> AuthMethod -> Bool
Eq, Int -> AuthMethod -> ShowS
[AuthMethod] -> ShowS
AuthMethod -> String
(Int -> AuthMethod -> ShowS)
-> (AuthMethod -> String)
-> ([AuthMethod] -> ShowS)
-> Show AuthMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthMethod] -> ShowS
$cshowList :: [AuthMethod] -> ShowS
show :: AuthMethod -> String
$cshow :: AuthMethod -> String
showsPrec :: Int -> AuthMethod -> ShowS
$cshowsPrec :: Int -> AuthMethod -> ShowS
Show)

pattern AuthNoAuthenticationRequired, AuthGssApi, AuthUsernamePassword, AuthNoAcceptableMethods :: AuthMethod

pattern $bAuthNoAuthenticationRequired :: AuthMethod
$mAuthNoAuthenticationRequired :: forall r. AuthMethod -> (Void# -> r) -> (Void# -> r) -> r
AuthNoAuthenticationRequired    = AuthMethod 0x00
pattern $bAuthGssApi :: AuthMethod
$mAuthGssApi :: forall r. AuthMethod -> (Void# -> r) -> (Void# -> r) -> r
AuthGssApi                      = AuthMethod 0x01
pattern $bAuthUsernamePassword :: AuthMethod
$mAuthUsernamePassword :: forall r. AuthMethod -> (Void# -> r) -> (Void# -> r) -> r
AuthUsernamePassword            = AuthMethod 0x02
pattern $bAuthNoAcceptableMethods :: AuthMethod
$mAuthNoAcceptableMethods :: forall r. AuthMethod -> (Void# -> r) -> (Void# -> r) -> r
AuthNoAcceptableMethods         = AuthMethod 0xFF

-- | SOCKS client commands
newtype Command                         = Command Word8 deriving (Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

pattern Connect, Bind, UdpAssociate :: Command

pattern $bConnect :: Command
$mConnect :: forall r. Command -> (Void# -> r) -> (Void# -> r) -> r
Connect                         = Command 1
pattern $bBind :: Command
$mBind :: forall r. Command -> (Void# -> r) -> (Void# -> r) -> r
Bind                            = Command 2
pattern $bUdpAssociate :: Command
$mUdpAssociate :: forall r. Command -> (Void# -> r) -> (Void# -> r) -> r
UdpAssociate                    = Command 3

-- | Tags used in the protocol messages for encoded 'Host' values
newtype HostTag                         = HostTag Word8 deriving (HostTag -> HostTag -> Bool
(HostTag -> HostTag -> Bool)
-> (HostTag -> HostTag -> Bool) -> Eq HostTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HostTag -> HostTag -> Bool
$c/= :: HostTag -> HostTag -> Bool
== :: HostTag -> HostTag -> Bool
$c== :: HostTag -> HostTag -> Bool
Eq, Int -> HostTag -> ShowS
[HostTag] -> ShowS
HostTag -> String
(Int -> HostTag -> ShowS)
-> (HostTag -> String) -> ([HostTag] -> ShowS) -> Show HostTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HostTag] -> ShowS
$cshowList :: [HostTag] -> ShowS
show :: HostTag -> String
$cshow :: HostTag -> String
showsPrec :: Int -> HostTag -> ShowS
$cshowsPrec :: Int -> HostTag -> ShowS
Show)

pattern IPv4Tag, DomainNameTag, IPv6Tag :: HostTag

pattern $bIPv4Tag :: HostTag
$mIPv4Tag :: forall r. HostTag -> (Void# -> r) -> (Void# -> r) -> r
IPv4Tag                         = HostTag 1
pattern $bDomainNameTag :: HostTag
$mDomainNameTag :: forall r. HostTag -> (Void# -> r) -> (Void# -> r) -> r
DomainNameTag                   = HostTag 3
pattern $bIPv6Tag :: HostTag
$mIPv6Tag :: forall r. HostTag -> (Void# -> r) -> (Void# -> r) -> r
IPv6Tag                         = HostTag 4

-- | SOCKS command reply codes
newtype CommandReply                    = CommandReply Word8 deriving (CommandReply -> CommandReply -> Bool
(CommandReply -> CommandReply -> Bool)
-> (CommandReply -> CommandReply -> Bool) -> Eq CommandReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandReply -> CommandReply -> Bool
$c/= :: CommandReply -> CommandReply -> Bool
== :: CommandReply -> CommandReply -> Bool
$c== :: CommandReply -> CommandReply -> Bool
Eq, Int -> CommandReply -> ShowS
[CommandReply] -> ShowS
CommandReply -> String
(Int -> CommandReply -> ShowS)
-> (CommandReply -> String)
-> ([CommandReply] -> ShowS)
-> Show CommandReply
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommandReply] -> ShowS
$cshowList :: [CommandReply] -> ShowS
show :: CommandReply -> String
$cshow :: CommandReply -> String
showsPrec :: Int -> CommandReply -> ShowS
$cshowsPrec :: Int -> CommandReply -> ShowS
Show)

pattern Succeeded, GeneralFailure, NotAllowed, NetUnreachable, HostUnreachable,
  ConnectionRefused, TTLExpired, CmdNotSupported, AddrNotSupported :: CommandReply

pattern $bSucceeded :: CommandReply
$mSucceeded :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
Succeeded                       = CommandReply 0
pattern $bGeneralFailure :: CommandReply
$mGeneralFailure :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
GeneralFailure                  = CommandReply 1
pattern $bNotAllowed :: CommandReply
$mNotAllowed :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
NotAllowed                      = CommandReply 2
pattern $bNetUnreachable :: CommandReply
$mNetUnreachable :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
NetUnreachable                  = CommandReply 3
pattern $bHostUnreachable :: CommandReply
$mHostUnreachable :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
HostUnreachable                 = CommandReply 4
pattern $bConnectionRefused :: CommandReply
$mConnectionRefused :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
ConnectionRefused               = CommandReply 5
pattern $bTTLExpired :: CommandReply
$mTTLExpired :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
TTLExpired                      = CommandReply 6
pattern $bCmdNotSupported :: CommandReply
$mCmdNotSupported :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
CmdNotSupported                 = CommandReply 7
pattern $bAddrNotSupported :: CommandReply
$mAddrNotSupported :: forall r. CommandReply -> (Void# -> r) -> (Void# -> r) -> r
AddrNotSupported                = CommandReply 8

-- | Network host and port number
data Address = Address Host PortNumber
  deriving Int -> Address -> ShowS
[Address] -> ShowS
Address -> String
(Int -> Address -> ShowS)
-> (Address -> String) -> ([Address] -> ShowS) -> Show Address
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Address] -> ShowS
$cshowList :: [Address] -> ShowS
show :: Address -> String
$cshow :: Address -> String
showsPrec :: Int -> Address -> ShowS
$cshowsPrec :: Int -> Address -> ShowS
Show

-- | Network host identified by address or domain name.
data Host
  = IPv4 HostAddress      -- ^ IPv4 host address
  | IPv6 HostAddress6     -- ^ IPv6 host address
  | DomainName ByteString -- ^ Domain name (maximum length 255)
  deriving Int -> Host -> ShowS
[Host] -> ShowS
Host -> String
(Int -> Host -> ShowS)
-> (Host -> String) -> ([Host] -> ShowS) -> Show Host
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> String
$cshow :: Host -> String
showsPrec :: Int -> Host -> ShowS
$cshowsPrec :: Int -> Host -> ShowS
Show


-- | Initial SOCKS sent by client with proposed list of authentication methods.
newtype ClientHello = ClientHello
  { ClientHello -> [AuthMethod]
cHelloMethods :: [AuthMethod] -- ^ proposed methods (maximum length 255)
  }
  deriving Int -> ClientHello -> ShowS
[ClientHello] -> ShowS
ClientHello -> String
(Int -> ClientHello -> ShowS)
-> (ClientHello -> String)
-> ([ClientHello] -> ShowS)
-> Show ClientHello
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientHello] -> ShowS
$cshowList :: [ClientHello] -> ShowS
show :: ClientHello -> String
$cshow :: ClientHello -> String
showsPrec :: Int -> ClientHello -> ShowS
$cshowsPrec :: Int -> ClientHello -> ShowS
Show

-- | Initial SOCKS sent by server with chosen authentication method.
newtype ServerHello = ServerHello
  { ServerHello -> AuthMethod
sHelloMethod  :: AuthMethod
  }
  deriving Int -> ServerHello -> ShowS
[ServerHello] -> ShowS
ServerHello -> String
(Int -> ServerHello -> ShowS)
-> (ServerHello -> String)
-> ([ServerHello] -> ShowS)
-> Show ServerHello
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerHello] -> ShowS
$cshowList :: [ServerHello] -> ShowS
show :: ServerHello -> String
$cshow :: ServerHello -> String
showsPrec :: Int -> ServerHello -> ShowS
$cshowsPrec :: Int -> ServerHello -> ShowS
Show

-- | Client message used to request a network operation from the SOCKS server.
data Request = Request
  { Request -> Command
reqCommand :: Command
  , Request -> Address
reqAddress :: Address
  }
  deriving Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> String
$cshow :: Request -> String
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show

-- | Server message used to indicate result of client's request.
data Response = Response
  { Response -> CommandReply
rspReply   :: CommandReply
  , Response -> Address
rspAddress :: Address
  }
  deriving Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show

-- | Transform a 'Builder' into a strict 'ByteString'
runBuilder :: Builder -> ByteString
runBuilder :: Builder -> ByteString
runBuilder = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Builder.toLazyByteString

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

buildCommand :: Command -> Builder
buildCommand :: Command -> Builder
buildCommand (Command Word8
c) = Word8 -> Builder
Builder.word8 Word8
c

parseCommand :: Parser Command
parseCommand :: Parser Command
parseCommand = Word8 -> Command
Command (Word8 -> Command) -> Parser ByteString Word8 -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
Parser.anyWord8

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

buildHost :: Host -> Builder
buildHost :: Host -> Builder
buildHost (IPv4 HostAddress
hostAddr) = HostTag -> Builder
buildHostTag HostTag
IPv4Tag       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HostAddress -> Builder
buildHostAddress  HostAddress
hostAddr
buildHost (IPv6 HostAddress6
hostAddr) = HostTag -> Builder
buildHostTag HostTag
IPv6Tag       Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> HostAddress6 -> Builder
buildHostAddress6 HostAddress6
hostAddr
buildHost (DomainName ByteString
dn) = HostTag -> Builder
buildHostTag HostTag
DomainNameTag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
buildDomainName ByteString
dn

parseHost :: Parser Host
parseHost :: Parser Host
parseHost =
  do HostTag
tag <- Parser HostTag
parseHostTag
     case HostTag
tag of
       HostTag
IPv4Tag       -> HostAddress -> Host
IPv4       (HostAddress -> Host)
-> Parser ByteString HostAddress -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString HostAddress
parseHostAddress
       HostTag
IPv6Tag       -> HostAddress6 -> Host
IPv6       (HostAddress6 -> Host)
-> Parser ByteString HostAddress6 -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString HostAddress6
parseHostAddress6
       HostTag
DomainNameTag -> ByteString -> Host
DomainName (ByteString -> Host) -> Parser ByteString ByteString -> Parser Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
parseDomainName
       HostTag
_             -> String -> Parser Host
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad address tag"

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

buildAddress :: Address -> Builder
buildAddress :: Address -> Builder
buildAddress (Address Host
host PortNumber
port) = Host -> Builder
buildHost Host
host Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Builder
buildPort PortNumber
port

parseAddress :: Parser Address
parseAddress :: Parser Address
parseAddress = Host -> PortNumber -> Address
Address (Host -> PortNumber -> Address)
-> Parser Host -> Parser ByteString (PortNumber -> Address)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Host
parseHost Parser ByteString (PortNumber -> Address)
-> Parser ByteString PortNumber -> Parser Address
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString PortNumber
parsePort

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

buildHostTag :: HostTag -> Builder
buildHostTag :: HostTag -> Builder
buildHostTag (HostTag Word8
tag) = Word8 -> Builder
Builder.word8 Word8
tag

parseHostTag :: Parser HostTag
parseHostTag :: Parser HostTag
parseHostTag = Word8 -> HostTag
HostTag (Word8 -> HostTag) -> Parser ByteString Word8 -> Parser HostTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
Parser.anyWord8

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

buildHostAddress :: HostAddress -> Builder
buildHostAddress :: HostAddress -> Builder
buildHostAddress HostAddress
hostAddr =
  case HostAddress -> (Word8, Word8, Word8, Word8)
hostAddressToTuple HostAddress
hostAddr of
    (Word8
a1,Word8
a2,Word8
a3,Word8
a4) -> (Word8 -> Builder) -> [Word8] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> Builder
Builder.word8 [Word8
a1,Word8
a2,Word8
a3,Word8
a4]

parseHostAddress :: Parser HostAddress
parseHostAddress :: Parser ByteString HostAddress
parseHostAddress =
  do [Word8
a1,Word8
a2,Word8
a3,Word8
a4] <- Int -> Parser ByteString Word8 -> Parser ByteString [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 Parser ByteString Word8
Parser.anyWord8
     HostAddress -> Parser ByteString HostAddress
forall (m :: * -> *) a. Monad m => a -> m a
return (HostAddress -> Parser ByteString HostAddress)
-> HostAddress -> Parser ByteString HostAddress
forall a b. (a -> b) -> a -> b
$! (Word8, Word8, Word8, Word8) -> HostAddress
tupleToHostAddress (Word8
a1,Word8
a2,Word8
a3,Word8
a4)

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

buildHostAddress6 :: HostAddress6 -> Builder
buildHostAddress6 :: HostAddress6 -> Builder
buildHostAddress6 HostAddress6
hostAddr =
  case HostAddress6
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
hostAddress6ToTuple HostAddress6
hostAddr of
    (Word16
a1,Word16
a2,Word16
a3,Word16
a4,Word16
a5,Word16
a6,Word16
a7,Word16
a8) ->
      (Word16 -> Builder) -> [Word16] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word16 -> Builder
Builder.word16BE [Word16
a1,Word16
a2,Word16
a3,Word16
a4,Word16
a5,Word16
a6,Word16
a7,Word16
a8]

parseHostAddress6 :: Parser HostAddress6
parseHostAddress6 :: Parser ByteString HostAddress6
parseHostAddress6 =
  do [Word16
a1,Word16
a2,Word16
a3,Word16
a4,Word16
a5,Word16
a6,Word16
a7,Word16
a8] <- Int -> Parser ByteString Word16 -> Parser ByteString [Word16]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 Parser ByteString Word16
parseWord16BE
     HostAddress6 -> Parser ByteString HostAddress6
forall (m :: * -> *) a. Monad m => a -> m a
return (HostAddress6 -> Parser ByteString HostAddress6)
-> HostAddress6 -> Parser ByteString HostAddress6
forall a b. (a -> b) -> a -> b
$! (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
-> HostAddress6
tupleToHostAddress6 (Word16
a1,Word16
a2,Word16
a3,Word16
a4,Word16
a5,Word16
a6,Word16
a7,Word16
a8)

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

buildDomainName :: ByteString -> Builder
buildDomainName :: ByteString -> Builder
buildDomainName ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = Word8 -> Builder
Builder.word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                        ByteString -> Builder
Builder.byteString ByteString
bs
  | Bool
otherwise = String -> Builder
forall a. HasCallStack => String -> a
error String
"SOCKS5 domain name too long"

parseDomainName :: Parser ByteString
parseDomainName :: Parser ByteString ByteString
parseDomainName =
  do Word8
len <- Parser ByteString Word8
Parser.anyWord8
     Int -> Parser ByteString ByteString
Parser.take (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len)

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

buildPort :: PortNumber -> Builder
buildPort :: PortNumber -> Builder
buildPort PortNumber
port = Word16 -> Builder
Builder.word16BE (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)

parsePort :: Parser PortNumber
parsePort :: Parser ByteString PortNumber
parsePort = Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber)
-> Parser ByteString Word16 -> Parser ByteString PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
parseWord16BE

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

buildVersion :: Builder
buildVersion :: Builder
buildVersion = Word8 -> Builder
Builder.word8 Word8
5

parseVersion :: Parser ()
parseVersion :: Parser ()
parseVersion = () () -> Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Word8 -> Parser ByteString Word8
Parser.word8 Word8
5

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

buildAuthMethod :: AuthMethod -> Builder
buildAuthMethod :: AuthMethod -> Builder
buildAuthMethod (AuthMethod Word8
x) = Word8 -> Builder
Builder.word8 Word8
x

parseAuthMethod :: Parser AuthMethod
parseAuthMethod :: Parser AuthMethod
parseAuthMethod = Word8 -> AuthMethod
AuthMethod (Word8 -> AuthMethod)
-> Parser ByteString Word8 -> Parser AuthMethod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
Parser.anyWord8

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

buildReply :: CommandReply -> Builder
buildReply :: CommandReply -> Builder
buildReply (CommandReply Word8
x) = Word8 -> Builder
Builder.word8 Word8
x

parseReply :: Parser CommandReply
parseReply :: Parser CommandReply
parseReply = Word8 -> CommandReply
CommandReply (Word8 -> CommandReply)
-> Parser ByteString Word8 -> Parser CommandReply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
Parser.anyWord8

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

buildReserved :: Builder
buildReserved :: Builder
buildReserved = Word8 -> Builder
Builder.word8 Word8
0

parseReserved :: Parser ()
parseReserved :: Parser ()
parseReserved = () () -> Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString Word8
Parser.anyWord8

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

-- | Build a list of buildable things prefixing the length of the list
-- as a single byte. The list must not be longer than 255 elements.
buildListOf :: (a -> Builder) -> [a] -> Builder
buildListOf :: (a -> Builder) -> [a] -> Builder
buildListOf a -> Builder
builder [a]
xs
  | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 = Word8 -> Builder
Builder.word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                      (a -> Builder) -> [a] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Builder
builder [a]
xs
  | Bool
otherwise       = String -> Builder
forall a. HasCallStack => String -> a
error String
"buildListOf: list too long"

-- | Parse a list of parsable things where the length of the list
-- is encoded as a single byte before the items to be parsed.
parseListOf :: Parser a -> Parser [a]
parseListOf :: Parser a -> Parser [a]
parseListOf Parser a
parser =
  do Word8
n <- Parser ByteString Word8
Parser.anyWord8
     Int -> Parser a -> Parser [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Parser a
parser

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

buildClientHello :: ClientHello -> ByteString
buildClientHello :: ClientHello -> ByteString
buildClientHello ClientHello
msg =
  Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  (AuthMethod -> Builder) -> [AuthMethod] -> Builder
forall a. (a -> Builder) -> [a] -> Builder
buildListOf AuthMethod -> Builder
buildAuthMethod (ClientHello -> [AuthMethod]
cHelloMethods ClientHello
msg)

parseClientHello :: Parser ClientHello
parseClientHello :: Parser ClientHello
parseClientHello =
  [AuthMethod] -> ClientHello
ClientHello
    ([AuthMethod] -> ClientHello)
-> Parser () -> Parser ByteString ([AuthMethod] -> ClientHello)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    Parser ByteString ([AuthMethod] -> ClientHello)
-> Parser ByteString [AuthMethod] -> Parser ClientHello
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser AuthMethod -> Parser ByteString [AuthMethod]
forall a. Parser a -> Parser [a]
parseListOf Parser AuthMethod
parseAuthMethod

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

buildServerHello :: ServerHello -> ByteString
buildServerHello :: ServerHello -> ByteString
buildServerHello ServerHello
msg =
  Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  AuthMethod -> Builder
buildAuthMethod (ServerHello -> AuthMethod
sHelloMethod ServerHello
msg)

parseServerHello :: Parser ServerHello
parseServerHello :: Parser ServerHello
parseServerHello =
  AuthMethod -> ServerHello
ServerHello
    (AuthMethod -> ServerHello)
-> Parser () -> Parser ByteString (AuthMethod -> ServerHello)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    Parser ByteString (AuthMethod -> ServerHello)
-> Parser AuthMethod -> Parser ServerHello
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser AuthMethod
parseAuthMethod

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

buildRequest :: Request -> ByteString
buildRequest :: Request -> ByteString
buildRequest Request
req =
  Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Command -> Builder
buildCommand  (Request -> Command
reqCommand  Request
req) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Builder
buildReserved                   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Address -> Builder
buildAddress  (Request -> Address
reqAddress  Request
req)

parseRequest :: Parser Request
parseRequest :: Parser Request
parseRequest =
  Command -> Address -> Request
Request
    (Command -> Address -> Request)
-> Parser () -> Parser ByteString (Command -> Address -> Request)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    Parser ByteString (Command -> Address -> Request)
-> Parser Command -> Parser ByteString (Address -> Request)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command
parseCommand
    Parser ByteString (Address -> Request)
-> Parser () -> Parser ByteString (Address -> Request)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser ()
parseReserved
    Parser ByteString (Address -> Request)
-> Parser Address -> Parser Request
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Address
parseAddress

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

buildResponse :: Response -> ByteString
buildResponse :: Response -> ByteString
buildResponse Response
msg =
  Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion                  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  CommandReply -> Builder
buildReply   (Response -> CommandReply
rspReply   Response
msg) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Builder
buildReserved                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Address -> Builder
buildAddress (Response -> Address
rspAddress Response
msg)

parseResponse :: Parser Response
parseResponse :: Parser Response
parseResponse =
  CommandReply -> Address -> Response
Response
    (CommandReply -> Address -> Response)
-> Parser ()
-> Parser ByteString (CommandReply -> Address -> Response)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    Parser ByteString (CommandReply -> Address -> Response)
-> Parser CommandReply -> Parser ByteString (Address -> Response)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser CommandReply
parseReply
    Parser ByteString (Address -> Response)
-> Parser () -> Parser ByteString (Address -> Response)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser ()
parseReserved
    Parser ByteString (Address -> Response)
-> Parser Address -> Parser Response
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Address
parseAddress

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

-- | Match a 16-bit, big-endian word.
parseWord16BE :: Parser Word16
parseWord16BE :: Parser ByteString Word16
parseWord16BE =
  do Word8
hi <- Parser ByteString Word8
Parser.anyWord8
     Word8
lo <- Parser ByteString Word8
Parser.anyWord8
     Word16 -> Parser ByteString Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Parser ByteString Word16)
-> Word16 -> Parser ByteString Word16
forall a b. (a -> b) -> a -> b
$! Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hi Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
0x100 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lo