--------------------------------------------------------------------
-- |
-- Module    : Codec.MIME.Decode
-- Copyright : (c) 2006-2009, Galois, Inc. 
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
-- Stability : provisional
-- Portability: portable
--
-- 
-- 
--------------------------------------------------------------------

module Codec.MIME.Decode where

import Data.Char

import Codec.MIME.QuotedPrintable as QP
import Codec.MIME.Base64 as Base64

-- | @decodeBody enc str@ decodes @str@ according to the scheme
-- specified by @enc@. Currently, @base64@ and @quoted-printable@ are
-- the only two encodings supported. If you supply anything else
-- for @enc@, @decodeBody@ returns @str@.
-- 
decodeBody :: String -> String -> String
decodeBody :: String -> String -> String
decodeBody enc :: String
enc body :: String
body =
 case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
enc of
   "base64"           -> String -> String
Base64.decodeToString String
body
   "quoted-printable" -> String -> String
QP.decode String
body
   _ -> String
body

-- Decoding of RFC 2047's "encoded-words" production
-- (as used in email-headers and some HTTP header cases
-- (AtomPub's Slug: header))
decodeWord :: String -> Maybe (String, String)
decodeWord :: String -> Maybe (String, String)
decodeWord str :: String
str =
  case String
str of
   '=':'?':xs :: String
xs ->
     case (String, String) -> (String, String)
forall a. (a, String) -> (a, String)
dropLang ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\ch :: Char
ch -> Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='?' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '*') String
xs of
       (cs :: String
cs,_:x :: Char
x:'?':bs :: String
bs)
         | String -> Bool
isKnownCharset ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs) ->
           case Char -> Char
toLower Char
x of
             'q' -> String -> (String, String) -> Maybe (String, String)
forall p. p -> (String, String) -> Maybe (String, String)
decodeQ String
cs ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='?') String
bs)
             'b' -> String -> (String, String) -> Maybe (String, String)
forall p. p -> (String, String) -> Maybe (String, String)
decodeB String
cs ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='?') String
bs)
             _   -> Maybe (String, String)
forall a. Maybe a
Nothing
       _ -> Maybe (String, String)
forall a. Maybe a
Nothing
   _ -> Maybe (String, String)
forall a. Maybe a
Nothing
 where
  isKnownCharset :: String -> Bool
isKnownCharset cs :: String
cs = String
cs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["iso-8859-1", "us-ascii"]

   -- ignore RFC 2231 extension of permitting a language tag to be supplied
   -- after the charset.
  dropLang :: (a, String) -> (a, String)
dropLang (as :: a
as,'*':bs :: String
bs) = (a
as,(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='?') String
bs)
  dropLang (as :: a
as,bs :: String
bs) = (a
as,String
bs)

  decodeQ :: p -> (String, String) -> Maybe (String, String)
decodeQ cset :: p
cset (fs :: String
fs,'?':'=':rs :: String
rs) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (p -> String -> String
forall p p. p -> p -> p
fromCharset p
cset (String -> String
QP.decode String
fs),String
rs)
  decodeQ _ _ = Maybe (String, String)
forall a. Maybe a
Nothing

  decodeB :: p -> (String, String) -> Maybe (String, String)
decodeB cset :: p
cset (fs :: String
fs,'?':'=':rs :: String
rs) =
    (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (p -> String -> String
forall p p. p -> p -> p
fromCharset p
cset (String -> String
Base64.decodeToString String
fs),String
rs)
  decodeB _ _ = Maybe (String, String)
forall a. Maybe a
Nothing

  fromCharset :: p -> p -> p
fromCharset _cset :: p
_cset cs :: p
cs = p
cs

decodeWords :: String -> String
decodeWords :: String -> String
decodeWords "" = ""
decodeWords (x :: Char
x:xs :: String
xs)
 | Char -> Bool
isSpace Char
x = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decodeWords String
xs
 | Bool
otherwise =
  case String -> Maybe (String, String)
decodeWord (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs) of
    Nothing -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decodeWords String
xs
    Just (as :: String
as,bs :: String
bs) -> String
as String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
decodeWords String
bs