split into library + executables

1 files changed, 146 insertions, 0 deletions

diff --git a/src/Codec/MIME/Base64.hs b/src/Codec/MIME/Base64.hs
new file mode 100644
index 0000000..4372a7f
--- /dev/null
+++ b/src/Codec/MIME/Base64.hs
@@ -0,0 +1,146 @@
+--------------------------------------------------------------------
+-- |
+-- 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 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 ("Codec.MIME.Base64.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
+
+-- | @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 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