-- |
-- Module      : Data.ASN1.Types.String
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Different String types available in ASN1
--
module Data.ASN1.Types.String
    ( ASN1StringEncoding(..)
    , ASN1CharacterString(..)
    , asn1CharacterString
    , asn1CharacterToString
    ) where

import Data.String
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Bits
import Data.Word

-- a note on T61 encodings. The actual specification of a T61 character set seems
-- to be lost in time, as such it will be considered an ascii like encoding.
--
-- <http://www.mail-archive.com/asn1@asn1.org/msg00460.html>
-- "sizable volume of software in the world treats TeletexString (T61String)
-- as a simple 8-bit string with mostly Windows Latin 1"

-- | Define all possible ASN1 String encoding.
data ASN1StringEncoding =
      IA5       -- ^ 128 characters equivalent to the ASCII alphabet
    | UTF8      -- ^ UTF8
    | General   -- ^ all registered graphic and character sets (see ISO 2375) plus SPACE and DELETE.
    | Graphic   -- ^ all registered G sets and SPACE
    | Numeric   -- ^ encoding containing numeric [0-9] and space
    | Printable -- ^ printable [a-z] [A-Z] [()+,-.?:/=] and space.
    | VideoTex  -- ^ CCITT's T.100 and T.101 character sets
    | Visible   -- ^ International ASCII printing character sets
    | T61       -- ^ teletext
    | UTF32     -- ^ UTF32
    | Character -- ^ Character
    | BMP       -- ^ UCS2
    deriving (Int -> ASN1StringEncoding -> ShowS
[ASN1StringEncoding] -> ShowS
ASN1StringEncoding -> String
(Int -> ASN1StringEncoding -> ShowS)
-> (ASN1StringEncoding -> String)
-> ([ASN1StringEncoding] -> ShowS)
-> Show ASN1StringEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ASN1StringEncoding] -> ShowS
$cshowList :: [ASN1StringEncoding] -> ShowS
show :: ASN1StringEncoding -> String
$cshow :: ASN1StringEncoding -> String
showsPrec :: Int -> ASN1StringEncoding -> ShowS
$cshowsPrec :: Int -> ASN1StringEncoding -> ShowS
Show,ASN1StringEncoding -> ASN1StringEncoding -> Bool
(ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> (ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> Eq ASN1StringEncoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c/= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
== :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c== :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
Eq,Eq ASN1StringEncoding
Eq ASN1StringEncoding
-> (ASN1StringEncoding -> ASN1StringEncoding -> Ordering)
-> (ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> (ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> (ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> (ASN1StringEncoding -> ASN1StringEncoding -> Bool)
-> (ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding)
-> (ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding)
-> Ord ASN1StringEncoding
ASN1StringEncoding -> ASN1StringEncoding -> Bool
ASN1StringEncoding -> ASN1StringEncoding -> Ordering
ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding
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 :: ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding
$cmin :: ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding
max :: ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding
$cmax :: ASN1StringEncoding -> ASN1StringEncoding -> ASN1StringEncoding
>= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c>= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
> :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c> :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
<= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c<= :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
< :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
$c< :: ASN1StringEncoding -> ASN1StringEncoding -> Bool
compare :: ASN1StringEncoding -> ASN1StringEncoding -> Ordering
$ccompare :: ASN1StringEncoding -> ASN1StringEncoding -> Ordering
$cp1Ord :: Eq ASN1StringEncoding
Ord)

-- | provide a way to possibly encode or decode character string based on character encoding
stringEncodingFunctions :: ASN1StringEncoding
                        -> Maybe (ByteString -> String, String -> ByteString)
stringEncodingFunctions :: ASN1StringEncoding
-> Maybe (ByteString -> String, String -> ByteString)
stringEncodingFunctions ASN1StringEncoding
encoding
    | ASN1StringEncoding
encoding ASN1StringEncoding -> ASN1StringEncoding -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1StringEncoding
UTF8                   = (ByteString -> String, String -> ByteString)
-> Maybe (ByteString -> String, String -> ByteString)
forall a. a -> Maybe a
Just (ByteString -> String
decodeUTF8, String -> ByteString
encodeUTF8)
    | ASN1StringEncoding
encoding ASN1StringEncoding -> ASN1StringEncoding -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1StringEncoding
BMP                    = (ByteString -> String, String -> ByteString)
-> Maybe (ByteString -> String, String -> ByteString)
forall a. a -> Maybe a
Just (ByteString -> String
decodeBMP, String -> ByteString
encodeBMP)
    | ASN1StringEncoding
encoding ASN1StringEncoding -> ASN1StringEncoding -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1StringEncoding
UTF32                  = (ByteString -> String, String -> ByteString)
-> Maybe (ByteString -> String, String -> ByteString)
forall a. a -> Maybe a
Just (ByteString -> String
decodeUTF32, String -> ByteString
encodeUTF32)
    | ASN1StringEncoding
encoding ASN1StringEncoding -> [ASN1StringEncoding] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ASN1StringEncoding]
asciiLikeEncodings = (ByteString -> String, String -> ByteString)
-> Maybe (ByteString -> String, String -> ByteString)
forall a. a -> Maybe a
Just (ByteString -> String
decodeASCII, String -> ByteString
encodeASCII)
    | Bool
otherwise                          = Maybe (ByteString -> String, String -> ByteString)
forall a. Maybe a
Nothing
  where asciiLikeEncodings :: [ASN1StringEncoding]
asciiLikeEncodings = [ASN1StringEncoding
IA5,ASN1StringEncoding
Numeric,ASN1StringEncoding
Printable,ASN1StringEncoding
Visible,ASN1StringEncoding
General,ASN1StringEncoding
Graphic,ASN1StringEncoding
T61]

-- | encode a string into a character string
asn1CharacterString :: ASN1StringEncoding -> String -> ASN1CharacterString
asn1CharacterString :: ASN1StringEncoding -> String -> ASN1CharacterString
asn1CharacterString ASN1StringEncoding
encoding String
s =
    case ASN1StringEncoding
-> Maybe (ByteString -> String, String -> ByteString)
stringEncodingFunctions ASN1StringEncoding
encoding of
        Just (ByteString -> String
_, String -> ByteString
e) -> ASN1StringEncoding -> ByteString -> ASN1CharacterString
ASN1CharacterString ASN1StringEncoding
encoding (String -> ByteString
e String
s)
        Maybe (ByteString -> String, String -> ByteString)
Nothing     -> String -> ASN1CharacterString
forall a. HasCallStack => String -> a
error (String
"cannot encode ASN1 Character String " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ASN1StringEncoding -> String
forall a. Show a => a -> String
show ASN1StringEncoding
encoding String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from string")

-- | try to decode an 'ASN1CharacterString' to a String
asn1CharacterToString :: ASN1CharacterString -> Maybe String
asn1CharacterToString :: ASN1CharacterString -> Maybe String
asn1CharacterToString (ASN1CharacterString ASN1StringEncoding
encoding ByteString
bs) =
    case ASN1StringEncoding
-> Maybe (ByteString -> String, String -> ByteString)
stringEncodingFunctions ASN1StringEncoding
encoding of
        Just (ByteString -> String
d, String -> ByteString
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (ByteString -> String
d ByteString
bs)
        Maybe (ByteString -> String, String -> ByteString)
Nothing     -> Maybe String
forall a. Maybe a
Nothing

-- | ASN1 Character String with encoding
data ASN1CharacterString = ASN1CharacterString
    { ASN1CharacterString -> ASN1StringEncoding
characterEncoding         :: ASN1StringEncoding
    , ASN1CharacterString -> ByteString
getCharacterStringRawData :: ByteString
    } deriving (Int -> ASN1CharacterString -> ShowS
[ASN1CharacterString] -> ShowS
ASN1CharacterString -> String
(Int -> ASN1CharacterString -> ShowS)
-> (ASN1CharacterString -> String)
-> ([ASN1CharacterString] -> ShowS)
-> Show ASN1CharacterString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ASN1CharacterString] -> ShowS
$cshowList :: [ASN1CharacterString] -> ShowS
show :: ASN1CharacterString -> String
$cshow :: ASN1CharacterString -> String
showsPrec :: Int -> ASN1CharacterString -> ShowS
$cshowsPrec :: Int -> ASN1CharacterString -> ShowS
Show,ASN1CharacterString -> ASN1CharacterString -> Bool
(ASN1CharacterString -> ASN1CharacterString -> Bool)
-> (ASN1CharacterString -> ASN1CharacterString -> Bool)
-> Eq ASN1CharacterString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c/= :: ASN1CharacterString -> ASN1CharacterString -> Bool
== :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c== :: ASN1CharacterString -> ASN1CharacterString -> Bool
Eq,Eq ASN1CharacterString
Eq ASN1CharacterString
-> (ASN1CharacterString -> ASN1CharacterString -> Ordering)
-> (ASN1CharacterString -> ASN1CharacterString -> Bool)
-> (ASN1CharacterString -> ASN1CharacterString -> Bool)
-> (ASN1CharacterString -> ASN1CharacterString -> Bool)
-> (ASN1CharacterString -> ASN1CharacterString -> Bool)
-> (ASN1CharacterString
    -> ASN1CharacterString -> ASN1CharacterString)
-> (ASN1CharacterString
    -> ASN1CharacterString -> ASN1CharacterString)
-> Ord ASN1CharacterString
ASN1CharacterString -> ASN1CharacterString -> Bool
ASN1CharacterString -> ASN1CharacterString -> Ordering
ASN1CharacterString -> ASN1CharacterString -> ASN1CharacterString
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 :: ASN1CharacterString -> ASN1CharacterString -> ASN1CharacterString
$cmin :: ASN1CharacterString -> ASN1CharacterString -> ASN1CharacterString
max :: ASN1CharacterString -> ASN1CharacterString -> ASN1CharacterString
$cmax :: ASN1CharacterString -> ASN1CharacterString -> ASN1CharacterString
>= :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c>= :: ASN1CharacterString -> ASN1CharacterString -> Bool
> :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c> :: ASN1CharacterString -> ASN1CharacterString -> Bool
<= :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c<= :: ASN1CharacterString -> ASN1CharacterString -> Bool
< :: ASN1CharacterString -> ASN1CharacterString -> Bool
$c< :: ASN1CharacterString -> ASN1CharacterString -> Bool
compare :: ASN1CharacterString -> ASN1CharacterString -> Ordering
$ccompare :: ASN1CharacterString -> ASN1CharacterString -> Ordering
$cp1Ord :: Eq ASN1CharacterString
Ord)

instance IsString ASN1CharacterString where
    fromString :: String -> ASN1CharacterString
fromString String
s = ASN1StringEncoding -> ByteString -> ASN1CharacterString
ASN1CharacterString ASN1StringEncoding
UTF8 (String -> ByteString
encodeUTF8 String
s)

decodeUTF8 :: ByteString -> String
decodeUTF8 :: ByteString -> String
decodeUTF8 ByteString
b = Int -> [Word8] -> String
loop Int
0 ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
B.unpack ByteString
b
  where loop :: Int -> [Word8] -> [Char]
        loop :: Int -> [Word8] -> String
loop Int
_   []     = []
        loop Int
pos (Word8
x:[Word8]
xs)
            | Word8
x Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
7 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x) Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Word8] -> String
loop (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Word8]
xs
            | Word8
x Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
6 = ShowS
forall a. HasCallStack => String -> a
error String
"continuation byte in heading context"
            | Word8
x Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
5 = Int -> Word8 -> Int -> [Word8] -> String
uncont Int
1 (Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x1f) Int
pos [Word8]
xs
            | Word8
x Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
4 = Int -> Word8 -> Int -> [Word8] -> String
uncont Int
2 (Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf)  Int
pos [Word8]
xs
            | Word8
x Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
3 = Int -> Word8 -> Int -> [Word8] -> String
uncont Int
3 (Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7)  Int
pos [Word8]
xs
            | Bool
otherwise     = ShowS
forall a. HasCallStack => String -> a
error String
"too many byte"
        uncont :: Int -> Word8 -> Int -> [Word8] -> [Char]
        uncont :: Int -> Word8 -> Int -> [Word8] -> String
uncont Int
1 Word8
iniV Int
pos [Word8]
xs =
            case [Word8]
xs of
                Word8
c1:[Word8]
xs' -> Word8 -> [Word8] -> Char
decodeCont Word8
iniV [Word8
c1] Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Word8] -> String
loop (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [Word8]
xs'
                [Word8]
_      -> ShowS
forall a. HasCallStack => String -> a
error String
"truncated continuation, expecting 1 byte"
        uncont Int
2 Word8
iniV Int
pos [Word8]
xs =
            case [Word8]
xs of
                Word8
c1:Word8
c2:[Word8]
xs' -> Word8 -> [Word8] -> Char
decodeCont Word8
iniV [Word8
c1,Word8
c2] Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Word8] -> String
loop (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) [Word8]
xs'
                [Word8]
_         -> ShowS
forall a. HasCallStack => String -> a
error String
"truncated continuation, expecting 2 bytes"
        uncont Int
3 Word8
iniV Int
pos [Word8]
xs =
            case [Word8]
xs of
                Word8
c1:Word8
c2:Word8
c3:[Word8]
xs' -> Word8 -> [Word8] -> Char
decodeCont Word8
iniV [Word8
c1,Word8
c2,Word8
c3] Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Word8] -> String
loop (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4) [Word8]
xs'
                [Word8]
