--------------------------------------------------------------------
-- |
-- Module    : Codec.MIME.Base64
-- Copyright : (c) 2006-2009, Galois, Inc. 
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
-- Stability : provisional
-- Portability: portable
--
-- 
-- Base64 decoding and encoding routines, multiple entry
-- points for either depending on use and level of control
-- wanted over the encoded output (and its input form on the
-- decoding side.)
-- 
--------------------------------------------------------------------
module Codec.MIME.Base64 
        ( encodeRaw         -- :: Bool -> String -> [Word8]
        , encodeRawString   -- :: Bool -> String -> String
        , encodeRawPrim     -- :: Bool -> Char -> Char -> [Word8] -> String

        , formatOutput      -- :: Int    -> Maybe String -> String -> String

        , decode            -- :: String -> [Word8]
        , decodeToString    -- :: String -> String
        , decodePrim        -- :: Char -> Char -> String -> [Word8]
        ) where

import Data.Bits
import Data.Char
import Data.Word
import Data.Maybe

encodeRawString :: Bool -> String -> String
encodeRawString :: Bool -> String -> String
encodeRawString trail :: Bool
trail xs :: String
xs = Bool -> [Word8] -> String
encodeRaw Bool
trail ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
ord) String
xs)

-- | @formatOutput n mbLT str@ formats @str@, splitting it
-- into lines of length @n@. The optional value lets you control what
-- line terminator sequence to use; the default is CRLF (as per MIME.)
formatOutput :: Int -> Maybe String -> String -> String
formatOutput :: Int -> Maybe String -> String -> String
formatOutput n :: Int
n mbTerm :: Maybe String
mbTerm str :: String
str
 | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0    = String -> String
