-- Copyright (c) 2023  Herbert Valerio Riedel <hvr@gnu.org>
--
--  This file is free software: you may copy, redistribute and/or modify it
--  under the terms of the GNU General Public License as published by the
--  Free Software Foundation, either version 2 of the License, or (at your
--  option) any later version.
--
--  This file is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program (see `LICENSE`).  If not, see
--  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>.

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE Trustworthy                #-}

-- |
-- Copyright: © Herbert Valerio Riedel 2023
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- LDAP OID Helpers
--
-- This module provides helpers for dealing with the representation of /Object Identifiers/ (OID) in LDAP.
--
-- @since 0.1.2
module LDAPv3.OID
   ( -- * Textually encoded OIDs
     LDAPOID
   , OID(OID)

     -- * Binary encoded OIDs
   , OBJECT_IDENTIFIER
   , object_identifier'toOID
   , object_identifier'fromOID

   , object_identifier'toBin
   , object_identifier'fromBin

     -- * Convenience helpers
   , IsWellFormedOid(isWellFormedOid)
   ) where

import           Common                  hiding (Option, many, option, some, (<|>))
import           Data.ASN1
import           Data.ASN1.Prim
import           LDAPv3.StringRepr.Class

import qualified Data.Binary             as Bin
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8   as BSC
import qualified Data.ByteString.Lazy    as BSL
import qualified Data.ByteString.Short   as SBS
import           Data.List
import qualified Data.Text               as T
import qualified Data.Text.Lazy          as TL
import           Data.Text.Lazy.Builder  as B
import qualified Data.Text.Short         as TS
import           Numeric                 (showHex)
import           Text.Parsec             as P

-- | Typeclass for 'isWellFormedOid' operation
--
-- @since 0.1.2
class IsWellFormedOid t where
  -- | Determine whether OID representation is deemed well-formed
  --
  -- An OID is considered well-formed /iff/ it has
  --
  --  * at least two arcs,
  --  * the first arc is one of @0@, @1@, or @2@, and
  --  * if the first arc is /not/ @2@, the second arc value is within the range @[0 .. 39]@.
  --
  -- Additionally, for string types the IETF-style ASCII dot notation with normalized (i.e. without redundant leading
  -- zeros) decimal numbers is expected (e.g. @1.23.456.7.890@) as expressed by the @numericoid@ ABNF production shown
  -- below:
  --
  -- > numericoid = number 1*( DOT number )
  -- > number  = DIGIT / ( LDIGIT 1*DIGIT )
  -- > DIGIT   = %x30 / LDIGIT       ; "0"-"9"
  -- > LDIGIT  = %x31-39             ; "1"-"9"
  --
  -- @since 0.1.2
  isWellFormedOid :: t -> Bool


