UUID.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module RON.UUID (
    UUID (..),
    UuidFields (..),
    build,
    buildX,
    buildY,
    split,
    succValue,
    addValue,
    zero,
    pattern Zero,

    -- * Fields as lenses
    variety,
    value,
    variant,
    version,
    origin,

    -- * Name
    getName,
    liftName,
    mkName,
    mkScopedName,

    -- * Base32 encoding, suitable for file names
    decodeBase32,
    encodeBase32,
) where

import RON.Prelude

import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.ByteString.Char8 qualified as BSC
import Language.Haskell.TH.Syntax (Exp, Q, liftData)
import Text.Show qualified

import RON.Base64 qualified as Base64
import RON.Util.Word (
    Word2,
    Word4,
    Word60,
    leastSignificant2,
    leastSignificant4,
    leastSignificant60,
    safeCast,
    pattern B00,
    pattern B0000,
    pattern B01,
    pattern B10,
    pattern B11,
 )

{- | Universally unique identifier of anything,
as documented in https://github.com/gritzko/ron/blob/master/uuid.md
-}
data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
    deriving (Data, Eq, Generic, Hashable, Ord)

-- | RON-Text-encoding
instance Show UUID where
    -- showsPrec a (UUID x y) =
    --     showParen (a >= 11) $
    --     showString "UUID 0x" . showHex x . showString " 0x" . showHex y
    show this = show serialized
      where
        UUID x y = this
        UuidFields{..} = split this
        serialized = case uuidVariant of
            B00 -> unzipped
            _ -> generic
        unzipped = x' <> y'
        variety' = case uuidVariety of
            B0000 -> ""
            _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/"
        x' = variety' <> BSC.unpack (Base64.encode60short uuidValue)
        y' = case (uuidVersion, uuidOrigin) of
            (B00, safeCast -> 0 :: Word64) -> ""
            _ -> version' : BSC.unpack (Base64.encode60short uuidOrigin)
        generic = BSC.unpack $ Base64.encode64 x <> Base64.encode64 y
        version' = case uuidVersion of
            B00 -> '$'
            B01 -> '%'
            B10 -> '+'
            B11 -> '-'

-- | UUID split in parts
data UuidFields = UuidFields
    { uuidVariety :: !Word4
    , uuidValue :: !Word60
    , uuidVariant :: !Word2
    , uuidVersion :: !Word2
    , uuidOrigin :: !Word60
    }
    deriving (Eq, Show)

-- | Split UUID into parts
split :: UUID -> UuidFields
split (UUID x y) =
    UuidFields
        { uuidVariety = leastSignificant4 $ x `shiftR` 60
        , uuidValue = leastSignificant60 x
        , uuidVariant = leastSignificant2 $ y `shiftR` 62
        , uuidVersion = leastSignificant2 $ y `shiftR` 60
        , uuidOrigin = leastSignificant60 y
        }

-- | Build UUID from parts
build :: UuidFields -> UUID
build UuidFields{..} =
    UUID
        (buildX uuidVariety uuidValue)
        (buildY uuidVariant uuidVersion uuidOrigin)

-- | Build former 64 bits of UUID from parts
buildX :: Word4 -> Word60 -> Word64
buildX uuidVariety uuidValue =
    (safeCast uuidVariety `shiftL` 60) .|. safeCast uuidValue

-- | Build latter 64 bits of UUID from parts
buildY :: Word2 -> Word2 -> Word60 -> Word64
buildY uuidVariant uuidVersion uuidOrigin =
    (safeCast uuidVariant `shiftL` 62)
        .|. (safeCast uuidVersion `shiftL` 60)
        .|. safeCast uuidOrigin

-- | Make an unscoped (unqualified) name
mkName ::
    (MonadFail m) =>
    -- | name, max 10 Base64 letters
    ByteString ->
    m UUID
mkName nam = mkScopedName nam ""

-- | Contruct a UUID name in compile-time
liftName :: ByteString -> Q Exp
liftName = mkName >=> liftData