_            -> ShowS
forall a. HasCallStack => String -> a
error String
"truncated continuation, expecting 3 bytes"
        uncont Int
_ Word8
_ Int
_ [Word8]
_ = ShowS
forall a. HasCallStack => String -> a
error String
"invalid number of bytes for continuation"
        decodeCont :: Word8 -> [Word8] -> Char
        decodeCont :: Word8 -> [Word8] -> Char
decodeCont Word8
iniV [Word8]
l
            | (Word8 -> Bool) -> [Word8] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Word8 -> Bool
forall a. Bits a => a -> Bool
isContByte [Word8]
l = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int -> Word8 -> Int) -> Int -> [Word8] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
acc Word8
v -> (Int
acc Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
iniV) ([Word8] -> Int) -> [Word8] -> Int
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8) -> [Word8] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (\Word8
v -> Word8
v Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f) [Word8]
l
            | Bool
otherwise        = String -> Char
forall a. HasCallStack => String -> a
error String
"continuation bytes invalid"
        isContByte :: a -> Bool
isContByte a
v = a
v a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 Bool -> Bool -> Bool
&& a
v a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`isClear` Int
6
        isClear :: a -> Int -> Bool
isClear a
v Int
i = Bool -> Bool
not (a
v a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i)

encodeUTF8 :: String -> ByteString
encodeUTF8 :: String -> ByteString
encodeUTF8 String
s = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> [Word8]) -> String -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Word8]
forall a a. (Integral a, Num a, Bits a) => a -> [a]
toUTF8 (Int -> [Word8]) -> (Char -> Int) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
s
  where toUTF8 :: a -> [a]
