Version.hs

-- | Internal module. Not part of the public API.
module Database.Bolty.Connection.Version
  ( boltVersionsToSpec
  , Version(..)
  ) where

import           Data.Bits           (shiftL, (.|.))
import           Data.Kind           (Type)
import           Data.List           (foldl', sort)
import           Data.Maybe          (catMaybes)
import           Data.Word           (Word8, Word32)
import qualified Data.ByteString     as BS
import qualified Data.Text           as T
import qualified Validation          as V
import           TextShow            (showt)


-- | A BOLT protocol version (major.minor).
type Version :: Type
data Version = Version
  { minor :: Word8
  , major :: Word8
  }
  deriving stock (Eq)

instance Ord Version where
  compare Version{minor = minorA, major = majorA} Version{minor = minorB, major = majorB} =
    let compare_major = compare majorA majorB
    in if compare_major == EQ then
         compare minorA minorB
       else
         compare_major


validateVersion :: Version -> Maybe T.Text
validateVersion Version{minor, major}
  | major < 4                = Just "Bolt protocol versions below 4.4 are not supported"
  | major == 4 && minor < 4  = Just "Bolt protocol version 4.4 is the minimum supported minor; 4.0-4.3 are not supported"
  | major == 4 && minor > 4  = Just "Bolt protocol version 4 does not have any minor versions higher than 4 (4.4 is the highest minor)"
  | major == 5 && minor > 4  = Just "The driver supports up to Bolt 5.4"
  | major > 5                = Just "The latest supported Bolt major version is 5, please open a github issue for support for later protocols"
  | otherwise                = Nothing

-- | Validate and compact a list of BOLT versions into a 4-element handshake spec.
boltVersionsToSpec :: [Version] -> V.Validation [T.Text] [Word32]
boltVersionsToSpec [] = V.Failure ["Specify at least one protocol version"]
boltVersionsToSpec versions =
  let errors :: [(Version, T.Text)]
      errors = catMaybes $ map (\x -> fmap (\e -> (x, e)) $ validateVersion x) versions
      version_error_to_string :: (Version, T.Text) -> T.Text
      version_error_to_string (Version{minor, major}, err) = showt (BS.singleton major) <> "." <> showt (BS.singleton minor) <> ": " <> err
  in if not (null errors) then
        V.Failure $ map version_error_to_string errors
      else
        let ws = compactVersions versions
        in if length ws > 4 then
             V.Failure ["Could not make a version specification, try specifying less versions"]
           else
             V.Success $ ws <> replicate (4 - length ws) (0 :: Word32)


word8ToWord32 :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
word8ToWord32 a b c d
    = (fromIntegral a `shiftL` 24)
  .|. (fromIntegral b `shiftL` 16)
  .|. (fromIntegral c `shiftL` 8)
  .|. fromIntegral d

compactVersions :: [Version] -> [Word32]
compactVersions versions =
  let (trailing, acc) = foldl' f (Nothing, []) $ reverse $ sort versions
  in acc <> maybe [] (\p -> [versionAndBelowToWord p]) trailing
  where versionAndBelowToWord :: (Version, Word8) -> Word32
        versionAndBelowToWord (Version{minor, major}, versions_below) = word8ToWord32 0 versions_below minor major

        f :: (Maybe (Version, Word8), [Word32]) -> Version -> (Maybe (Version, Word8), [Word32])
        f (previous, acc) current@Version{minor = minorCurrent, major = majorCurrent} =
            let supportsVersionCompression = (majorCurrent == 4 && minorCurrent >= 3) || majorCurrent > 4
            in  if not supportsVersionCompression then
                  case previous of
                    Nothing -> (Nothing, acc <> [versionAndBelowToWord (current, 0)])
                    Just p -> (Nothing, acc <> [versionAndBelowToWord p, versionAndBelowToWord (current, 0)])
                else
                  case previous of
                    Just (p@(Version{minor = minorLast, major = majorLast}), versions_below) ->
                      if majorLast == majorCurrent && minorCurrent == minorLast - versions_below - 1 then
                        (Just (p, versions_below + 1), acc)
                      else
                        (Just (current, 0), acc <> [versionAndBelowToWord (p, versions_below)])
                    Nothing -> (Just (current, 0), acc)