{- | Object identifier  (<https://tools.ietf.org/html/rfc4511#section-4.1.2 RFC4511 Section 4.1.2>)

> LDAPOID ::= OCTET STRING -- Constrained to <numericoid>
>                          -- [RFC4512]

@since 0.1.0
-}
type LDAPOID = OID


{- | Numeric Object Identifier (OID)

> numericoid = number 1*( DOT number )
> number  = DIGIT / ( LDIGIT 1*DIGIT )
> DIGIT   = %x30 / LDIGIT       ; "0"-"9"
> LDIGIT  = %x31-39             ; "1"-"9"

NB: The current type definition and its 'StringRepr' instance currently allows to represent and parse more than the ABNF
    described above; moreover, the ABNF is also more liberal as it doesn't express the constraints imposed upon the
    first two arcs by @X.660@ and @ASN.1@. See also 'isWellFormedOid'.

@since 0.1.0
-}
newtype OID = OID (NonEmpty Natural)
  deriving (OID -> OID -> Bool
(OID -> OID -> Bool) -> (OID -> OID -> Bool) -> Eq OID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OID -> OID -> Bool
$c/= :: OID -> OID -> Bool
== :: OID -> OID -> Bool
$c== :: OID -> OID -> Bool
Eq,Eq OID
Eq OID =>
(OID -> OID -> Ordering)
-> (OID -> OID -> Bool)
-> (OID -> OID -> Bool)
-> (OID -> OID -> Bool)
-> (OID -> OID -> Bool)
-> (OID -> OID -> OID)
-> (OID -> OID -> OID)
-> Ord OID
OID -> OID -> Bool
OID -> OID -> Ordering
OID -> OID -> OID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OID -> OID -> OID
$cmin :: OID -> OID -> OID
max :: OID -> OID -> OID
$cmax :: OID -> OID -> OID
>= :: OID -> OID -> Bool
$c>= :: OID -> OID -> Bool
> :: OID -> OID -> Bool
$c> :: OID -> OID -> Bool
<= :: OID -> OID -> Bool
$c<= :: OID -> OID -> Bool
< :: OID -> OID -> Bool
$c< :: OID -> OID -> Bool
compare :: OID -> OID -> Ordering
$ccompare :: OID -> OID -> Ordering
$cp1Ord :: Eq OID
Ord,Int -> OID -> ShowS
[OID] -> ShowS
OID -> String
(Int -> OID -> ShowS)
-> (OID -> String) -> ([OID] -> ShowS) -> Show OID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OID] -> ShowS
$cshowList :: [OID] -> ShowS
show :: OID -> String
$cshow :: OID -> String
showsPrec :: Int -> OID -> ShowS
$cshowsPrec :: Int -> OID -> ShowS
Show,OID -> ()
(OID -> ()) -> NFData OID
forall a. (a -> ()) -> NFData a
rnf :: OID -> ()
$crnf :: OID -> ()
NFData)

instance Newtype OID (NonEmpty Natural)

instance ASN1 OID where
  asn1defTag :: Proxy OID -> Tag
asn1defTag _   = Proxy OCTET_STRING -> Tag
forall t. ASN1 t => Proxy t -> Tag
asn1defTag (Proxy OCTET_STRING
forall k (t :: k). Proxy t
Proxy :: Proxy OCTET_STRING)
  asn1encode :: OID -> ASN1Encode Word64
asn1encode oid :: OID
oid = OCTET_STRING -> ASN1Encode Word64
forall t. ASN1 t => t -> ASN1Encode Word64
asn1encode (String -> OCTET_STRING
BSC.pack (OID -> String
s'OID OID
oid))
  asn1decode :: ASN1Decode OID
asn1decode     = String -> Parser OID -> ASN1Decode OID
forall t. String -> Parser t -> ASN1Decode t
asn1decodeParsec "OID" Parser OID
forall s. Stream s Identity Char => Parsec s () OID
p'OID

instance StringRepr OID where
  asBuilder :: OID -> Builder
asBuilder       = String -> Builder
B.fromString (String -> Builder) -> (OID -> String) -> OID -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OID -> String
s'OID
  renderShortText :: OID -> ShortText
renderShortText = String -> ShortText
TS.fromString (String -> ShortText) -> (OID -> String) -> OID -> ShortText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OID -> String
s'OID
  asParsec :: Parsec s () OID
asParsec        = Parsec s () OID
forall s. Stream s Identity Char => Parsec s () OID
p'OID

-- Ideally this instance will become redundant/trivial in the future as it currently papers over an inadequacy in the
-- current definition of the 'OID' type
instance IsWellFormedOid OID where
  isWellFormedOid :: OID -> Bool
isWellFormedOid (OID s :: NonEmpty Natural
s) = case NonEmpty Natural
s of
    0 :| (y :: Natural
y:_) | Natural
y Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 40 -> Bool
True
    1 :| (y :: Natural
y:_) | Natural
y Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 40 -> Bool
True
    2 :| (_:_)          -> Bool
True
    _                   -> Bool
False

-- the main cost is dealing with formatting the 'Natural' components and it's not obvious if it's worth the complexity
-- optimizing a more direct path for 'ShortText'
s'OID :: OID -> String
s'OID :: OID -> String
s'OID (OID (x :: Natural
x:|xs :: [Natural]
xs)) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ((Natural -> String) -> [Natural] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Natural -> String
forall a. Show a => a -> String
show (Natural
xNatural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
:[Natural]
xs))