forall a. HasCallStack => String -> a
error ("Codec.MIME.Base64.formatOutput: negative line length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
 | Bool
otherwise = Int -> String -> String
chop Int
n String
str
   where
     crlf :: String
     crlf :: String
crlf = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "\r\n" Maybe String
mbTerm

     chop :: Int -> String -> String
chop _ "" = ""
     chop i :: Int
i xs :: String
xs =
       case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i String
xs of
         (as :: String
as,"") -> String
as
         (as :: String
as,bs :: String
bs) -> String
as String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
crlf String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
chop Int
i String
bs

encodeRaw :: Bool -> [Word8] -> String
encodeRaw :: Bool -> [Word8] -> String
encodeRaw trail :: Bool
trail bs :: [Word8]
bs = Bool -> Char -> Char -> [Word8] -> String
encodeRawPrim Bool
trail '+' '/' [Word8]
bs

-- | @encodeRawPrim@ lets you control what non-alphanum characters to use
-- (The base64url variation uses @*@ and @-@, for instance.)
-- No support for mapping these to multiple characters in the output though.
encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String
encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String
encodeRawPrim trail :: Bool
trail ch62 :: Char
ch62 ch63 :: Char
ch63 ls :: [Word8]
ls = [Word8] -> String
encoder [Word8]
ls
 where
  trailer :: [a] -> [a] -> [a]
trailer xs :: [a]
xs ys :: [a]
ys
   | Bool -> Bool
not Bool
trail = [a]
xs
   | Bool
otherwise = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys
  f :: Word8 -> Char
f = Char -> Char -> Word8 -> Char
fromB64 Char
ch62 Char
ch63 
  encoder :: [Word8] -> String
encoder []    = []
  encoder [x :: Word8
x]   = String -> String -> String
forall a. [a] -> [a] -> [a]
trailer (Int -> String -> String
forall a. Int -> [a] -> [a]
take 2 ((Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 Word8 -> Char
f Word8
x 0 0 "")) "=="
  encoder [x :: Word8
x,y :: Word8
y] = String -> String -> String
forall a. [a] -> [a] -> [a]
trailer (Int -> String -> String
forall a. Int -> [a] -> [a]
take 3 ((Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 Word8 -> Char
f Word8
x Word8
y 0 "")) "="
  encoder (x :: Word8
x:y :: Word8
y:z :: Word8
z:ws :: [Word8]
ws) = (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 Word8 -> Char
f Word8
x Word8
y Word8
z ([Word8] -> String
encoder [Word8]
ws)

encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 f :: Word8 -> Char
f a :: Word8
a b :: Word8
b c :: Word8
c rs :: String
rs = 
     Word8 -> Char
f (Word32 -> Word8
low6 (Word32
w24 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 18)) Char -> String -> String
forall a. a -> [a] -> [a]
:
     Word8 -> Char
f (Word32 -> Word8
low6 (Word32
w24 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 12)) Char -> String -> String
forall a. a -> [a] -> [a]
:
     Word8 -> Char
f (Word32 -> Word8
low6 (Word32
w24 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 6))  Char -> String -> String
forall a. a -> [a] -> [a]
:
     Word8 -> Char
f (Word32 -> Word8
low6 Word32
w24) Char -> String -> String
forall a. a -> [a] -> [a]
: String
rs
   where
    w24 :: Word32
    w24 :: Word32
w24 = (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` 16) Word32 -> Word32 -> Word32
forall a. Num 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` 8)  Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ 
           Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c

decodeToString :: String -> String
decodeToString :: String -> String
decodeToString str :: String
str = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr(Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$ String -> [Word8]
decode String
str

decode :: String -> [Word8]
decode :: String -> [Word8]
decode str :: String
str = Char -> Char -> String -> [Word8]
decodePrim '+' '/' String
str

decodePrim :: Char -> Char -> String -> [Word8]
decodePrim :: Char -> Char -> String -> [Word8]
decodePrim ch62 :: Char
ch62 ch63 :: Char
ch63 str :: String
str =  [Word8] -> [Word8]
decoder ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ String -> [Word8]
takeUntilEnd String
str
 where
  takeUntilEnd :: String -> [Word8]
takeUntilEnd "" = []
  takeUntilEnd ('=':_) = []
  takeUntilEnd (x :: Char
x:xs :: String
xs) = 
    case Char -> Char -> Char -> Maybe Word8
toB64 Char
ch62 Char
ch63 Char
x of
      Nothing -> String -> [Word8]
takeUntilEnd String
xs
      Just b :: Word8
b  -> Word8
b Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: String -> [Word8]
takeUntilEnd String
xs

decoder :: [Word8] -> [Word8]
decoder :: [Word8] -> [Word8]
decoder [] = []
decoder [x :: Word8
x] = Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take 1 (Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 Word8
x 0 0 0 [])
decoder [x :: Word8
x,y :: Word8
y] = Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take 1 (Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 Word8
x Word8
y 0 0 []) -- upper 4 bits of second val are known to be 0.
decoder [x :: Word8
x,y :: Word8
y,z :: Word8
z] = Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take 2 (Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 Word8
x Word8
y Word8
z 0 [])
decoder (x :: Word8
x:y :: Word8
y:z :: Word8
z:w :: Word8
w:xs :: [Word8]
xs) = Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 Word8
x Word8
y Word8
z Word8
w ([Word8] -> [Word8]
decoder [Word8]
xs)

decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 a :: Word8
a b :: Word8
b c :: Word8
c d :: Word8
d rs :: [Word8]
rs =
  (Word32 -> Word8
lowByte (Word32
w24 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 16)) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:
  (Word32 -> Word8
lowByte (Word32
w24 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 8))  Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:
  (Word32 -> Word8
lowByte Word32
w24) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
rs
 where
  w24 :: Word32
  w24 :: Word32
w24 =
   (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` 18 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` 12 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` 6  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
   (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d)

toB64 :: Char -> Char -> Char -> Maybe Word8
toB64 :: Char -> Char -> Char -> Maybe Word8
toB64 a :: Char
a b :: Char
b ch :: Char
ch
  | Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'A' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'Z' = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord 'A'))
  | Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'a' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'z' = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (26 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord 'a'))
  | Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9' = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (52 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '0'))
  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
a = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just 62
  | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just 63
  | Bool
otherwise = Maybe Word8
forall a. Maybe a
Nothing

fromB64 :: Char -> Char -> Word8 -> Char
fromB64 :: Char -> Char -> Word8 -> Char
fromB64 ch62 :: Char
ch62 ch63 :: Char
ch63 x :: Word8
x 
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 26    = Int -> Char
chr (Char -> Int
ord 'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xi)
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 52    = Int -> Char
chr (Char -> Int
ord 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
xiInt -> Int -> Int
forall a. Num a => a -> a -> a
-26))
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 62    = Int -> Char
chr (Char -> Int
ord '0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
xiInt -> Int -> Int
forall a. Num a => a -> a -> a
-52))
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 62   = Char
ch62
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 63   = Char
ch63
  | Bool
otherwise = String -> Char
forall a. HasCallStack => String -> a
error ("fromB64: index out of range " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
x)
 where
  xi :: Int
  xi :: Int
xi = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x

low6 :: Word32 -> Word8
low6 :: Word32 -> Word8
low6 x :: Word32
x = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0x3f)

lowByte :: Word32 -> Word8
lowByte :: Word32 -> Word8
lowByte x :: Word32
x = (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xff