toUTF8 a
e
            | a
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x80      = [a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
e]
            | a
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x800     = [a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
0xc0 a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)), a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont a
e]
            | a
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x10000   = [a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
0xe0 a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12))
                              ,a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)
                              ,a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont a
e]
            | a
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0x200000  = [a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
0xf0 a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
18))
                              , a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12)
                              , a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont (a
e a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)
                              , a -> a
forall a b. (Integral a, Bits a, Num b) => a -> b
toCont a
e]
            | Bool
otherwise     = String -> [a]
forall a. HasCallStack => String -> a
error String
"not a valid value"
        toCont :: a -> b
toCont a
v = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
0x80 a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
v a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f))

decodeASCII :: ByteString -> String
decodeASCII :: ByteString -> String
decodeASCII = ByteString -> String
BC.unpack

encodeASCII :: String -> ByteString
encodeASCII :: String -> ByteString
encodeASCII = String -> ByteString
BC.pack

decodeBMP :: ByteString -> String
decodeBMP :: ByteString -> String
decodeBMP ByteString
b
    | Int -> Bool
forall a. Integral a => a -> Bool
odd (ByteString -> Int
B.length ByteString
b) = ShowS
forall a. HasCallStack => String -> a
error String
"not a valid BMP string"
    | Bool