p'OID :: Stream s Identity Char => Parsec s () OID
p'OID :: Parsec s () OID
p'OID = Parsec s () OID
forall u. ParsecT s u Identity OID
p'numericoid
  where
    -- numericoid = number 1*( DOT number )
    p'numericoid :: ParsecT s u Identity OID
p'numericoid = NonEmpty Natural -> OID
OID (NonEmpty Natural -> OID)
-> ParsecT s u Identity (NonEmpty Natural)
-> ParsecT s u Identity OID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT s u Identity Natural
forall u. ParsecT s u Identity Natural
p'number ParsecT s u Identity Natural
-> ParsecT s u Identity Char
-> ParsecT s u Identity (NonEmpty Natural)
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m (NonEmpty a)
`sepBy1'` Char -> ParsecT s u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.')

    -- number  = DIGIT / ( LDIGIT 1*DIGIT )
    -- DIGIT   = %x30 / LDIGIT       ; "0"-"9"
    -- LDIGIT  = %x31-39             ; "1"-"9"
    p'number :: ParsecT s u Identity Natural
p'number = do
      Char
ldigit <- ParsecT s u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
      if Char
ldigit Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0'
         then Natural -> ParsecT s u Identity Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
         else String -> Natural
forall a. Read a => String -> a
read (String -> Natural) -> ShowS -> String -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
ldigitChar -> ShowS
forall a. a -> [a] -> [a]
:) (String -> Natural)
-> ParsecT s u Identity String -> ParsecT s u Identity Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u Identity Char -> ParsecT s u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

