{-# 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 )

  -- * Plaintext authentication request message
  , PlainAuthentication(..)
  , buildPlainAuthentication
  , parsePlainAuthentication

  -- * Plaintext authentication reply message
  , PlainAuthenticationReply(..)
  , buildPlainAuthenticationReply
  , parsePlainAuthenticationReply

  -- * 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
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
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 -> ((# #) -> r) -> ((# #) -> r) -> r
AuthNoAuthenticationRequired    = AuthMethod 0x00
pattern $bAuthGssApi :: AuthMethod
$mAuthGssApi :: forall {r}. AuthMethod -> ((# #) -> r) -> ((# #) -> r) -> r
AuthGssApi                      = AuthMethod 0x01
pattern $bAuthUsernamePassword :: AuthMethod
$mAuthUsernamePassword :: forall {r}. AuthMethod -> ((# #) -> r) -> ((# #) -> r) -> r
AuthUsernamePassword            = AuthMethod 0x02
pattern $bAuthNoAcceptableMethods :: AuthMethod
$mAuthNoAcceptableMethods :: forall {r}. AuthMethod -> ((# #) -> r) -> ((# #) -> r) -> r
AuthNoAcceptableMethods         = AuthMethod 0xFF

-- | SOCKS client commands
newtype Command                         = Command Word8 deriving (Command -> Command -> Bool
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
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 -> ((# #) -> r) -> ((# #) -> r) -> r
Connect                         = Command 1
pattern $bBind :: Command
$mBind :: forall {r}. Command -> ((# #) -> r) -> ((# #) -> r) -> r
Bind                            = Command 2
pattern $bUdpAssociate :: Command
$mUdpAssociate :: forall {r}. Command -> ((# #) -> r) -> ((# #) -> r) -> r
UdpAssociate                    = Command 3

-- | Tags used in the protocol messages for encoded 'Host' values
newtype HostTag                         = HostTag Word8 deriving (HostTag -> HostTag -> Bool
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
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 -> ((# #) -> r) -> ((# #) -> r) -> r
IPv4Tag                         = HostTag 1
pattern $bDomainNameTag :: HostTag
$mDomainNameTag :: forall {r}. HostTag -> ((# #) -> r) -> ((# #) -> r) -> r
DomainNameTag                   = HostTag 3
pattern $bIPv6Tag :: HostTag
$mIPv6Tag :: forall {r}. HostTag -> ((# #) -> r) -> ((# #) -> r) -> r
IPv6Tag                         = HostTag 4

-- | SOCKS command reply codes
newtype CommandReply                    = CommandReply Word8 deriving (CommandReply -> CommandReply -> Bool
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
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 -> ((# #) -> r) -> ((# #) -> r) -> r
Succeeded                       = CommandReply 0
pattern $bGeneralFailure :: CommandReply
$mGeneralFailure :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
GeneralFailure                  = CommandReply 1
pattern $bNotAllowed :: CommandReply
$mNotAllowed :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
NotAllowed                      = CommandReply 2
pattern $bNetUnreachable :: CommandReply
$mNetUnreachable :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
NetUnreachable                  = CommandReply 3
pattern $bHostUnreachable :: CommandReply
$mHostUnreachable :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
HostUnreachable                 = CommandReply 4
pattern $bConnectionRefused :: CommandReply
$mConnectionRefused :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
ConnectionRefused               = CommandReply 5
pattern $bTTLExpired :: CommandReply
$mTTLExpired :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
TTLExpired                      = CommandReply 6
pattern $bCmdNotSupported :: CommandReply
$mCmdNotSupported :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
CmdNotSupported                 = CommandReply 7
pattern $bAddrNotSupported :: CommandReply
$mAddrNotSupported :: forall {r}. CommandReply -> ((# #) -> r) -> ((# #) -> r) -> r
AddrNotSupported                = CommandReply 8

-- | Network host and port number
data Address = Address Host PortNumber
  deriving Int -> Address -> ShowS
[Address] -> ShowS
Address -> String
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
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

-- RFC 1929 Username/Password

-- | Plaintext username and password request
data PlainAuthentication = PlainAuthentication
  { PlainAuthentication -> ByteString
plainUsername :: ByteString -- ^ username
  , PlainAuthentication -> ByteString
plainPassword :: ByteString -- ^ password
  }
  deriving Int -> PlainAuthentication -> ShowS
[PlainAuthentication] -> ShowS
PlainAuthentication -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlainAuthentication] -> ShowS
$cshowList :: [PlainAuthentication] -> ShowS
show :: PlainAuthentication -> String
$cshow :: PlainAuthentication -> String
showsPrec :: Int -> PlainAuthentication -> ShowS
$cshowsPrec :: Int -> PlainAuthentication -> ShowS
Show

-- | Plaintext username and password response
newtype PlainAuthenticationReply = PlainAuthenticationReply
  { PlainAuthenticationReply -> Word8
plainStatus :: Word8 -- ^ @0@ for success, failure otherwise
  }
  deriving Int -> PlainAuthenticationReply -> ShowS
[PlainAuthenticationReply] -> ShowS
PlainAuthenticationReply -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlainAuthenticationReply] -> ShowS
$cshowList :: [PlainAuthenticationReply] -> ShowS
show :: PlainAuthenticationReply -> String
$cshow :: PlainAuthenticationReply -> String
showsPrec :: Int -> PlainAuthenticationReply -> ShowS
$cshowsPrec :: Int -> PlainAuthenticationReply -> 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
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
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
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
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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
Parser.anyWord8

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

buildHost :: Host -> Builder
buildHost :: Host -> Builder
buildHost (IPv4 HostAddress
hostAddr) = HostTag -> Builder
buildHostTag HostTag
IPv4Tag       forall a. Semigroup a => a -> a -> a
<> HostAddress -> Builder
buildHostAddress  HostAddress
hostAddr
buildHost (IPv6 HostAddress6
hostAddr) = HostTag -> Builder
buildHostTag HostTag
IPv6Tag       forall a. Semigroup a => a -> a -> a
<> HostAddress6 -> Builder
buildHostAddress6 HostAddress6
hostAddr
buildHost (DomainName ByteString
dn) = HostTag -> Builder
buildHostTag HostTag
DomainNameTag 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       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser HostAddress
parseHostAddress
       HostTag
IPv6Tag       -> HostAddress6 -> Host
IPv6       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser HostAddress6
parseHostAddress6
       HostTag
DomainNameTag -> ByteString -> Host
DomainName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
parseDomainName
       HostTag
_             -> 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 forall a. Semigroup a => a -> a -> a
<> PortNumber -> Builder
buildPort PortNumber
port

parseAddress :: Parser Address
parseAddress :: Parser Address
parseAddress = Host -> PortNumber -> Address
Address forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Host
parseHost forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser 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) -> 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 HostAddress
parseHostAddress =
  do [Word8
a1,Word8
a2,Word8
a3,Word8
a4] <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 Parser Word8
Parser.anyWord8
     forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) ->
      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 HostAddress6
parseHostAddress6 =
  do [Word16
a1,Word16
a2,Word16
a3,Word16
a4,Word16
a5,Word16
a6,Word16
a7,Word16
a8] <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 Parser Word16
parseWord16BE
     forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. Ord a => a -> a -> Bool
< Int
256 = Word8 -> Builder
Builder.word8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) forall a. Semigroup a => a -> a -> a
<>
                        ByteString -> Builder
Builder.byteString ByteString
bs
  | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"SOCKS5 domain name too long"

parseDomainName :: Parser ByteString
parseDomainName :: Parser ByteString
parseDomainName =
  do Word8
len <- Parser Word8
Parser.anyWord8
     Int -> Parser ByteString
Parser.take (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)

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

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

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

parseVersion :: Parser ()
parseVersion :: Parser ()
parseVersion = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Word8 -> Parser 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
Parser.anyWord8

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

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

parseReserved :: Parser ()
parseReserved :: Parser ()
parseReserved = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser 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 :: forall a. (a -> Builder) -> [a] -> Builder
buildListOf a -> Builder
builder [a]
xs
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Ord a => a -> a -> Bool
< Int
256 = Word8 -> Builder
Builder.word8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)) forall a. Semigroup a => a -> a -> a
<>
                      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Builder
builder [a]
xs
  | Bool
otherwise       = 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 :: forall a. Parser a -> Parser [a]
parseListOf Parser a
parser =
  do Word8
n <- Parser Word8
Parser.anyWord8
     forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (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 forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion forall a. Semigroup a => a -> a -> a
<>
  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
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser a -> Parser [a]
parseListOf Parser AuthMethod
parseAuthMethod

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

buildServerHello :: ServerHello -> ByteString
buildServerHello :: ServerHello -> ByteString
buildServerHello ServerHello
msg =
  Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion 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
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    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 forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion                    forall a. Semigroup a => a -> a -> a
<>
  Command -> Builder
buildCommand  (Request -> Command
reqCommand  Request
req) forall a. Semigroup a => a -> a -> a
<>
  Builder
buildReserved                   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
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command
parseCommand
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser ()
parseReserved
    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 forall a b. (a -> b) -> a -> b
$
  Builder
buildVersion                  forall a. Semigroup a => a -> a -> a
<>
  CommandReply -> Builder
buildReply   (Response -> CommandReply
rspReply   Response
msg) forall a. Semigroup a => a -> a -> a
<>
  Builder
buildReserved                 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
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Parser ()
parseVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser CommandReply
parseReply
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser ()
parseReserved
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Address
parseAddress

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

buildPlainAuthentication :: PlainAuthentication -> ByteString
buildPlainAuthentication :: PlainAuthentication -> ByteString
buildPlainAuthentication PlainAuthentication
msg =
  Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$
  Word8 -> Builder
Builder.word8 Word8
1 forall a. Semigroup a => a -> a -> a
<> -- subnegotiation version
  ByteString -> Builder
buildBS (PlainAuthentication -> ByteString
plainUsername PlainAuthentication
msg) forall a. Semigroup a => a -> a -> a
<>
  ByteString -> Builder
buildBS (PlainAuthentication -> ByteString
plainPassword PlainAuthentication
msg)
  where
    buildBS :: ByteString -> Builder
buildBS ByteString
x =
      Word8 -> Builder
Builder.word8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
x)) forall a. Semigroup a => a -> a -> a
<>
      ByteString -> Builder
Builder.byteString ByteString
x

parsePlainAuthentication :: Parser PlainAuthentication
parsePlainAuthentication :: Parser PlainAuthentication
parsePlainAuthentication =
  ByteString -> ByteString -> PlainAuthentication
PlainAuthentication
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Word8 -> Parser Word8
Parser.word8 Word8
1 -- subnegotiation version
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
parseBS
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
parseBS
  where
    parseBS :: Parser ByteString
parseBS =
     do Word8
len <- Parser Word8
Parser.anyWord8
        Int -> Parser ByteString
Parser.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len)

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

buildPlainAuthenticationReply :: PlainAuthenticationReply -> ByteString
buildPlainAuthenticationReply :: PlainAuthenticationReply -> ByteString
buildPlainAuthenticationReply PlainAuthenticationReply
msg =
  Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$
  Word8 -> Builder
Builder.word8 Word8
1 forall a. Semigroup a => a -> a -> a
<> -- subnegotiation version
  Word8 -> Builder
Builder.word8 (PlainAuthenticationReply -> Word8
plainStatus PlainAuthenticationReply
msg)

parsePlainAuthenticationReply :: Parser PlainAuthenticationReply
parsePlainAuthenticationReply :: Parser PlainAuthenticationReply
parsePlainAuthenticationReply =
  Word8 -> PlainAuthenticationReply
PlainAuthenticationReply
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  Word8 -> Parser Word8
Parser.word8 Word8
1 -- subnegotiation version
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word8
Parser.anyWord8

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

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