diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Data/MIME/Extended.hs | 86 |
1 files changed, 84 insertions, 2 deletions
diff --git a/src/Data/MIME/Extended.hs b/src/Data/MIME/Extended.hs index 46384d4..773d0b7 100644 --- a/src/Data/MIME/Extended.hs +++ b/src/Data/MIME/Extended.hs @@ -9,12 +9,24 @@ module Data.MIME.Extended import Control.Lens hiding ((.=)) import Data.Aeson +import Data.ByteString (ByteString) import Data.ByteString.Extended () +import Data.CaseInsensitive (CI) +import Data.Either (fromRight) +import Data.List.NonEmpty (NonEmpty) import Data.MIME import Data.MIME.EncodedWord +import Data.Maybe (fromMaybe) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.CaseInsensitive as CI import qualified Data.Vector +-- Data.MIME.Boundary.Extra +makeBoundaryUnsafe :: ByteString -> Boundary +makeBoundaryUnsafe = either (error . C8.unpack) id . makeBoundary + + instance ToJSON (Message s MIME) where toJSON (Message h b) = @@ -24,7 +36,7 @@ instance ToJSON (Message s MIME) where case b of Part b' -> toJSON b' Encapsulated b' -> toJSON b' - Multipart b' -> toJSON b' + Multipart _ _ b' -> toJSON b' FailedParse _ msg -> toJSON msg ] @@ -38,7 +50,7 @@ instance FromJSON (Message s MIME) where Encapsulated <$> v .: "body" ContentType "multipart" _ _ -> - Multipart <$> v .: "body" + makeMultipart h <$> v .: "body" _ -> Part <$> v .: "body" @@ -65,3 +77,73 @@ instance FromJSON Headers where withObject "Header" $ \v -> (,) <$> v .: "key" <*> encodeEncodedWords `fmap` (v .: "value") + + +makeMultipart :: HasHeaders s => s -> NonEmpty MIMEMessage -> MIME +makeMultipart h = + Multipart sub boundary + where + ( sub, boundary ) = + either dummyPrep id $ prepMultipart (h ^. contentType) + + dummyPrep :: (Show a) => a -> (MultipartSubtype, Boundary) + dummyPrep err = + ( Unrecognised $ CI.mk $ C8.pack $ show err + , fromRight (makeBoundaryUnsafe "bad_boundary") $ + makeBoundary $ fromMaybe "no_boundary_found" $ + firstOf (contentType . mimeBoundary) h + ) + + -- Stuff below this line taken from Data.MIME.mime' + + prepMultipart :: ContentType + -> Either MIMEParseError (MultipartSubtype, Boundary) + prepMultipart ct = + (,) <$> parseSubtype ct <*> parseBoundary ct + + parseSubtype :: ContentType + -> Either MIMEParseError MultipartSubtype + parseSubtype ct = case view ctSubtype ct of + "mixed" -> pure Mixed + "alternative" -> pure Alternative + "digest" -> pure Digest + "parallel" -> pure Parallel + "multilingual" -> pure Multilingual + "report" -> Report <$> getRequiredParam "report-type" ct + "signed" -> Signed + <$> getRequiredParam "protocol" ct + <*> getRequiredParam "micalg" ct + "encrypted" -> Encrypted <$> getRequiredParam "protocol" ct + "related" -> Related + <$> ( getRequiredParam "type" ct + >>= \s -> + maybe + (Left $ InvalidParameterValue "type" s) + Right + (preview (parsed parseContentType) s) + ) + <*> getOptionalParam "start" ct + <*> getOptionalParam "start-info" ct + unrecognised -> pure $ Unrecognised unrecognised + + parseBoundary :: HasParameters s => s -> Either MIMEParseError Boundary + parseBoundary ct = + getRequiredParam "boundary" ct + >>= over _Left (InvalidParameterValue "boundary") . makeBoundary + + getRequiredParam :: HasParameters s => + CI ByteString -> s -> Either MIMEParseError ByteString + getRequiredParam k = + maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k) + + getOptionalParam :: HasParameters s => + CI ByteString -> s -> Either a (Maybe ByteString) + getOptionalParam k = + Right . preview (rawParameter k) + +data MIMEParseError + = RequiredParameterMissing (CI ByteString) + | InvalidParameterValue (CI ByteString) ByteString + | MultipartParseFail + | EncapsulatedMessageParseFail + deriving (Eq, Show) |