{-# INLINE wf'OID #-}
wf'OID :: String -> Bool
wf'OID :: String -> Bool
wf'OID = \case
    '0':'.':rest :: String
rest -> String -> Bool
go01 String
rest
    '1':'.':rest :: String
rest -> String -> Bool
go01 String
rest
    '2':'.':rest :: String
rest -> String -> Bool
go String
rest
    _            -> Bool
False
  where
    -- enforce 2nd arc to be within (canonically represented) [0..39] range
    go01 :: String -> Bool
go01 [d1 :: Char
d1]    | Char -> Bool
isD Char
d1                       = Bool
True
    go01 [d1 :: Char
d1,d2 :: Char
d2] | Char
d1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '1', Char
d1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '3', Char -> Bool
isD Char
d2 = Bool
True
    go01 (d1 :: Char
d1:'.':rest :: String
rest)    | Char -> Bool
isD Char
d1                       = String -> Bool
go String
rest
    go01 (d1 :: Char
d1:d2 :: Char
d2:'.':rest :: String
rest) | Char
d1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '1', Char
d1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '3', Char -> Bool
isD Char
d2 = String -> Bool
go String
rest
    go01 _ = Bool
False

    -- subsequent arcs without upper bounds
    go :: String -> Bool
go (c :: Char
c:rest :: String
rest)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0' = case String
rest of
                    []        -> Bool
True
                    '.':rest' :: String
rest' -> String -> Bool
go String
rest'
                    _         -> Bool
False
      | Char -> Bool
isNZD Char
c = case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isD String
rest of
                    []        -> Bool
True
                    '.':rest' :: String
rest' -> String -> Bool
go String
rest'
                    _:_       -> Bool
False
    go _ = Bool
False

    isNZD :: Char -> Bool
isNZD c :: Char
c = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '1' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9'
    isD :: Char -> Bool
isD c :: Char
c   = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9'

-- the instances below work best if the compiler manages to optimize away the intermediate @[Char]@ ...

instance IsWellFormedOid ShortText where
    isWellFormedOid :: ShortText -> Bool
isWellFormedOid = String -> Bool
wf'OID (String -> Bool) -> (ShortText -> String) -> ShortText -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> String
TS.unpack

instance IsWellFormedOid T.Text where
    isWellFormedOid :: Text -> Bool
isWellFormedOid = String -> Bool
wf'OID (String -> Bool) -> (Text -> String) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance IsWellFormedOid TL.Text where
    isWellFormedOid :: Text -> Bool
isWellFormedOid = String -> Bool
wf'OID (String -> Bool) -> (Text -> String) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack


-- | ASN.1 @OBJECT IDENTIFIER@
--
-- The 'OID' type uses the textual LDAP encoding when converted to/from ASN.1 whereas this type provides the proper ASN.1 encoding as defined per X.690 section 8.19 (accessible via its 'Binary' instance).
--
-- @since 0.1.2
newtype OBJECT_IDENTIFIER = OID_ SBS.ShortByteString {- content encoded as per X.690 sec. 8.19 -}
  deriving (OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
(OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool)
-> (OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool)
-> Eq OBJECT_IDENTIFIER
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
$c/= :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
== :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
$c== :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
Eq,OBJECT_IDENTIFIER -> ()
(OBJECT_IDENTIFIER -> ()) -> NFData OBJECT_IDENTIFIER
forall a. (a -> ()) -> NFData a
rnf :: OBJECT_IDENTIFIER -> ()
$crnf :: OBJECT_IDENTIFIER -> ()
NFData)

instance Show OBJECT_IDENTIFIER where
    showsPrec :: Int -> OBJECT_IDENTIFIER -> ShowS
showsPrec _ (OID_ z :: ShortByteString
z) = ("OID<"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\s :: String
s -> (Word8 -> ShowS) -> String -> [Word8] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> ShowS
hex8 String
s (ShortByteString -> [Word8]
SBS.unpack ShortByteString
z)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ('>'Char -> ShowS
forall a. a -> [a] -> [a]
:)
      where
        hex8 :: Word8 -> ShowS
        hex8 :: Word8 -> ShowS
hex8 x :: Word8
x
          | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x10  = ('0'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
x
          | Bool
otherwise = Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
x

-- | Lexicographic ordering
instance Ord OBJECT_IDENTIFIER where
  compare :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Ordering
compare = OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Ordering
compareSubIds

instance ASN1 OBJECT_IDENTIFIER where
  asn1defTag :: Proxy OBJECT_IDENTIFIER -> Tag
asn1defTag _ = Word64 -> Tag
Universal 6
  asn1encode :: OBJECT_IDENTIFIER -> ASN1Encode Word64
asn1encode (OID_ sbs :: ShortByteString
sbs) = Tag -> ASN1Encode Word64 -> ASN1Encode Word64
forall a. Tag -> ASN1Encode a -> ASN1Encode a
retag (Word64 -> Tag
Universal 6) (ASN1Encode Word64 -> ASN1Encode Word64)
-> ASN1Encode Word64 -> ASN1Encode Word64
forall a b. (a -> b) -> a -> b
$ ShortByteString -> ASN1Encode Word64
forall t. ASN1 t => t -> ASN1Encode Word64
asn1encode ShortByteString
sbs
  asn1decode :: ASN1Decode OBJECT_IDENTIFIER
asn1decode = Tag -> ASN1Decode OBJECT_IDENTIFIER -> ASN1Decode OBJECT_IDENTIFIER
forall x. Tag -> ASN1Decode x -> ASN1Decode x
implicit (Word64 -> Tag
Universal 6)
               (ASN1Decode ShortByteString
forall t. ASN1 t => ASN1Decode t
asn1decode ASN1Decode ShortByteString
-> (ShortByteString -> Either String OBJECT_IDENTIFIER)
-> ASN1Decode OBJECT_IDENTIFIER
forall x y. ASN1Decode x -> (x -> Either String y) -> ASN1Decode y
`transformVia`
                (Either String OBJECT_IDENTIFIER
-> (OBJECT_IDENTIFIER -> Either String OBJECT_IDENTIFIER)
-> Maybe OBJECT_IDENTIFIER
-> Either String OBJECT_IDENTIFIER
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String OBJECT_IDENTIFIER
forall a b. a -> Either a b
Left "not well-formed OBJECT IDENTIFIER") OBJECT_IDENTIFIER -> Either String OBJECT_IDENTIFIER
forall a b. b -> Either a b
Right (Maybe OBJECT_IDENTIFIER -> Either String OBJECT_IDENTIFIER)
-> (ShortByteString -> Maybe OBJECT_IDENTIFIER)
-> ShortByteString
-> Either String OBJECT_IDENTIFIER
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Maybe OBJECT_IDENTIFIER
object_identifier'fromBin))

instance StringRepr OBJECT_IDENTIFIER where
  asBuilder :: OBJECT_IDENTIFIER -> Builder
asBuilder       = OID -> Builder
forall a. StringRepr a => a -> Builder
asBuilder (OID -> Builder)
-> (OBJECT_IDENTIFIER -> OID) -> OBJECT_IDENTIFIER -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OBJECT_IDENTIFIER -> OID
object_identifier'toOID
  renderShortText :: OBJECT_IDENTIFIER -> ShortText
renderShortText = OID -> ShortText
forall a. StringRepr a => a -> ShortText
renderShortText (OID -> ShortText)
-> (OBJECT_IDENTIFIER -> OID) -> OBJECT_IDENTIFIER -> ShortText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OBJECT_IDENTIFIER -> OID
object_identifier'toOID
  asParsec :: Parsec s () OBJECT_IDENTIFIER
asParsec        = do
    OID
x <- Parsec s () OID
forall s. Stream s Identity Char => Parsec s () OID
p'OID
    case OID -> Maybe OBJECT_IDENTIFIER
object_identifier'fromOID OID
x of
      Nothing -> String -> Parsec s () OBJECT_IDENTIFIER
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid top-level arcs"
      Just y :: OBJECT_IDENTIFIER
y  -> OBJECT_IDENTIFIER -> Parsec s () OBJECT_IDENTIFIER
forall (f :: * -> *) a. Applicative f => a -> f a
pure OBJECT_IDENTIFIER
y

-- | Encodes as ASN.1 BER\/DER with @UNIVERSAL 6@ tag as per X.690 section 8.19
instance Bin.Binary OBJECT_IDENTIFIER where
  get :: Get OBJECT_IDENTIFIER
get = ASN1Decode OBJECT_IDENTIFIER -> Get OBJECT_IDENTIFIER
forall x. ASN1Decode x -> Get x
toBinaryGet ASN1Decode OBJECT_IDENTIFIER
forall t. ASN1 t => ASN1Decode t
asn1decode
  put :: OBJECT_IDENTIFIER -> Put
put = PutM Word64 -> Put
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PutM Word64 -> Put)
-> (OBJECT_IDENTIFIER -> PutM Word64) -> OBJECT_IDENTIFIER -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Encode Word64 -> PutM Word64
forall a. ASN1Encode a -> PutM a
toBinaryPut (ASN1Encode Word64 -> PutM Word64)
-> (OBJECT_IDENTIFIER -> ASN1Encode Word64)
-> OBJECT_IDENTIFIER
-> PutM Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OBJECT_IDENTIFIER -> ASN1Encode Word64
forall t. ASN1 t => t -> ASN1Encode Word64
asn1encode

-- | Trivial instance as 'OBJECT_IDENTIFIER' values are always well-formed by construction
instance IsWellFormedOid OBJECT_IDENTIFIER where
  isWellFormedOid :: OBJECT_IDENTIFIER -> Bool
isWellFormedOid = Bool -> OBJECT_IDENTIFIER -> Bool
forall a b. a -> b -> a
const Bool
True

-- | Encode as raw ASN.1 BER\/DER value (i.e. without tag & length)
--
-- NB: As this function simply returns the internal representation this operation has zero cost.
--
-- @since 0.1.2
object_identifier'toBin :: OBJECT_IDENTIFIER -> SBS.ShortByteString
object_identifier'toBin :: OBJECT_IDENTIFIER -> ShortByteString
object_identifier'toBin (OID_ sbs :: ShortByteString
sbs) = ShortByteString
sbs

-- | Decode from raw ASN.1 BER\/DER value (i.e. without tag & length)
--
-- All byte sequences are deemed well-formed raw ASN.1 OID encodings that satisfy the simple rules below (which ought to result in the same syntax as the rules specified in X.690 section 8.19.):
--
--  * The sequence must end with an octet with a value below @0x80@ (i.e. unset MSB), and
--  * any @0x80@ octet must be directly preceded by an octet which must have a value equal or greater than @0x80@ (i.e. set MSB).
--
-- In case these rules are not satisfied this function returns 'Nothing'.
--
-- NB: As this encoding matches the internal representation the resulting 'OBJECT_IDENTIFIER' merely @newtype@-wraps the input argument on success.
--
-- @since 0.1.2
object_identifier'fromBin :: SBS.ShortByteString -> Maybe OBJECT_IDENTIFIER
object_identifier'fromBin :: ShortByteString -> Maybe OBJECT_IDENTIFIER
object_identifier'fromBin z :: ShortByteString
z
  | Bool
isValid   = OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a. a -> Maybe a
Just (ShortByteString -> OBJECT_IDENTIFIER
OID_ ShortByteString
z)
  | Bool
otherwise = Maybe OBJECT_IDENTIFIER
forall a. Maybe a
Nothing
  where
    isValid :: Bool
isValid = case ShortByteString -> [Word8]
SBS.unpack ShortByteString
z of
      [] -> Bool
False
      xs :: [Word8]
xs -> Word8 -> [Word8] -> Bool
forall t. (Ord t, Num t) => t -> [t] -> Bool
go 0x00 [Word8]
xs

    go :: t -> [t] -> Bool
go pre :: t
pre []       = t
pre t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80
    go pre :: t
pre (0x80:xs :: [t]
xs)
      | t
pre t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x80 = t -> [t] -> Bool
go 0x80 [t]
xs
      | Bool
otherwise   = Bool
False
    go _ (x :: t
x:xs :: [t]
xs)     = t -> [t] -> Bool
go t
x [t]
xs

-- | Convert 'OBJECT_IDENTIFIER' into 'OID' representation
--
-- @since 0.1.2
object_identifier'toOID :: OBJECT_IDENTIFIER -> OID
object_identifier'toOID :: OBJECT_IDENTIFIER -> OID
object_identifier'toOID oid :: OBJECT_IDENTIFIER
oid = case OBJECT_IDENTIFIER -> [Natural]
decodeSubIds OBJECT_IDENTIFIER
oid of
  [] -> String -> OID
forall a. HasCallStack => String -> a
error "the impossible just happened: internal invariant of OBJECT_IDENTIFIER broken"
  (i0 :: Natural
i0:is :: [Natural]
is)
    | Natural
i0 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 40   -> NonEmpty Natural -> OID
OID (0 Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| (Natural
i0 Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
is))
    | Natural
i0 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 80   -> NonEmpty Natural -> OID
OID (1 Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| (Natural
i0Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
-40 Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
is))
    | Bool
otherwise -> NonEmpty Natural -> OID
OID (2 Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| (Natural
i0Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
-80 Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Natural]
is))

-- NB: the next major version shall avoid the 'Maybe' in the typesig
-- | Try to 'OID' representation into 'OBJECT_IDENTIFIER' representation
--
-- NB: This will return 'Nothing' /iff/ 'isWellFormedOid' returns 'False' on the input argument.
--
-- @since 0.1.2
object_identifier'fromOID :: OID -> Maybe OBJECT_IDENTIFIER
object_identifier'fromOID :: OID -> Maybe OBJECT_IDENTIFIER
object_identifier'fromOID (OID s :: NonEmpty Natural
s) = case NonEmpty Natural
s of
  0 :| (y :: Natural
y:rest :: [Natural]
rest) | Natural
y Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 40 -> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a. a -> Maybe a
Just (OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER)
-> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a b. (a -> b) -> a -> b
$ NonEmpty Natural -> OBJECT_IDENTIFIER
encodeSubIds (Natural
y Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| [Natural]
rest)
  1 :| (y :: Natural
y:rest :: [Natural]
rest) | Natural
y Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 40 -> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a. a -> Maybe a
Just (OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER)
-> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a b. (a -> b) -> a -> b
$ NonEmpty Natural -> OBJECT_IDENTIFIER
encodeSubIds (Natural
yNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+40 Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| [Natural]
rest)
  2 :| (y :: Natural
y:rest :: [Natural]
rest)          -> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a. a -> Maybe a
Just (OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER)
-> OBJECT_IDENTIFIER -> Maybe OBJECT_IDENTIFIER
forall a b. (a -> b) -> a -> b
$ NonEmpty Natural -> OBJECT_IDENTIFIER
encodeSubIds (Natural
yNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+80 Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| [Natural]
rest)
  _                      -> Maybe OBJECT_IDENTIFIER
