{-# LANGUAGE BangPatterns #-}

{-| Functions for decoding RFC 9562 UUIDs in RFC 8259 JSONs.
 -}

module Codec.JSON.Decoder.UUID
  ( Codec.JSON.Decoder.UUID.uuid
  ) where

import           Codec.JSON.Decoder
import           Codec.JSON.Decoder.Unsafe
import           Codec.JSON.Decoder.String.Internal

import           Data.UUID.Types as UUID
import           Parser.Lathe as Lathe



-- | Decode a JSON string as a 'UUID', in hexadecimal
--   @xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx@ format ("hex-and-dash"). Case-insensitive.
uuid :: Decoder UUID
uuid :: Decoder UUID
uuid =
  (Path -> Bitmask -> K -> Parser (Path, Error) UUID) -> Decoder UUID
forall a.
(Path -> Bitmask -> K -> Parser (Path, Error) a) -> Decoder a
Decoder ((Path -> Bitmask -> K -> Parser (Path, Error) UUID)
 -> Decoder UUID)
-> (Path -> Bitmask -> K -> Parser (Path, Error) UUID)
-> Decoder UUID
forall a b. (a -> b) -> a -> b
$ \Path
path Bitmask
bits K
k ->
    case K
k of
      K
S -> Int
-> Path -> Parser (Path, Error) UUID -> Parser (Path, Error) UUID
forall a.
Int -> Path -> Parser (Path, Error) a -> Parser (Path, Error) a
embedP Int
64 Path
path (Parser (Path, Error) UUID -> Parser (Path, Error) UUID)
-> Parser (Path, Error) UUID -> Parser (Path, Error) UUID
forall a b. (a -> b) -> a -> b
$ do
             ro <- Int -> (Path, Error) -> Parser (Path, Error) ByteString
forall end. Int -> end -> Parser end ByteString
Lathe.byteString Int
36 (Path
path, Error
AbruptEnd)
             case UUID.fromASCIIBytes ro of
               Maybe UUID
Nothing ->
                 let malformed :: String
malformed = String
"Expected UUID encoded as xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx"
                 in (Path, Error) -> Parser (Path, Error) UUID
forall e a. e -> Parser e a
err (Path
path, Gravity -> String -> Error
Malformed Gravity
Benign String
malformed)
               Just UUID
u  -> do
                 end <- Parser (Path, Error) Bool
forall never. Parser never Bool
atEnd
                 if end
                   then pure u
                   else err (path, Malformed Benign "Found trailing data after the UUID")

      K
_ ->
        let !bits' :: Bitmask
bits' = Bitmask
bits Bitmask -> Bitmask -> Bitmask
forall a. Semigroup a => a -> a -> a
<> Bitmask
StringBit
        in (Path, Error) -> Parser (Path, Error) UUID
forall e a. e -> Parser e a
err (Path
path, Bitmask -> K -> Error
Mismatch Bitmask
bits' K
k)