-- | Parsers for the 'Fingerprint' type.
--
--   This is an internal module that's not needed for the
--   normal use of the library.
module Hetzner.Cloud.Fingerprint (
    Fingerprint
  , FingerprintText (..)
  ) where

-- base
import GHC.Fingerprint (Fingerprint (..))
import Data.Void
import Data.Word
#if !MIN_VERSION_base(4,18,0)
import Control.Applicative (liftA2)
#endif
import Control.Monad (replicateM)
import Data.Foldable (foldl')
import Data.Bits (shiftL, (.|.))
-- text
import Data.Text (Text)
-- megaparsec
import Text.Megaparsec qualified as Parser
import Text.Megaparsec.Char.Lexer qualified as Parser
-- aeson
import Data.Aeson (FromJSON)
import Data.Aeson qualified as JSON

type Parser = Parser.Parsec Void Text

-- | Text-based 'Fingerprint' parser.
fingerprintParser :: Parser Fingerprint
fingerprintParser :: Parser Fingerprint
fingerprintParser = do
  [Word8]
bs0 <- forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Parser.hexadecimal forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
7 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
Parser.single Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Parser.hexadecimal
  [Word8]
bs1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
Parser.single Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Parser.hexadecimal
  let f :: Word64 -> (Int, Word8) -> Word64
      f :: Word64 -> (Int, Word8) -> Word64
f Word64
acc (Int
i,Word8
b) = Word64
acc forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b forall a. Bits a => a -> Int -> a
`shiftL` (Int
8 forall a. Num a => a -> a -> a
* (Int
7 forall a. Num a => a -> a -> a
- Int
i)))
      combineBytes :: [Word8] -> Word64
      combineBytes :: [Word8] -> Word64
combineBytes = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word64 -> (Int, Word8) -> Word64
f Word64
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Fingerprint
Fingerprint ([Word8] -> Word64
combineBytes [Word8]
bs0) ([Word8] -> Word64
combineBytes [Word8]
bs1)

-- | A wrapper of 'Fingerprint' with a custom 'FromJSON' instance.
newtype FingerprintText = FingerprintText { FingerprintText -> Fingerprint
fingerprint :: Fingerprint }

instance FromJSON FingerprintText where
  parseJSON :: Value -> Parser FingerprintText
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
JSON.withText String
"Fingerprint" forall a b. (a -> b) -> a -> b
$ \Text
t ->
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Parser.errorBundlePretty) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> FingerprintText
FingerprintText) forall a b. (a -> b) -> a -> b
$
      forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Parser.runParser (Parser Fingerprint
fingerprintParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
Parser.eof) String
"JSON input" Text
t