otherwise        = [Word8] -> String
forall a a. (Integral a, Enum a) => [a] -> [a]
fromUCS2 ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
B.unpack ByteString
b
  where fromUCS2 :: [a] -> [a]
fromUCS2 [] = []
        fromUCS2 (a
b0:a
b1:[a]
l) =
            let v :: Word16
                v :: Word16
v = (a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b0 Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b1
             in Int -> a
forall a. Enum a => Int -> a
toEnum (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
fromUCS2 [a]
l
        fromUCS2 [a]
_ = String -> [a]
forall a. HasCallStack => String -> a
error String
"decodeBMP: internal error"
encodeBMP :: String -> ByteString
encodeBMP :: String -> ByteString
encodeBMP String
s = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> [Word8]) -> String -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Word8]
forall a a. (Integral a, Bits a, Num a) => a -> [a]
toUCS2 (Int -> [Word8]) -> (Char -> Int) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
s
  where toUCS2 :: a -> [a]
toUCS2 a
v = [a
b0,a
b1]
            where b0 :: a
b0 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
                  b1 :: a
b1 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xff)

decodeUTF32 :: ByteString -> String
decodeUTF32 :: ByteString -> String
decodeUTF32 ByteString
bs
    | (ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = ShowS
forall a. HasCallStack => String -> a
error String
"not a valid UTF32 string"
    | Bool
otherwise                  = Int -> String
fromUTF32 Int
0
  where w32ToChar :: Word32 -> Char
        w32ToChar :: Word32 -> Char
w32ToChar = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        fromUTF32 :: Int -> String
fromUTF32 Int
ofs
            | Int
ofs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
B.length ByteString
bs = []
            | Bool
otherwise =
                let a :: Word8
a = ByteString -> Int -> Word8
B.index ByteString
bs Int
ofs
                    b :: Word8
b = ByteString -> Int -> Word8
B.index ByteString
bs (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                    c :: Word8
c = ByteString -> Int -> Word8
B.index ByteString
bs (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
                    d :: Word8
d = ByteString -> Int -> Word8
B.index ByteString
bs (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3)
                    v :: Word32
v = (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                        (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                        (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                        (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d)
                 in Word32 -> Char
w32ToChar Word32
v Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
fromUTF32 (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4)
encodeUTF32 :: String -> ByteString
encodeUTF32 :: String -> ByteString
encodeUTF32 String
s = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> [Word8]) -> String -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Word8]
forall a a. (Integral a, Bits a, Num a) => a -> [a]
toUTF32 (Int -> [Word8]) -> (Char -> Int) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
s
  where toUTF32 :: a -> [a]
toUTF32 a
v = [a
b0,a
b1,a
b2,a
b3]
            where b0 :: a
b0 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
                  b1 :: a
b1 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((a
v a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xff)
                  b2 :: a
b2 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((a
v a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)  a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xff)
                  b3 :: a
b3 = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xff)