-- TODO(2019-01-11, cblp) typed splice

-- | Make a scoped (qualified) name
mkScopedName ::
    (MonadFail m) =>
    -- | scope, max 10 Base64 letters
    ByteString ->
    -- | local name, max 10 Base64 letters
    ByteString ->
    m UUID
mkScopedName scope nam = do
    scope' <- expectBase64x60 "UUID scope" scope $ Base64.decode60 scope
    nam' <- expectBase64x60 "UUID name" nam $ Base64.decode60 nam
    pure $
        build
            UuidFields
                { uuidVariety = B0000
                , uuidValue = scope'
                , uuidVariant = B00
                , uuidVersion = B00
                , uuidOrigin = nam'
                }
  where
    expectBase64x60 field input =
        maybe
            ( fail $
                field
                    <> ": expected a Base64-encoded 10-character string, got "
                    <> show input
            )
            pure

-- | Convert UUID to a name
getName ::
    UUID ->
    -- | @(scope, name)@ for a scoped name; @(name, "")@ for a global name
    Maybe (ByteString, ByteString)
getName uuid =
    case split uuid of
        UuidFields
            { uuidVariety = B0000
            , uuidVariant = B00
            , uuidVersion = B00
            , uuidValue
            , uuidOrigin
            } ->
                Just (x, y)
              where
                x = Base64.encode60short uuidValue
                y = case safeCast uuidOrigin :: Word64 of
                    0 -> ""
                    _ -> Base64.encode60short uuidOrigin
        _ -> Nothing

-- | UUID with all zero fields
zero :: UUID
zero = UUID 0 0

-- | UUID with all zero fields
pattern Zero :: UUID
pattern Zero = UUID 0 0

-- | Increment field 'uuidValue' of a UUID
succValue :: UUID -> UUID
succValue = build . go . split
  where
    go u@UuidFields{uuidValue} =
        u
            { uuidValue =
                if uuidValue < maxBound then succ uuidValue else uuidValue
            }

-- | Increase field 'uuidValue' of a UUID
addValue :: UUID -> Word60 -> UUID
addValue uu v = build u{uuidValue = uuidValue + v}
  where
    u@UuidFields{uuidValue} = split uu

-- | Encode a UUID to a Base32 string
encodeBase32 :: UUID -> FilePath
encodeBase32 (UUID x y) =
    BSC.unpack $
        Base64.encode64base32short x <> "-" <> Base64.encode64base32short y

-- | Decode a UUID from a Base32 string
decodeBase32 :: FilePath -> Maybe UUID
decodeBase32 fp = do
    let (x, dashy) = span (/= '-') $ map toUpper fp
    ("-", y) <- pure $ splitAt 1 dashy
    UUID
        <$> Base64.decode64base32 (BSC.pack x)
        <*> Base64.decode64base32 (BSC.pack y)

variety :: Lens' UUID Word4
variety =
    lens
        (\(UUID x _) -> leastSignificant4 $ x `shiftR` 60)
        ( \(UUID x y) v ->
            UUID (x .&. 0x0FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) y
        )

value :: Lens' UUID Word60
value =
    lens
        (\(UUID x _) -> leastSignificant60 x)
        (\(UUID x y) v -> UUID (x .&. 0xF000000000000000 .|. safeCast v) y)

variant :: Lens' UUID Word2
variant =
    lens
        (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 62)
        ( \(UUID x y) v ->
            UUID x (y .&. 0x3FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 62))
        )

version :: Lens' UUID Word2
version =
    lens
        (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 60)
        ( \(UUID x y) v ->
            UUID x (y .&. 0xCFFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60))
        )

origin :: Lens' UUID Word60
origin =
    lens
        (\(UUID _ y) -> leastSignificant60 y)
        (\(UUID x y) v -> UUID x (y .&. 0xF000000000000000 .|. safeCast v))

type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t

type Lens' s a = Lens s s a a

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens sa sbt afb s = sbt s <$> afb (sa s)
{-# INLINE lens #-}