-- | 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 <- (Word8 -> [Word8] -> [Word8])
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity [Word8]
-> ParsecT Void Text Identity [Word8]
forall a b c.
(a -> b -> c)
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity b
-> ParsecT Void Text Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ParsecT Void Text Identity Word8
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Parser.hexadecimal (ParsecT Void Text Identity [Word8]
 -> ParsecT Void Text Identity [Word8])
-> ParsecT Void Text Identity [Word8]
-> ParsecT Void Text Identity [Word8]
forall a b. (a -> b) -> a -> b
$
         Int
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
7 (ParsecT Void Text Identity Word8
 -> ParsecT Void Text Identity [Word8])
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity [Word8]
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
Parser.single Char
Token Text
':' ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity Word8
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Word8
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Parser.hexadecimal
  [Word8]
bs1 <- Int
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 (ParsecT Void Text Identity Word8
 -> ParsecT Void Text Identity [Word8])
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity [Word8]
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
Parser.single Char
Token Text
':' ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity Word8
-> ParsecT Void Text Identity Word8
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Word8
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 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)))
      combineBytes :: [Word8] -> Word64
      combineBytes :: [Word8] -> Word64
combineBytes = (Word64 -> (Int, Word8) -> Word64)
-> Word64 -> [(Int, Word8)] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word64 -> (Int, Word8) -> Word64
f Word64
0 ([(Int, Word8)] -> Word64)
-> ([Word8] -> [(Int, Word8)]) -> [Word8] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Word8] -> [(Int, Word8)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
  Fingerprint -> Parser Fingerprint
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fingerprint -> Parser Fingerprint)
-> Fingerprint -> Parser Fingerprint
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 = String
-> (Text -> Parser FingerprintText)
-> Value
-> Parser FingerprintText
forall a. String -> (Text -> Parser a) -> Value -> Parser a
JSON.withText String
"Fingerprint" ((Text -> Parser FingerprintText)
 -> Value -> Parser FingerprintText)
-> (Text -> Parser FingerprintText)
-> Value
-> Parser FingerprintText
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    (ParseErrorBundle Text Void -> Parser FingerprintText)
-> (Fingerprint -> Parser FingerprintText)
-> Either (ParseErrorBundle Text Void) Fingerprint
-> Parser FingerprintText
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser FingerprintText
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser FingerprintText)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Parser FingerprintText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Parser.errorBundlePretty) (FingerprintText -> Parser FingerprintText
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FingerprintText -> Parser FingerprintText)
-> (Fingerprint -> FingerprintText)
-> Fingerprint
-> Parser FingerprintText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> FingerprintText
FingerprintText) (Either (ParseErrorBundle Text Void) Fingerprint
 -> Parser FingerprintText)
-> Either (ParseErrorBundle Text Void) Fingerprint
-> Parser FingerprintText
forall a b. (a -> b) -> a -> b
$
      Parser Fingerprint
-> String
-> Text
-> Either (ParseErrorBundle Text Void) Fingerprint
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Parser.runParser (Parser Fingerprint
fingerprintParser Parser Fingerprint
-> ParsecT Void Text Identity () -> Parser Fingerprint
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Parser.eof) String
"JSON input" Text
t