--------------------------------------------------------------------
-- |
-- 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 String
enc String
body =
 case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
enc of
   String
"base64"           -> String -> String
Base64.decodeToString String
body
   String
"quoted-printable" -> String -> String
QP.decode String
body
   String
_ -> 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 String
str =
  case String
str of
   Char
'=':Char
'?':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 (\Char
ch -> Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'?' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*') String
xs of
       (String
cs,Char
_:Char
x:Char
'?':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
             Char
'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
==Char
'?') String
bs)
             Char
'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
==Char
'?') String
bs)
             Char
_   -> Maybe (String, String)
forall a. Maybe a
Nothing
       (String, String)
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
   String
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
 where
  isKnownCharset :: String -> Bool
isKnownCharset String
cs = String
cs String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"iso-8859-1", String
"us-ascii"]

   -- ignore RFC 2231 extension of permitting a language tag to be supplied
   -- after the charset.
  dropLang :: (a, String) -> (a, String)
dropLang (a
as,Char
'*':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
/=Char
'?') String
bs)
  dropLang (a
as,String
bs) = (a
as,String
bs)

  decodeQ :: p -> (String, String) -> Maybe (String, String)
decodeQ p
cset (String
fs,Char
'?':Char
'=':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 p
_ (String, String)
_ = Maybe (String, String)
forall a. Maybe a
Nothing

  decodeB :: p -> (String, String) -> Maybe (String, String)
decodeB p
cset (String
fs,Char
'?':Char
'=':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 p
_ (String, String)
_ = Maybe (String, String)
forall a. Maybe a
Nothing

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

decodeWords :: String -> String
decodeWords :: String -> String
decodeWords String
"" = String
""
decodeWords (Char
x: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
    Maybe (String, String)
Nothing -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
decodeWords String
xs
    Just (String
as,String
bs) -> String
as String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
decodeWords String
bs