Internal.hs

-- |
-- Module      : Data.TypeID.Internal
-- License     : MIT
-- Maintainer  : mmzk1526@outlook.com
-- Portability : GHC
--
module Data.TypeID.Internal where

import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.ST
import           Data.Aeson.Types hiding (Array, String)
import           Data.Array
import           Data.Array.ST
import           Data.Array.Unsafe (unsafeFreeze)
import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.Bifunctor
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BSL
import           Data.Char
import           Data.Hashable
import           Data.Proxy
import           Data.String
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding
import           Data.TypeID.Class
import           Data.TypeID.Error
import           Data.UUID.Types.Internal (UUID(..))
import qualified Data.UUID.Types.Internal as UUID
import qualified Data.UUID.V7 as V7
import           Foreign

-- | The constructor is not exposed to the public API to prevent generating
-- invalid @TypeID@s.
data TypeID = TypeID { _getPrefix :: Text
                     , _getUUID   :: UUID }
  deriving (Eq, Ord)

instance Show TypeID where
  show :: TypeID -> String
  show = toString
  {-# INLINE show #-}

instance Read TypeID where
  readsPrec :: Int -> String -> [(TypeID, String)]
  readsPrec _ str = case parseStringS str of
    Left _      -> []
    Right (x,y) -> [(x, y)]
  {-# INLINE readsPrec #-}

instance ToJSON TypeID where
  toJSON :: TypeID -> Value
  toJSON = toJSON . toText
  {-# INLINE toJSON #-}

instance FromJSON TypeID where
  parseJSON :: Value -> Parser TypeID
  parseJSON str = do
    s <- parseJSON str
    case parseText s of
      Left err  -> fail $ show err
      Right tid -> pure tid
  {-# INLINE parseJSON #-}

instance ToJSONKey TypeID where
  toJSONKey :: ToJSONKeyFunction TypeID
  toJSONKey = toJSONKeyText toText
  {-# INLINE toJSONKey #-}

instance FromJSONKey TypeID where
  fromJSONKey :: FromJSONKeyFunction TypeID
  fromJSONKey = FromJSONKeyTextParser \t -> case parseText t of
    Left err  -> fail $ show err
    Right tid -> pure tid
  {-# INLINE fromJSONKey #-}

-- | Since the specification does not formulate a concrete binary format, this
-- instance is based on the following custom format:
--
-- * The first 16 bytes are the suffix 'UUID' encoded in base32.
-- * The next byte is the length of the prefix encoded in a byte.
-- * The next bytes are the prefix, each letter taking 5 bits, mapping \'a\' to
--   1 and \'z\' to 26.
--
-- Note that the prefix and the 'UUID' is swapped compared to the string
-- representation, this is for the convenience of the use case where only the
-- suffix 'UUID' is required. Because of this, the sorting order may be
-- different from the string representation, but they are guaranteed to be the
-- same if the same prefix is used.
instance Binary TypeID where
  put :: TypeID -> Put
  put (TypeID prefix uuid) = do
    put uuid
    let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack
                      $ encodeUtf8 prefix
    putWord8 . fromIntegral $ length encodedPrefix
    forM_ encodedPrefix putWord8
  {-# INLINE put #-}

  get :: Get TypeID
  get = do
    uuid          <- get
    len           <- getWord8
    encodedPrefix <- separate5BitInts <$> replicateM (fromIntegral len) getWord8
    when (length encodedPrefix > 63) $ fail "Binary: Prefix too long"
    when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)
         (fail "Binary: Invalid prefix")
    pure $ TypeID (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid
  {-# INLINE get #-}

-- | Similar to the 'Binary' instance, but the 'UUID' is stored in host endian.
instance Storable TypeID where
  sizeOf :: TypeID -> Int
  sizeOf _ = 60
  {-# INLINE sizeOf #-}

  alignment :: TypeID -> Int
  alignment _ = 4
  {-# INLINE alignment #-}

  peek :: Ptr TypeID -> IO TypeID
  peek ptr = do
    uuid          <- peek (castPtr ptr :: Ptr UUID)
    len           <- fromIntegral <$> (peekByteOff ptr 16 :: IO Word8)
    encodedPrefix <- separate5BitInts
                 <$> forM [1..len] \ix -> peekByteOff @Word8 ptr (16 + ix)
    when (length encodedPrefix > 63) $ fail "Storable: Prefix too long"
    when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)
         (fail "Storable: Invalid prefix")
    pure $ TypeID (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid
  {-# INLINE peek #-}

  poke :: Ptr TypeID -> TypeID -> IO ()
  poke ptr (TypeID prefix uuid) = do
    poke (castPtr ptr) uuid
    let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack
                      $ encodeUtf8 prefix
    pokeByteOff @Word8 ptr 16 (fromIntegral $ length encodedPrefix)
    zipWithM_ (pokeByteOff ptr . (+ 16)) [1..] encodedPrefix
  {-# INLINE poke #-}

instance Hashable TypeID where
  hashWithSalt :: Int -> TypeID -> Int
  hashWithSalt salt (TypeID prefix uuid)
    = salt `hashWithSalt` prefix `hashWithSalt` uuid
  {-# INLINE hashWithSalt #-}

-- | Get the prefix, 'UUID', and timestamp of a 'TypeID'.
instance IDType TypeID where
  getPrefix :: TypeID -> Text
  getPrefix = _getPrefix
  {-# INLINE getPrefix #-}

  getUUID :: TypeID -> UUID
  getUUID = _getUUID
  {-# INLINE getUUID #-}

  getTime :: TypeID -> Word64
  getTime = V7.getTime . getUUID
  {-# INLINE getTime #-}

-- | Conversion between 'TypeID' and 'String'/'Text'/'ByteString'.
instance IDConv TypeID where
  string2ID :: String -> Either TypeIDError TypeID
  string2ID = parseString
  {-# INLINE string2ID #-}

  text2ID :: Text -> Either TypeIDError TypeID
  text2ID = parseText
  {-# INLINE text2ID #-}

  byteString2ID :: ByteString -> Either TypeIDError TypeID
  byteString2ID = parseByteString
  {-# INLINE byteString2ID #-}

  id2String :: TypeID -> String
  id2String = toString
  {-# INLINE id2String #-}

  id2Text :: TypeID -> Text
  id2Text = toText
  {-# INLINE id2Text #-}

  id2ByteString :: TypeID -> ByteString
  id2ByteString = toByteString
  {-# INLINE id2ByteString #-}

  unsafeString2ID :: String -> TypeID
  unsafeString2ID = unsafeParseString
  {-# INLINE unsafeString2ID #-}

  unsafeText2ID :: Text -> TypeID
  unsafeText2ID = unsafeParseText
  {-# INLINE unsafeText2ID #-}

  unsafeByteString2ID :: ByteString -> TypeID
  unsafeByteString2ID = unsafeParseByteString
  {-# INLINE unsafeByteString2ID #-}

-- | Generate 'TypeID's.
instance IDGen TypeID where
  type IDGenPrefix TypeID = 'Just Text

  genID_ :: MonadIO m => Proxy TypeID -> Text -> m TypeID
  genID_ _ = genTypeID
  {-# INLINE genID_ #-}

  genID'_ :: MonadIO m => Proxy TypeID -> Text -> m TypeID
  genID'_ _ = genTypeID'
  {-# INLINE genID'_ #-}

  genIDs_ :: MonadIO m => Proxy TypeID -> Text -> Word16 -> m [TypeID]
  genIDs_ _ = genTypeIDs
  {-# INLINE genIDs_ #-}

  decorate_ :: Proxy TypeID -> Text -> UUID -> Either TypeIDError TypeID
  decorate_ _ = decorateTypeID
  {-# INLINE decorate_ #-}

  checkID_ :: Proxy TypeID -> TypeID -> Maybe TypeIDError
  checkID_ _ = checkTypeID
  {-# INLINE checkID_ #-}

  checkIDWithEnv_ :: MonadIO m
                  => Proxy TypeID -> TypeID -> m (Maybe TypeIDError)
  checkIDWithEnv_ _ = checkTypeIDWithEnv
  {-# INLINE checkIDWithEnv_ #-}

-- | Generate a new 'TypeID' from a prefix.
--
-- It throws a 'TypeIDError' if the prefix does not match the specification,
-- namely if it's longer than 63 characters or if it contains characters other
-- than lowercase latin letters.
genTypeID :: MonadIO m => Text -> m TypeID
genTypeID = fmap head . (`genTypeIDs` 1)
{-# INLINE genTypeID #-}

-- | Generate a new 'TypeID' from a prefix based on statelesss 'UUID'v7.
--
-- See the documentation of 'V7.genUUID'' for more information.
genTypeID' :: MonadIO m => Text -> m TypeID
genTypeID' prefix = case checkPrefix prefix of
  Nothing  -> unsafeGenTypeID' prefix
  Just err -> liftIO $ throwIO err
{-# INLINE genTypeID' #-}

-- | Generate a list of 'TypeID's from a prefix.
--
-- It tries its best to generate 'TypeID's at the same timestamp, but it may not
-- be possible if we are asking too many 'UUID's at the same time.
--
-- It is guaranteed that the first 32768 'TypeID's are generated at the same
-- timestamp.
genTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID]
genTypeIDs prefix n = case checkPrefix prefix of
  Nothing  -> unsafeGenTypeIDs prefix n
  Just err -> liftIO $ throwIO err
{-# INLINE genTypeIDs #-}

-- | Generate a new 'TypeID' from a prefix, but without checking if the prefix
-- is valid.
unsafeGenTypeID :: MonadIO m => Text -> m TypeID
unsafeGenTypeID = fmap head . (`unsafeGenTypeIDs` 1)
{-# INLINE unsafeGenTypeID #-}

-- | Generate a new 'TypeID' from a prefix based on statelesss 'UUID'v7, but
-- without checking if the prefix is valid.
unsafeGenTypeID' :: MonadIO m => Text -> m TypeID
unsafeGenTypeID' prefix = TypeID prefix <$> V7.genUUID'
{-# INLINE unsafeGenTypeID' #-}

-- | Generate n 'TypeID's from a prefix, but without checking if the prefix is
-- valid.
--
-- It tries its best to generate 'TypeID's at the same timestamp, but it may not
-- be possible if we are asking too many 'UUID's at the same time.
--
-- It is guaranteed that the first 32768 'TypeID's are generated at the same
-- timestamp.
unsafeGenTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID]
unsafeGenTypeIDs prefix n = map (TypeID prefix) <$> V7.genUUIDs n
{-# INLINE unsafeGenTypeIDs #-}

-- | The nil 'TypeID'.
nilTypeID :: TypeID
nilTypeID = TypeID "" UUID.nil
{-# INLINE nilTypeID #-}
{-# DEPRECATED nilTypeID "Will be removed in the next major release." #-}

-- | Obtain a 'TypeID' from a prefix and a 'UUID'.
decorateTypeID :: Text -> UUID -> Either TypeIDError TypeID
decorateTypeID prefix uuid = case checkPrefix prefix of
  Nothing  -> Right $ TypeID prefix uuid
  Just err -> Left err
{-# INLINE decorateTypeID #-}

-- | Pretty-print a 'TypeID'. It is 'id2String' with concrete type.
toString :: TypeID -> String
toString (TypeID prefix (UUID w1 w2)) = if T.null prefix
  then suffixEncode bs
  else T.unpack prefix ++ "_" ++ suffixEncode bs
  where
    bs = runPut $ mapM_ putWord64be [w1, w2]
{-# INLINE toString #-}

-- | Pretty-print a 'TypeID' to strict 'Text'. It is 'id2Text' with concrete
-- type.
toText :: TypeID -> Text
toText (TypeID prefix (UUID w1 w2)) = if T.null prefix
  then T.pack (suffixEncode bs)
  else prefix <> "_" <> T.pack (suffixEncode bs)
  where
    bs = runPut $ mapM_ putWord64be [w1, w2]
{-# INLINE toText #-}

-- | Pretty-print a 'TypeID' to lazy 'ByteString'. It is 'id2ByteString' with
-- concrete type.
toByteString :: TypeID -> ByteString
toByteString = fromString . toString
{-# INLINE toByteString #-}

-- | Parse a 'TypeID' from its 'String' representation. It is 'string2ID' with
-- concrete type.
parseString :: String -> Either TypeIDError TypeID
parseString str = case parseStringS str of
  Left err        -> Left err
  Right (tid, "") -> Right tid
  _               -> Left TypeIDErrorUUIDError
{-# INLINE parseString #-}

parseStringS :: String -> Either TypeIDError (TypeID, String)
parseStringS str = case span (/= '_') str of
  ("", _)              -> Left TypeIDExtraSeparator
  (_, "")              -> do
    let (uuid, rem) = splitAt 26 str
        bs          = fromString uuid
    (, rem) . TypeID "" <$> decodeUUID bs
  (prefix, _ : suffix) -> do
    let prefix'     = T.pack prefix
        (uuid, rem) = splitAt 26 suffix
        bs          = fromString uuid
    case checkPrefix prefix' of
      Nothing  -> (, rem) . TypeID prefix' <$> decodeUUID bs
      Just err -> Left err

-- | Parse a 'TypeID' from its string representation as a strict 'Text'. It is
-- 'text2ID' with concrete type.
parseText :: Text -> Either TypeIDError TypeID
parseText text = case second T.uncons $ T.span (/= '_') text of
  ("", _)                    -> Left TypeIDExtraSeparator
  (_, Nothing)               -> TypeID "" <$> decodeUUID bs
  (prefix, Just (_, suffix)) -> do
    case checkPrefix prefix of
      Nothing  -> TypeID prefix
              <$> decodeUUID (BSL.fromStrict $ encodeUtf8 suffix)
      Just err -> Left err
  where
    bs = BSL.fromStrict $ encodeUtf8 text

-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString'. It
-- is 'byteString2ID' with concrete type.
parseByteString :: ByteString -> Either TypeIDError TypeID
parseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of
  ("", _)                    -> Left TypeIDExtraSeparator
  (_, Nothing)               -> TypeID "" <$> decodeUUID bs
  (prefix, Just (_, suffix)) -> do
    let prefix' = decodeUtf8 $ BSL.toStrict prefix
    case checkPrefix prefix' of
      Nothing  -> TypeID prefix' <$> decodeUUID suffix
      Just err -> Left err

-- | Parse a 'TypeID' from its 'String' representation, throwing an error when
-- the parsing fails. It is 'string2IDM' with concrete type.
parseStringM :: MonadIO m => String -> m TypeID
parseStringM = string2IDM
{-# INLINE parseStringM #-}

-- | Parse a 'TypeID' from its string representation as a strict 'Text',
-- throwing an error when the parsing fails. It is 'text2IDM' with concrete
-- type.
parseTextM :: MonadIO m => Text -> m TypeID
parseTextM = text2IDM
{-# INLINE parseTextM #-}

-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString',
-- throwing an error when the parsing fails. It is 'byteString2IDM' with
-- concrete type.
parseByteStringM :: MonadIO m => ByteString -> m TypeID
parseByteStringM = byteString2IDM
{-# INLINE parseByteStringM #-}

-- | Check if the given prefix is a valid TypeID prefix.
checkPrefix :: Text -> Maybe TypeIDError
checkPrefix prefix
  | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong (T.length prefix)
  | otherwise
      = case T.uncons (T.dropWhile (liftM2 (&&) isLower isAscii) prefix) of
        Nothing     -> Nothing
        Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c
{-# INLINE checkPrefix #-}

-- | Check if the prefix is valid and the suffix 'UUID' has the correct v7
-- version and variant.
checkTypeID :: TypeID -> Maybe TypeIDError
checkTypeID (TypeID prefix uuid)
  = msum [ checkPrefix prefix
         , TypeIDErrorUUIDError <$ guard (not $ V7.validate uuid) ]
{-# INLINE checkTypeID #-}

-- | Similar to 'checkTypeID', but also checks if the suffix 'UUID' is
-- generated in the past.
checkTypeIDWithEnv :: MonadIO m => TypeID -> m (Maybe TypeIDError)
checkTypeIDWithEnv tid@(TypeID _ uuid)
  = fmap (checkTypeID tid `mplus`)
         ((TypeIDErrorUUIDError <$) . guard . not <$> V7.validateWithTime uuid)
{-# INLINE checkTypeIDWithEnv #-}

-- | Parse a 'TypeID' from its 'String' representation, but crashes when
-- parsing fails.
unsafeParseString :: String -> TypeID
unsafeParseString str = case span (/= '_') str of
  (_, "")              -> TypeID "" . unsafeDecodeUUID $ fromString str
  (prefix, _ : suffix) -> TypeID (T.pack prefix)
                        . unsafeDecodeUUID $ fromString suffix
{-# INLINE unsafeParseString #-}

-- | Parse a 'TypeID' from its string representation as a strict 'Text', but
-- crashes when parsing fails.
unsafeParseText :: Text -> TypeID
unsafeParseText text = case second T.uncons $ T.span (/= '_') text of
  (_, Nothing)               -> TypeID "" . unsafeDecodeUUID
                              . BSL.fromStrict $ encodeUtf8 text
  (prefix, Just (_, suffix)) -> TypeID prefix . unsafeDecodeUUID
                              . BSL.fromStrict . encodeUtf8 $ suffix
{-# INLINE unsafeParseText #-}

-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString',
-- but crashes when parsing fails.
unsafeParseByteString :: ByteString -> TypeID
unsafeParseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of
  (_, Nothing)               -> TypeID "" $ unsafeDecodeUUID bs
  (prefix, Just (_, suffix)) -> TypeID (decodeUtf8 $ BSL.toStrict prefix)
                              . unsafeDecodeUUID $ suffix
{-# INLINE unsafeParseByteString #-}

concat5BitInts :: [Word8] -> [Word8]
concat5BitInts
  = reverse . toBytes
  . foldl (\(acc :: Integer) w -> acc `shiftL` 5 + fromIntegral w) 0
  where
    toBytes 0 = []
    toBytes x = fromIntegral (x .&. 0xFF) : toBytes (x `shiftR` 8)
{-# INLINE concat5BitInts #-}

separate5BitInts :: [Word8] -> [Word8]
separate5BitInts
  = reverse . toBytes
  . foldl (\(acc :: Integer) w -> acc `shiftL` 8 + fromIntegral w) 0
  where
    toBytes 0 = []
    toBytes x = fromIntegral (x .&. 0x1F) : toBytes (x `shiftR` 5)
{-# INLINE separate5BitInts #-}

-- The helpers below are verbatim translations from the official highly magical
-- Go implementation.

suffixEncode :: ByteString -> String
suffixEncode bs = (alphabet !) <$> runST do
  dest <- newArray_ (0, 25) :: ST s (STUArray s Int Word8)
  writeArray dest 0 $ (bs `BSL.index` 0 .&. 224) `shiftR` 5
  writeArray dest 1 $ bs `BSL.index` 0 .&. 31
  writeArray dest 2 $ (bs `BSL.index` 1 .&. 248) `shiftR` 3
  writeArray dest 3 $ ((bs `BSL.index` 1 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 2 .&. 192) `shiftR` 6)
  writeArray dest 4 $ (bs `BSL.index` 2 .&. 62) `shiftR` 1
  writeArray dest 5 $ ((bs `BSL.index` 2 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 3 .&. 240) `shiftR` 4)
  writeArray dest 6 $ ((bs `BSL.index` 3 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 4 .&. 128) `shiftR` 7)
  writeArray dest 7 $ (bs `BSL.index` 4 .&. 124) `shiftR` 2
  writeArray dest 8 $ ((bs `BSL.index` 4 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 5 .&. 224) `shiftR` 5)
  writeArray dest 9 $ bs `BSL.index` 5 .&. 31
  writeArray dest 10 $ (bs `BSL.index` 6 .&. 248) `shiftR` 3
  writeArray dest 11 $ ((bs `BSL.index` 6 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 7 .&. 192) `shiftR` 6)
  writeArray dest 12 $ (bs `BSL.index` 7 .&. 62) `shiftR` 1
  writeArray dest 13 $ ((bs `BSL.index` 7 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 8 .&. 240) `shiftR` 4)
  writeArray dest 14 $ ((bs `BSL.index` 8 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 9 .&. 128) `shiftR` 7)
  writeArray dest 15 $ (bs `BSL.index` 9 .&. 124) `shiftR` 2
  writeArray dest 16 $ ((bs `BSL.index` 9 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 10 .&. 224) `shiftR` 5)
  writeArray dest 17 $ bs `BSL.index` 10 .&. 31
  writeArray dest 18 $ (bs `BSL.index` 11 .&. 248) `shiftR` 3
  writeArray dest 19 $ ((bs `BSL.index` 11 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 12 .&. 192) `shiftR` 6)
  writeArray dest 20 $ (bs `BSL.index` 12 .&. 62) `shiftR` 1
  writeArray dest 21 $ ((bs `BSL.index` 12 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 13 .&. 240) `shiftR` 4)
  writeArray dest 22 $ ((bs `BSL.index` 13 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 14 .&. 128) `shiftR` 7)
  writeArray dest 23 $ (bs `BSL.index` 14 .&. 124) `shiftR` 2
  writeArray dest 24 $ ((bs `BSL.index` 14 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 15 .&. 224) `shiftR` 5)
  writeArray dest 25 $ bs `BSL.index` 15 .&. 31
  elems <$> unsafeFreeze dest
  where
    alphabet = listArray (0, 31) "0123456789abcdefghjkmnpqrstvwxyz"

suffixDecode :: ByteString -> ByteString
suffixDecode bs = BSL.pack $ runST do
  dest <- newArray_ (0, 15) :: ST s (STUArray s Int Word8)
  writeArray dest 0 $ ((base32Table ! (bs `BSL.index` 0)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 1))
  writeArray dest 1 $ ((base32Table ! (bs `BSL.index` 2)) `shiftL` 3) .|. ((base32Table ! (bs `BSL.index` 3)) `shiftR` 2)
  writeArray dest 2 $ ((base32Table ! (bs `BSL.index` 3)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 4)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 5)) `shiftR` 4)
  writeArray dest 3 $ ((base32Table ! (bs `BSL.index` 5)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 6)) `shiftR` 1)
  writeArray dest 4 $ ((base32Table ! (bs `BSL.index` 6)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 7)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 8)) `shiftR` 3)
  writeArray dest 5 $ ((base32Table ! (bs `BSL.index` 8)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 9))
  writeArray dest 6 $ ((base32Table ! (bs `BSL.index` 10)) `shiftL` 3) .|. ((base32Table ! (bs `BSL.index` 11)) `shiftR` 2)
  writeArray dest 7 $ ((base32Table ! (bs `BSL.index` 11)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 12)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 13)) `shiftR` 4)
  writeArray dest 8 $ ((base32Table ! (bs `BSL.index` 13)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 14)) `shiftR` 1)
  writeArray dest 9 $ ((base32Table ! (bs `BSL.index` 14)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 15)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 16)) `shiftR` 3)
  writeArray dest 10 $ ((base32Table ! (bs `BSL.index` 16)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 17))
  writeArray dest 11 $ ((base32Table ! (bs `BSL.index` 18)) `shiftL` 3) .|. (base32Table ! (bs `BSL.index` 19)) `shiftR` 2
  writeArray dest 12 $ ((base32Table ! (bs `BSL.index` 19)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 20)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 21)) `shiftR` 4)
  writeArray dest 13 $ ((base32Table ! (bs `BSL.index` 21)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 22)) `shiftR` 1)
  writeArray dest 14 $ ((base32Table ! (bs `BSL.index` 22)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 23)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 24)) `shiftR` 3)
  writeArray dest 15 $ ((base32Table ! (bs `BSL.index` 24)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 25))
  elems <$> unsafeFreeze dest

decodeUUID :: ByteString -> Either TypeIDError UUID
decodeUUID bs = do
  unless (BSL.length bs == 26) $ Left TypeIDErrorUUIDError
  unless (bs `BSL.index` 0 <= 55) $ Left TypeIDErrorUUIDError
  when (any ((== 0xFF) . (base32Table !)) $ BSL.unpack bs) $ Left TypeIDErrorUUIDError
  pure $ unsafeDecodeUUID bs
{-# INLINE decodeUUID #-}

unsafeDecodeUUID :: ByteString -> UUID
unsafeDecodeUUID
  = uncurry UUID . runGet (join (liftM2 (,)) getWord64be) . suffixDecode
{-# INLINE unsafeDecodeUUID #-}

base32Table :: Array Word8 Word8
base32Table = listArray (0, 255)
  [ 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x00, 0x01
  , 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x0A, 0x0B, 0x0C
  , 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0xFF, 0x12, 0x13, 0xFF, 0x14
  , 0x15, 0xFF, 0x16, 0x17, 0x18, 0x19, 0x1A, 0xFF, 0x1B, 0x1C
  , 0x1D, 0x1E, 0x1F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
  , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF ]