Connect.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

module Types.Connect
  ( Connect (..)
  , validateAuthToken
  , validateUser
  , validatePass
  , validateName
  , validateLang
  , validateVersion
  , validateProtocol
  , validateSig
  , validateJwt
  , validateNKey
  ) where

import           Data.Aeson
import qualified Data.ByteString           as BS
import qualified Data.ByteString.Lazy      as LBS
import qualified Data.Text.Encoding        as E
import           GHC.Generics              (Generic)
import           Transformers.Transformers (Transformer (..))
import           Validators.Validators

data Connect = Connect
                 { verbose       :: Bool
                 , pedantic      :: Bool
                 , tls_required  :: Bool
                 , auth_token    :: Maybe BS.ByteString
                 , user          :: Maybe BS.ByteString
                 , pass          :: Maybe BS.ByteString
                 , name          :: Maybe BS.ByteString
                 , lang          :: BS.ByteString
                 , version       :: BS.ByteString
                 , protocol      :: Maybe Int
                 , echo          :: Maybe Bool
                 , sig           :: Maybe BS.ByteString
                 , jwt           :: Maybe BS.ByteString
                 , nkey          :: Maybe BS.ByteString
                 , no_responders :: Maybe Bool
                 , headers       :: Maybe Bool
                 }
  deriving (Eq, Show)

instance ToJSON Connect where
  toJSON = toJSON . toConnectJSON

instance Transformer Connect where
  transform c =
    let encoded = encode c
    in LBS.fromChunks ["CONNECT ", LBS.toStrict encoded, "\r\n"]

newtype Utf8ByteString = Utf8ByteString { unUtf8ByteString :: BS.ByteString }
  deriving (Eq, Show)

instance ToJSON Utf8ByteString where
  toJSON = toJSON . E.decodeUtf8 . unUtf8ByteString

data ConnectJSON = ConnectJSON
                     { connectJSON_verbose       :: Bool
                     , connectJSON_pedantic      :: Bool
                     , connectJSON_tls_required  :: Bool
                     , connectJSON_auth_token    :: Maybe Utf8ByteString
                     , connectJSON_user          :: Maybe Utf8ByteString
                     , connectJSON_pass          :: Maybe Utf8ByteString
                     , connectJSON_name          :: Maybe Utf8ByteString
                     , connectJSON_lang          :: Utf8ByteString
                     , connectJSON_version       :: Utf8ByteString
                     , connectJSON_protocol      :: Maybe Int
                     , connectJSON_echo          :: Maybe Bool
                     , connectJSON_sig           :: Maybe Utf8ByteString
                     , connectJSON_jwt           :: Maybe Utf8ByteString
                     , connectJSON_nkey          :: Maybe Utf8ByteString
                     , connectJSON_no_responders :: Maybe Bool
                     , connectJSON_headers       :: Maybe Bool
                     }
  deriving (Eq, Generic, Show)

instance ToJSON ConnectJSON where
  toJSON = genericToJSON defaultOptions
    { fieldLabelModifier = drop connectJSONPrefixLength
    , omitNothingFields = True
    }

connectJSONPrefixLength :: Int
connectJSONPrefixLength = 12

toConnectJSON :: Connect -> ConnectJSON
toConnectJSON c =
  ConnectJSON
    { connectJSON_verbose = verbose c
    , connectJSON_pedantic = pedantic c
    , connectJSON_tls_required = tls_required c
    , connectJSON_auth_token = Utf8ByteString <$> auth_token c
    , connectJSON_user = Utf8ByteString <$> user c
    , connectJSON_pass = Utf8ByteString <$> pass c
    , connectJSON_name = Utf8ByteString <$> name c
    , connectJSON_lang = Utf8ByteString (lang c)
    , connectJSON_version = Utf8ByteString (version c)
    , connectJSON_protocol = protocol c
    , connectJSON_echo = echo c
    , connectJSON_sig = Utf8ByteString <$> sig c
    , connectJSON_jwt = Utf8ByteString <$> jwt c
    , connectJSON_nkey = Utf8ByteString <$> nkey c
    , connectJSON_no_responders = no_responders c
    , connectJSON_headers = headers c
    }

instance Validator Connect where
  validate c = do
    validateAuthToken c
    validateUser c
    validatePass c
    validateName c
    validateLang c
    validateVersion c
    validateProtocol c
    validateSig c
    validateJwt c
    validateNKey c

validateAuthToken :: Connect -> Either BS.ByteString ()
validateAuthToken c
  | auth_token c == Just "" = Left "explicit empty auth token"
  | otherwise = Right ()

validateUser :: Connect -> Either BS.ByteString ()
validateUser c
  | user c == Just "" = Left "explicit empty user"
  | otherwise = Right ()

validatePass :: Connect -> Either BS.ByteString ()
validatePass c
  | pass c == Just "" = Left "explicit empty pass"
  | otherwise = Right ()

validateName :: Connect -> Either BS.ByteString ()
validateName c
  | name c == Just "" = Left "explicit empty name"
  | otherwise = Right ()

validateLang :: Connect -> Either BS.ByteString ()
validateLang c
  | lang c ==  "" = Left "explicit empty lang"
  | otherwise = Right ()

validateVersion :: Connect -> Either BS.ByteString ()
validateVersion c
  | version c == "" = Left "explicit empty version"
  | otherwise = Right ()

validateProtocol :: Connect -> Either BS.ByteString ()
validateProtocol c
  | protocol c `notElem` [Nothing, Just 0, Just 1] = Left "invalid protocol"
  | otherwise = Right ()

validateSig :: Connect -> Either BS.ByteString ()
validateSig c
  | sig c == Just "" = Left "explicit empty sig"
  | otherwise = Right ()

validateJwt :: Connect -> Either BS.ByteString ()
validateJwt c
  | jwt c == Just "" = Left "explicit empty jwt"
  | otherwise = Right ()

validateNKey :: Connect -> Either BS.ByteString ()
validateNKey c
  | nkey c == Just "" = Left "explicit empty nkey"
  | otherwise = Right ()