forall a. Maybe a
Nothing -- invalid OID

encodeSubIds :: NonEmpty Natural -> OBJECT_IDENTIFIER
encodeSubIds :: NonEmpty Natural -> OBJECT_IDENTIFIER
encodeSubIds (z :: Natural
z:|zs :: [Natural]
zs) = ShortByteString -> OBJECT_IDENTIFIER
OID_ (ShortByteString -> OBJECT_IDENTIFIER)
-> ShortByteString -> OBJECT_IDENTIFIER
forall a b. (a -> b) -> a -> b
$ OCTET_STRING -> ShortByteString
SBS.toShort (OCTET_STRING -> ShortByteString)
-> OCTET_STRING -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> OCTET_STRING
BSL.toStrict (ByteString -> OCTET_STRING) -> ByteString -> OCTET_STRING
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BSB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Natural -> Builder) -> [Natural] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Natural -> Builder
subid (Natural
zNatural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
:[Natural]
zs))
  where
    subid :: Natural -> BSB.Builder
    subid :: Natural -> Builder
subid x :: Natural
x
      | Natural
x Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 0x100000000 {- i.e. 2^32 -} = Bool -> Word32 -> Builder
encodeWord32 Bool
False (Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x) -- shortcut
      | Bool
otherwise = let (x' :: Natural
x',x'' :: Word32
x'') = (Natural -> Word32) -> (Natural, Natural) -> (Natural, Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
x 0x10000000) -- NB: 0x80^4, *not* 2^32
                    in Natural -> Builder
