summaryrefslogtreecommitdiffstats
path: root/Codec/MIME/Base64.hs
blob: a8da683eb83a96913ac250f1d97938865262156b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
{- |
 
  Module      :  Codec.MIME.Parse
  Copyright   :  (c) 2006-2007

  Maintainer      : 
  Stability       : unstable
  Portability     : GHC
  
  Base64 decoding and encoding routines.
-}
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 trail xs = encodeRaw trail (map (fromIntegral.ord) 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 n mbTerm str
 | n <= 0    = error ("formatOutput: negative line length " ++ show n)
 | otherwise = chop n str
   where
     crlf :: String
     crlf = fromMaybe "\r\n" mbTerm

     chop _ "" = ""
     chop i xs =
       case splitAt i xs of
         (as,"") -> as
         (as,bs) -> as ++ crlf ++ chop i bs

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

-- 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 trail ch62 ch63 ls = encoder ls
 where
  trailer xs ys
   | not trail = xs
   | otherwise = xs ++ ys
  f = fromB64 ch62 ch63 
  encoder []    = []
  encoder [x]   = trailer (take 2 (encode3 f x 0 0 "")) "=="
  encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "="
  encoder (x:y:z:ws) = encode3 f x y z (encoder ws)

encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String
encode3 f a b c rs = 
     f (low6 (w24 `shiftR` 18)) :
     f (low6 (w24 `shiftR` 12)) :
     f (low6 (w24 `shiftR` 6))  :
     f (low6 w24) : rs
   where
    w24 :: Word32
    w24 = (fromIntegral a `shiftL` 16) +
          (fromIntegral b `shiftL` 8)  + 
           fromIntegral c

decodeToString :: String -> String
decodeToString str = map (chr.fromIntegral) $ decode str

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

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

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

decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]
decode4 a b c d rs =
  (lowByte (w24 `shiftR` 16)) :
  (lowByte (w24 `shiftR` 8))  :
  (lowByte w24) : rs
 where
  w24 :: Word32
  w24 =
   (fromIntegral a) `shiftL` 18 .|.
   (fromIntegral b) `shiftL` 12 .|.
   (fromIntegral c) `shiftL` 6  .|.
   (fromIntegral d)

toB64 :: Char -> Char -> Char -> Maybe Word8
toB64 a b ch
  | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A'))
  | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a'))
  | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0'))
  | ch == a = Just 62
  | ch == b = Just 63
  | otherwise = Nothing

fromB64 :: Char -> Char -> Word8 -> Char
fromB64 ch62 ch63 x 
  | x < 26    = chr (ord 'A' + xi)
  | x < 52    = chr (ord 'a' + (xi-26))
  | x < 62    = chr (ord '0' + (xi-52))
  | x == 62   = ch62
  | x == 63   = ch63
  | otherwise = error ("fromB64: index out of range " ++ show x)
 where
  xi :: Int
  xi = fromIntegral x

low6 :: Word32 -> Word8
low6 x = fromIntegral (x .&. 0x3f)

lowByte :: Word32 -> Word8
lowByte x = (fromIntegral x) .&. 0xff