netserver/Codec/Binary/Base64.hs
changeset 1747 44a6a9924c6d
equal deleted inserted replaced
1746:7a84521a903e 1747:44a6a9924c6d
       
     1 -- |
       
     2 -- Module    : Codec.Binary.Base64
       
     3 -- Copyright : (c) 2007 Magnus Therning
       
     4 -- License   : BSD3
       
     5 --
       
     6 -- Implemented as specified in RFC 4648
       
     7 -- (<http://tools.ietf.org/html/rfc4648>).
       
     8 --
       
     9 -- Further documentation and information can be found at
       
    10 -- <http://www.haskell.org/haskellwiki/Library/Data_encoding>.
       
    11 module Codec.Binary.Base64
       
    12     ( encode
       
    13     , decode
       
    14     , decode'
       
    15     , chop
       
    16     , unchop
       
    17     ) where
       
    18 
       
    19 import Control.Monad
       
    20 import Data.Array
       
    21 import Data.Bits
       
    22 import Data.Maybe
       
    23 import Data.Word
       
    24 import qualified Data.Map as M
       
    25 
       
    26 -- {{{1 enc/dec map
       
    27 _encMap =
       
    28     [ (0, 'A'), (1, 'B'), (2, 'C'), (3, 'D'), (4, 'E')
       
    29     , (5, 'F') , (6, 'G'), (7, 'H'), (8, 'I'), (9, 'J')
       
    30     , (10, 'K'), (11, 'L'), (12, 'M'), (13, 'N'), (14, 'O')
       
    31     , (15, 'P'), (16, 'Q'), (17, 'R'), (18, 'S'), (19, 'T')
       
    32     , (20, 'U'), (21, 'V'), (22, 'W'), (23, 'X'), (24, 'Y')
       
    33     , (25, 'Z'), (26, 'a'), (27, 'b'), (28, 'c'), (29, 'd')
       
    34     , (30, 'e'), (31, 'f'), (32, 'g'), (33, 'h'), (34, 'i')
       
    35     , (35, 'j'), (36, 'k'), (37, 'l'), (38, 'm'), (39, 'n')
       
    36     , (40, 'o'), (41, 'p'), (42, 'q'), (43, 'r'), (44, 's')
       
    37     , (45, 't'), (46, 'u'), (47, 'v'), (48, 'w'), (49, 'x')
       
    38     , (50, 'y'), (51, 'z'), (52, '0'), (53, '1'), (54, '2')
       
    39     , (55, '3'), (56, '4'), (57, '5'), (58, '6'), (59, '7')
       
    40     , (60, '8'), (61, '9'), (62, '+'), (63, '/') ]
       
    41 
       
    42 -- {{{1 encodeArray
       
    43 encodeArray :: Array Word8 Char
       
    44 encodeArray = array (0, 64) _encMap
       
    45 
       
    46 -- {{{1 decodeMap
       
    47 decodeMap :: M.Map Char Word8
       
    48 decodeMap  = M.fromList [(snd i, fst i) | i <- _encMap]
       
    49 
       
    50 -- {{{1 encode
       
    51 -- | Encode data.
       
    52 encode :: [Word8]
       
    53     -> String
       
    54 encode = let
       
    55         pad n = take n $ repeat 0
       
    56         enc [] = ""
       
    57         enc l@[o] = (++ "==") . take 2 .enc $ l ++ pad 2
       
    58         enc l@[o1, o2] = (++ "=") . take 3 . enc $ l ++ pad 1
       
    59         enc (o1:o2:o3:os) = let
       
    60                 i1 = o1 `shiftR` 2
       
    61                 i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f
       
    62                 i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f
       
    63                 i4 = o3 .&. 0x3f
       
    64             in (foldr (\ i s -> (encodeArray ! i) : s) "" [i1, i2, i3, i4]) ++ enc os
       
    65     in enc
       
    66 
       
    67 -- {{{1 decode
       
    68 -- | Decode data (lazy).
       
    69 decode' :: String
       
    70     -> [Maybe Word8]
       
    71 decode' = let
       
    72         pad n = take n $ repeat $ Just 0
       
    73         dec [] = []
       
    74         dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2
       
    75         dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1
       
    76         dec (Just eo1:Just eo2:Just eo3:Just eo4:eos) = let
       
    77                 o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4
       
    78                 o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2
       
    79                 o3 = eo3 `shiftL` 6 .|. eo4
       
    80             in Just o1:Just o2:Just o3:(dec eos)
       
    81         dec _ = [Nothing]
       
    82     in
       
    83         dec . map (flip M.lookup decodeMap) . takeWhile (/= '=')
       
    84 
       
    85 -- | Decode data (strict).
       
    86 decode :: String
       
    87     -> Maybe [Word8]
       
    88 decode = sequence . decode'
       
    89 
       
    90 -- {{{1 chop
       
    91 -- | Chop up a string in parts.
       
    92 --
       
    93 --   The length given is rounded down to the nearest multiple of 4.
       
    94 --
       
    95 --   /Notes:/
       
    96 --
       
    97 --   * PEM requires lines that are 64 characters long.
       
    98 --
       
    99 --   * MIME requires lines that are at most 76 characters long.
       
   100 chop :: Int     -- ^ length of individual lines
       
   101     -> String
       
   102     -> [String]
       
   103 chop n "" = []
       
   104 chop n s = let
       
   105         enc_len | n < 4 = 4
       
   106                 | otherwise = n `div` 4 * 4
       
   107     in (take enc_len s) : chop n (drop enc_len s)
       
   108 
       
   109 -- {{{1 unchop
       
   110 -- | Concatenate the strings into one long string.
       
   111 unchop :: [String]
       
   112     -> String
       
   113 unchop = foldr (++) ""