subid1 Natural
x' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Bool -> Word32 -> Builder
encodeWord32 Bool
True Word32
x''

    subid1 :: Natural -> BSB.Builder
    subid1 :: Natural -> Builder
subid1 0 = Builder
forall a. Monoid a => a
mempty -- NB: never reached due to shortcut
    subid1 x :: Natural
x
      | Natural
x Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80 = Word8 -> Builder
BSB.word8 (Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) -- shortcut
      | Bool
otherwise = let (x' :: Natural
x',x'' :: Word8
x'') = (Natural -> Word8) -> (Natural, Natural) -> (Natural, Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
x 0x80)
                    in Natural -> Builder
subid1 Natural
x' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` (Word8 -> Builder
BSB.word8 (Word8
x'' Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80))

    -- fast-path for 32bit values encoded in up to 5 octects;
    -- if enabled, pre-pad with 0x80 octects to 4 octets
    encodeWord32 :: Bool -> Word32 -> BSB.Builder
    encodeWord32 :: Bool -> Word32 -> Builder
encodeWord32 dopad :: Bool
dopad w :: Word32
w
      | Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80     = Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
pad' (Word16 -> Builder
BSB.word16BE 0x8080 Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<> Word8 -> Builder
BSB.word8 0x80) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
      | Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x4000   = Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
pad' (Word16 -> Builder
BSB.word16BE 0x8080) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR`  7) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f)
      | Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x200000 = Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
pad' (Word8 -> Builder
BSB.word8 0x80) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 14) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR`  7) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f)
      | Word32
w Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x10000000 =
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 21) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 14) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR`  7) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f)
      | Bool
dopad = String -> Builder
forall a. HasCallStack => String -> a
error "the impossible happened (encodeWord32)"
      | Bool
otherwise =
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 28) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 21) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 14) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR`  7) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. 0x80) Builder -> Builder -> Builder
forall p. Semigroup p => p -> p -> p
<>
            Word8 -> Builder
BSB.word8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f)
      where
        pad' :: p -> p -> p
pad' thepad :: p
thepad x :: p
x
          | Bool
dopad     = p
thepad p -> p -> p
forall p. Semigroup p => p -> p -> p
<> p
x
          | Bool
otherwise = p
x


decodeSubIds :: OBJECT_IDENTIFIER -> [Natural]
decodeSubIds :: OBJECT_IDENTIFIER -> [Natural]
decodeSubIds (OID_ b :: ShortByteString
b) = [Word8] -> [Natural]
go0 (ShortByteString -> [Word8]
SBS.unpack ShortByteString
b)
  where
    go0 :: [Word8] -> [Natural]
go0 [] = []
    go0 (x :: Word8
x:rest :: [Word8]
rest)
      | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80 = Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Word8] -> [Natural]
go0 [Word8]
rest
      | Bool
otherwise = Natural -> [Word8] -> [Natural]
go1 (Natural -> Natural
shift7 (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Word8 -> Natural
stripMsb Word8
x) [Word8]
rest

    go1 :: Natural -> [Word8] -> [Natural]
go1 _ [] = String -> [Natural]
forall a. HasCallStack => String -> a
error "the impossible just happened: internal invariant of OBJECT_IDENTIFIER broken"
    go1 acc :: Natural
acc (x :: Word8
x:rest :: [Word8]
rest)
      | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80  = (Natural
acc Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x) Natural -> [Natural] -> [Natural]
forall a. a -> [a] -> [a]
: [Word8] -> [Natural]
go0 [Word8]
rest
      | Bool
otherwise = Natural -> [Word8] -> [Natural]
go1 (Natural -> Natural
shift7 (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural
acc Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Word8 -> Natural
stripMsb Word8
x) [Word8]
rest

    stripMsb :: Word8 -> Natural
    stripMsb :: Word8 -> Natural
stripMsb x :: Word8
x = Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f)

    shift7 :: Natural -> Natural
    shift7 :: Natural -> Natural
shift7 x :: Natural
x = Natural
x Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 7

-- efficient lexicographic streaming
--
-- This is supposed to be semantically equivalent to
--
-- > compareSubIds x y = compare (decodeSubIds x) (decodeSubIds y)
--
-- NB: this implementation relies on 'mappend' over 'Ordering' shortcutting
compareSubIds :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Ordering
compareSubIds :: OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Ordering
compareSubIds x :: OBJECT_IDENTIFIER
x y :: OBJECT_IDENTIFIER
y | OBJECT_IDENTIFIER
x OBJECT_IDENTIFIER -> OBJECT_IDENTIFIER -> Bool
forall a. Eq a => a -> a -> Bool
== OBJECT_IDENTIFIER
y = Ordering
EQ -- fast shortcut
compareSubIds (OID_ bx :: ShortByteString
bx) (OID_ by :: ShortByteString
by) = Ordering -> [Word8] -> [Word8] -> Ordering
forall a.
(Show a, Ord a, Num a) =>
Ordering -> [a] -> [a] -> Ordering
go Ordering
EQ (ShortByteString -> [Word8]
SBS.unpack ShortByteString
bx) (ShortByteString -> [Word8]
SBS.unpack ShortByteString
by)
  where
    go :: Ordering -> [a] -> [a] -> Ordering
go c :: Ordering
c (x :: a
x:xs :: [a]
xs) (y :: a
y:ys :: [a]
ys)
      | Bool
finX, Bool
finY = Ordering
c Ordering -> Ordering -> Ordering
forall p. Semigroup p => p -> p -> p
<> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y Ordering -> Ordering -> Ordering
forall p. Semigroup p => p -> p -> p
<> Ordering -> [a] -> [a] -> Ordering
go Ordering
EQ [a]
xs [a]
ys
      | Bool
finX       = Ordering
LT
      | Bool
finY       = Ordering
GT
      | Bool
otherwise  = Ordering -> [a] -> [a] -> Ordering
go (Ordering
c Ordering -> Ordering -> Ordering
forall p. Semigroup p => p -> p -> p
<> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y) [a]
xs [a]
ys
      where
        finX :: Bool
finX = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80
        finY :: Bool
finY = a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80

    go EQ (_:_) [] = Ordering
GT
    go EQ [] (_:_) = Ordering
LT
    go EQ [] []    = Ordering
EQ -- actually not reachable due to '==' short-cut

    go c :: Ordering
c xs :: [a]
xs ys :: [a]
ys = String -> Ordering
forall a. HasCallStack => String -> a
error (String -> Ordering) -> String -> Ordering
forall a b. (a -> b) -> a -> b
$ "the impossible just happened: compareSubIds " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShortByteString, ShortByteString, Ordering, [a], [a]) -> String
forall a. Show a => a -> String
show (ShortByteString
bx,ShortByteString
by,Ordering
c,[a]
xs,[a]
ys)