{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Trustworthy #-}
module LDAPv3.OID
(
LDAPOID
, OID(OID)
, OBJECT_IDENTIFIER
, object_identifier'toOID
, object_identifier'fromOID
, object_identifier'toBin
, object_identifier'fromBin
, 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
class IsWellFormedOid t where
isWellFormedOid :: t -> Bool
type LDAPOID = OID
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
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
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
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 '.')
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
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
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'
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
newtype OBJECT_IDENTIFIER = OID_ SBS.ShortByteString
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
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
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
instance IsWellFormedOid OBJECT_IDENTIFIER where
isWellFormedOid :: OBJECT_IDENTIFIER -> Bool
isWellFormedOid = Bool -> OBJECT_IDENTIFIER -> Bool
forall a b. a -> b -> a
const Bool
True
object_identifier'toBin :: OBJECT_IDENTIFIER -> SBS.ShortByteString
object_identifier'toBin :: OBJECT_IDENTIFIER -> ShortByteString
object_identifier'toBin (OID_ sbs :: ShortByteString
sbs) = ShortByteString
sbs
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
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))
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
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 = Bool -> Word32 -> Builder
encodeWord32 Bool
False (Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x)
| 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)
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
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)
| 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))
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
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
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
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)