{-# LANGUAGE OverloadedStrings #-}
-- | A few extra data types
module Codec.Candid.Data where

import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Builder as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Digest.CRC
import Data.Digest.CRC32
import Data.ByteString.Base32
import Data.List
import Data.List.Split (chunksOf)
import Data.Bifunctor
import Control.Monad

data Reserved = Reserved
 deriving (Reserved -> Reserved -> Bool
(Reserved -> Reserved -> Bool)
-> (Reserved -> Reserved -> Bool) -> Eq Reserved
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reserved -> Reserved -> Bool
$c/= :: Reserved -> Reserved -> Bool
== :: Reserved -> Reserved -> Bool
$c== :: Reserved -> Reserved -> Bool
Eq, Eq Reserved
Eq Reserved
-> (Reserved -> Reserved -> Ordering)
-> (Reserved -> Reserved -> Bool)
-> (Reserved -> Reserved -> Bool)
-> (Reserved -> Reserved -> Bool)
-> (Reserved -> Reserved -> Bool)
-> (Reserved -> Reserved -> Reserved)
-> (Reserved -> Reserved -> Reserved)
-> Ord Reserved
Reserved -> Reserved -> Bool
Reserved -> Reserved -> Ordering
Reserved -> Reserved -> Reserved
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 :: Reserved -> Reserved -> Reserved
$cmin :: Reserved -> Reserved -> Reserved
max :: Reserved -> Reserved -> Reserved
$cmax :: Reserved -> Reserved -> Reserved
>= :: Reserved -> Reserved -> Bool
$c>= :: Reserved -> Reserved -> Bool
> :: Reserved -> Reserved -> Bool
$c> :: Reserved -> Reserved -> Bool
<= :: Reserved -> Reserved -> Bool
$c<= :: Reserved -> Reserved -> Bool
< :: Reserved -> Reserved -> Bool
$c< :: Reserved -> Reserved -> Bool
compare :: Reserved -> Reserved -> Ordering
$ccompare :: Reserved -> Reserved -> Ordering
$cp1Ord :: Eq Reserved
Ord, Int -> Reserved -> ShowS
[Reserved] -> ShowS
Reserved -> String
(Int -> Reserved -> ShowS)
-> (Reserved -> String) -> ([Reserved] -> ShowS) -> Show Reserved
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reserved] -> ShowS
$cshowList :: [Reserved] -> ShowS
show :: Reserved -> String
$cshow :: Reserved -> String
showsPrec :: Int -> Reserved -> ShowS
$cshowsPrec :: Int -> Reserved -> ShowS
Show)

newtype Principal = Principal { Principal -> ByteString
rawPrincipal :: BS.ByteString }
 deriving (Principal -> Principal -> Bool
(Principal -> Principal -> Bool)
-> (Principal -> Principal -> Bool) -> Eq Principal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Principal -> Principal -> Bool
$c/= :: Principal -> Principal -> Bool
== :: Principal -> Principal -> Bool
$c== :: Principal -> Principal -> Bool
Eq, Eq Principal
Eq Principal
-> (Principal -> Principal -> Ordering)
-> (Principal -> Principal -> Bool)
-> (Principal -> Principal -> Bool)
-> (Principal -> Principal -> Bool)
-> (Principal -> Principal -> Bool)
-> (Principal -> Principal -> Principal)
-> (Principal -> Principal -> Principal)
-> Ord Principal
Principal -> Principal -> Bool
Principal -> Principal -> Ordering
Principal -> Principal -> Principal
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 :: Principal -> Principal -> Principal
$cmin :: Principal -> Principal -> Principal
max :: Principal -> Principal -> Principal
$cmax :: Principal -> Principal -> Principal
>= :: Principal -> Principal -> Bool
$c>= :: Principal -> Principal -> Bool
> :: Principal -> Principal -> Bool
$c> :: Principal -> Principal -> Bool
<= :: Principal -> Principal -> Bool
$c<= :: Principal -> Principal -> Bool
< :: Principal -> Principal -> Bool
$c< :: Principal -> Principal -> Bool
compare :: Principal -> Principal -> Ordering
$ccompare :: Principal -> Principal -> Ordering
$cp1Ord :: Eq Principal
Ord, Int -> Principal -> ShowS
[Principal] -> ShowS
Principal -> String
(Int -> Principal -> ShowS)
-> (Principal -> String)
-> ([Principal] -> ShowS)
-> Show Principal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Principal] -> ShowS
$cshowList :: [Principal] -> ShowS
show :: Principal -> String
$cshow :: Principal -> String
showsPrec :: Int -> Principal -> ShowS
$cshowsPrec :: Int -> Principal -> ShowS
Show)

prettyPrincipal :: Principal -> T.Text
prettyPrincipal :: Principal -> Text
prettyPrincipal (Principal ByteString
blob) =
    String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf Int
5 (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
base32 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
checkbytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
blob
  where
    CRC32 Word32
checksum = ByteString -> CRC32
forall a. CRC a => ByteString -> a
digest (ByteString -> ByteString
BS.toStrict ByteString
blob)
    checkbytes :: ByteString
checkbytes = Builder -> ByteString
BS.toLazyByteString (Word32 -> Builder
BS.word32BE Word32
checksum)
    base32 :: ByteString -> String
base32 = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'=') ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeBase32 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict

parsePrincipal :: T.Text -> Either String Principal
parsePrincipal :: Text -> Either String Principal
parsePrincipal Text
s = do
    ByteString
all_bytes <- (Text -> String)
-> (ByteString -> ByteString)
-> Either Text ByteString
-> Either String ByteString
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> String
T.unpack ByteString -> ByteString
BS.fromStrict (Either Text ByteString -> Either String ByteString)
-> Either Text ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$
        ByteString -> Either Text ByteString
decodeBase32Unpadded (Text -> ByteString
T.encodeUtf8 ((Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
s))
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int64
BS.length ByteString
all_bytes Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
4) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left String
"Too short id"
    let p :: Principal
p = ByteString -> Principal
Principal (Int64 -> ByteString -> ByteString
BS.drop Int64
4 ByteString
all_bytes)
    let expected :: Text
expected = Principal -> Text
prettyPrincipal Principal
p
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expected) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Principal id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" malformed; did you mean " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"?"
    Principal -> Either String Principal
forall (m :: * -> *) a. Monad m => a -> m a
return Principal
p