From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- Action.hs | 200 ------------- Codec/MIME/Base64.hs | 147 ---------- Codec/MIME/Decode.hs | 76 ----- Codec/MIME/Parse.hs | 295 ------------------- Codec/MIME/QuotedPrintable.hs | 66 ----- Codec/MIME/Type.hs | 189 ------------- Codec/MIME/Utils.hs | 33 --- Core.hs | 216 -------------- Data/Aeson/Extends.hs | 15 - Event.hs | 12 - MBox.hs | 156 ----------- MappedSets.hs | 28 -- Network/Mail/Mime.hs | 575 -------------------------------------- Notmuch.hs | 200 ------------- Notmuch/Class.hs | 4 - Notmuch/Message.hs | 123 -------- Notmuch/SearchResult.hs | 61 ---- ParseMail.hs | 312 --------------------- RenderTreeView.hs | 210 -------------- Screen.hs | 32 --- State.hs | 42 --- TagUtils.hs | 62 ---- TreeSearch.hs | 87 ------ TreeView.hs | 229 --------------- TreeView/Types.hs | 63 ----- TreeZipperUtils.hs | 52 ---- Utils.hs | 28 -- config/kmein.hs | 10 +- config/tv.hs | 16 +- much.cabal | 129 ++++++--- src/Codec/MIME/Base64.hs | 146 ++++++++++ src/Codec/MIME/Decode.hs | 76 +++++ src/Codec/MIME/Parse.hs | 295 +++++++++++++++++++ src/Codec/MIME/QuotedPrintable.hs | 66 +++++ src/Codec/MIME/Type.hs | 189 +++++++++++++ src/Codec/MIME/Utils.hs | 33 +++ src/Data/Aeson/Extends.hs | 15 + src/Much/Action.hs | 200 +++++++++++++ src/Much/Core.hs | 216 ++++++++++++++ src/Much/Event.hs | 12 + src/Much/MBox.hs | 156 +++++++++++ src/Much/MappedSets.hs | 28 ++ src/Much/ParseMail.hs | 312 +++++++++++++++++++++ src/Much/RenderTreeView.hs | 210 ++++++++++++++ src/Much/Screen.hs | 32 +++ src/Much/State.hs | 42 +++ src/Much/TagUtils.hs | 62 ++++ src/Much/TreeSearch.hs | 87 ++++++ src/Much/TreeView.hs | 229 +++++++++++++++ src/Much/TreeView/Types.hs | 63 +++++ src/Much/TreeZipperUtils.hs | 52 ++++ src/Much/Utils.hs | 28 ++ src/Network/Mail/Mime.hs | 575 ++++++++++++++++++++++++++++++++++++++ src/Notmuch.hs | 200 +++++++++++++ src/Notmuch/Class.hs | 4 + src/Notmuch/Message.hs | 123 ++++++++ src/Notmuch/SearchResult.hs | 61 ++++ 57 files changed, 3621 insertions(+), 3559 deletions(-) delete mode 100644 Action.hs delete mode 100644 Codec/MIME/Base64.hs delete mode 100644 Codec/MIME/Decode.hs delete mode 100644 Codec/MIME/Parse.hs delete mode 100644 Codec/MIME/QuotedPrintable.hs delete mode 100644 Codec/MIME/Type.hs delete mode 100644 Codec/MIME/Utils.hs delete mode 100644 Core.hs delete mode 100644 Data/Aeson/Extends.hs delete mode 100644 Event.hs delete mode 100644 MBox.hs delete mode 100644 MappedSets.hs delete mode 100644 Network/Mail/Mime.hs delete mode 100644 Notmuch.hs delete mode 100644 Notmuch/Class.hs delete mode 100644 Notmuch/Message.hs delete mode 100644 Notmuch/SearchResult.hs delete mode 100644 ParseMail.hs delete mode 100644 RenderTreeView.hs delete mode 100644 Screen.hs delete mode 100644 State.hs delete mode 100644 TagUtils.hs delete mode 100644 TreeSearch.hs delete mode 100644 TreeView.hs delete mode 100644 TreeView/Types.hs delete mode 100644 TreeZipperUtils.hs delete mode 100644 Utils.hs create mode 100644 src/Codec/MIME/Base64.hs create mode 100644 src/Codec/MIME/Decode.hs create mode 100644 src/Codec/MIME/Parse.hs create mode 100644 src/Codec/MIME/QuotedPrintable.hs create mode 100644 src/Codec/MIME/Type.hs create mode 100644 src/Codec/MIME/Utils.hs create mode 100644 src/Data/Aeson/Extends.hs create mode 100644 src/Much/Action.hs create mode 100644 src/Much/Core.hs create mode 100644 src/Much/Event.hs create mode 100644 src/Much/MBox.hs create mode 100644 src/Much/MappedSets.hs create mode 100644 src/Much/ParseMail.hs create mode 100644 src/Much/RenderTreeView.hs create mode 100644 src/Much/Screen.hs create mode 100644 src/Much/State.hs create mode 100644 src/Much/TagUtils.hs create mode 100644 src/Much/TreeSearch.hs create mode 100644 src/Much/TreeView.hs create mode 100644 src/Much/TreeView/Types.hs create mode 100644 src/Much/TreeZipperUtils.hs create mode 100644 src/Much/Utils.hs create mode 100644 src/Network/Mail/Mime.hs create mode 100644 src/Notmuch.hs create mode 100644 src/Notmuch/Class.hs create mode 100644 src/Notmuch/Message.hs create mode 100644 src/Notmuch/SearchResult.hs diff --git a/Action.hs b/Action.hs deleted file mode 100644 index 95bc7ca..0000000 --- a/Action.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Action where - -import Blessings.String -import Scanner -import State -import TagUtils -import TreeSearch -import TreeView -import TreeZipperUtils -import qualified Data.Tree as Tree -import qualified Data.Tree.Zipper as Z -import qualified Notmuch -import qualified Notmuch.Message as Notmuch -import qualified Notmuch.SearchResult as Notmuch - -displayKey :: String -> State -> IO State -displayKey s q = return q { flashMessage = Plain $ show s } - - -displayMouse :: Scan -> State -> IO State -displayMouse info q = - return q { flashMessage = SGR [38,5,202] $ Plain $ show info } - -defaultMouse1Click :: Monad m => Int -> State -> m State -defaultMouse1Click y q@State{..} = do - let linearClickPos = - let i = (y - length headBuffer + yoffset) - 1 {-zero-based-} - in if 0 <= i && i < length treeBuffer - then Just i - else Nothing - case linearClickPos of - Nothing -> - return q - { flashMessage = Plain "nothing to click" - } - Just i -> - return q - { cursor = findNextN i $ Z.root cursor - } - - -moveCursorDown :: Monad m => Int -> State -> m State -moveCursorDown n q@State{..} = - let cursor' = findNextN n cursor - q' = q { cursor = cursor' } - in case botOverrun q' of - 0 -> return q' - i -> moveTreeUp i q' - - -moveCursorUp :: Monad m => Int -> State -> m State -moveCursorUp n q@State{..} = - let cursor' = findPrevN n cursor - q' = q { cursor = cursor' } - in case topOverrun q' of - 0 -> return q' - i -> moveTreeDown i q' - - -moveTreeUp :: Monad m => Int -> State -> m State -moveTreeUp n q@State{..} = - let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) } - in case topOverrun q' of - 0 -> return q' - i -> moveCursorDown i q' - - -moveTreeDown :: Monad m => Int -> State -> m State -moveTreeDown n q@State{..} = - let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) } - in case botOverrun q' of - 0 -> return q' - i -> moveCursorUp i q' - - -moveTreeLeft :: Monad m => Int -> State -> m State -moveTreeLeft n q@State{..} = - return q { xoffset = xoffset + n } - -moveTreeRight :: Monad m => Int -> State -> m State -moveTreeRight n q@State{..} = - return q { xoffset = max 0 (xoffset - n) } - - -moveToParent :: Monad m => State -> m State -moveToParent q@State{..} = - case Z.parent cursor of - Nothing -> return q { flashMessage = "cannot go further up" } - Just cursor' -> - let q' = q { cursor = cursor' } - in case topOverrun q' of - 0 -> return q' - i -> moveTreeDown i q' - - -moveCursorToUnread - :: (Num a, Monad m, Eq a) - => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView)) - -> (State -> a) - -> (a -> State -> m State) - -> State -> m State -moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} = - case cursorMove cursor >>= rec of - Just cursor' -> - let q' = q { cursor = cursor' } - in case getTreeMoveCount q' of - 0 -> return q' - i -> treeMove i q' - Nothing -> - return q { flashMessage = "no unread message in sight" } - where - rec loc = - if hasTag "unread" loc - then Just loc - else cursorMove loc >>= rec - hasTag tag loc = - case Z.label loc of - TVSearchResult sr -> - tag `elem` Notmuch.searchTags sr - TVMessage m -> - tag `elem` Notmuch.messageTags m - _ -> - False - -moveCursorUpToPrevUnread :: Monad m => State -> m State -moveCursorUpToPrevUnread = - moveCursorToUnread findPrev topOverrun moveTreeDown - -moveCursorDownToNextUnread :: Monad m => State -> m State -moveCursorDownToNextUnread = - moveCursorToUnread findNext botOverrun moveTreeUp - - -openFold :: State -> IO State -openFold q@State{..} = - handle <$> loadSubForest (Z.label cursor) - where - handle = \case - Left err -> - q { flashMessage = SGR [31] $ Plain err } - Right sf -> - q { cursor = Z.modifyTree (setSubForest sf) cursor } - -closeFold :: State -> IO State -closeFold q@State{..} = - let sf = unloadSubForest (Z.tree cursor) - in return q { cursor = Z.modifyTree (setSubForest sf) cursor } - -toggleFold :: State -> IO State -toggleFold q@State{..} = - if hasUnloadedSubForest (Z.tree cursor) - then openFold q - else closeFold q - - -toggleTagAtCursor :: Tag -> State -> IO State -toggleTagAtCursor tag q@State{..} = case Z.label cursor of - - TVSearchResult sr -> do - let tagOp = - if tag `elem` Notmuch.searchTags sr - then DelTag - else AddTag - tagOps = [tagOp tag] - Notmuch.notmuchTag tagOps sr - let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor - return q { cursor = cursor' } - - TVMessage m -> do - let tagOp = - if tag `elem` Notmuch.messageTags m - then DelTag - else AddTag - tagOps = [tagOp tag] - Notmuch.notmuchTag tagOps m - let cursor' = - -- TODO this needs a nice name - modifyFirstParentLabelWhere isTVSearchResult f $ - Z.modifyLabel f cursor - f = patchTags tagOps - return q { cursor = cursor' } - - _ -> return q { flashMessage = "nothing happened" } - - -topOverrun :: State -> Int -topOverrun State{..} = - max 0 (- (linearPos cursor - yoffset)) - - -botOverrun :: State -> Int -botOverrun State{..} = - max 0 (linearPos cursor - yoffset - (screenHeight - length headBuffer - 1)) - - -setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a -setSubForest sf t = t { Tree.subForest = sf } diff --git a/Codec/MIME/Base64.hs b/Codec/MIME/Base64.hs deleted file mode 100644 index f60419b..0000000 --- a/Codec/MIME/Base64.hs +++ /dev/null @@ -1,147 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : Codec.MIME.Base64 --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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 - diff --git a/Codec/MIME/Decode.hs b/Codec/MIME/Decode.hs deleted file mode 100644 index 278d6f6..0000000 --- a/Codec/MIME/Decode.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : Codec.MIME.Decode --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- 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 enc body = - case map toLower enc of - "base64" -> Base64.decodeToString body - "quoted-printable" -> QP.decode body - _ -> 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 str = - case str of - '=':'?':xs -> - case dropLang $ break (\ch -> ch =='?' || ch == '*') xs of - (cs,_:x:'?':bs) - | isKnownCharset (map toLower cs) -> - case toLower x of - 'q' -> decodeQ cs (break (=='?') bs) - 'b' -> decodeB cs (break (=='?') bs) - _ -> Nothing - _ -> Nothing - _ -> Nothing - where - isKnownCharset cs = cs `elem` ["iso-8859-1", "us-ascii"] - - -- ignore RFC 2231 extension of permitting a language tag to be supplied - -- after the charset. - dropLang (as,'*':bs) = (as,dropWhile (/='?') bs) - dropLang (as,bs) = (as,bs) - - decodeQ cset (fs,'?':'=':rs) = Just (fromCharset cset (QP.decode fs),rs) - decodeQ _ _ = Nothing - - decodeB cset (fs,'?':'=':rs) = - Just (fromCharset cset (Base64.decodeToString fs),rs) - decodeB _ _ = Nothing - - fromCharset _cset cs = cs - -decodeWords :: String -> String -decodeWords "" = "" -decodeWords (x:xs) - | isSpace x = x : decodeWords xs - | otherwise = - case decodeWord (x:xs) of - Nothing -> x : decodeWords xs - Just (as,bs) -> as ++ decodeWords bs - - diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs deleted file mode 100644 index c5392fe..0000000 --- a/Codec/MIME/Parse.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------- --- | --- Module : Codec.MIME.Pare --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- Stability : provisional --- Portability: portable --- --- Parsing MIME content. --- --------------------------------------------------------------------- -module Codec.MIME.Parse - ( parseMIMEBody -- :: [(T.Text,T.Text)] -> T.Text -> MIMEValue - , parseMIMEType -- :: T.Text -> Maybe Type - , parseMIMEMessage -- :: T.Text -> MIMEValue - - , parseHeaders -- :: T.Text -> ([(T.Text,T.Text)], T.Text) - , parseMultipart -- :: Type -> T.Text -> (MIMEValue, T.Text) - , parseContentType -- :: T.Text -> Maybe Type - , splitMulti -- :: T.Text -> T.Text -> ([MIMEValue], T.Text) - , normalizeCRLF - ) where - -import Codec.MIME.Type -import Codec.MIME.Decode -import Control.Arrow(second) - -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Char -import Data.Maybe -import qualified Data.List as L -import Debug.Trace ( trace ) -import qualified Data.Text as T -import Data.Monoid(Monoid(..), (<>)) - -enableTrace :: Bool -enableTrace = False - -doTrace :: String -> b -> b -doTrace | enableTrace = trace - | otherwise = \_ x -> x - - -parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue -parseMIMEBody headers body = result { mime_val_headers = headers } - where - result = case mimeType mty of - Multipart{} -> fst (parseMultipart mty body) - Message{} -> fst (parseMultipart mty body) - _ -> nullMIMEValue { mime_val_type = mty - , mime_val_disp = parseContentDisp headers - , mime_val_content = Single (processBody headers body) - } - mty = fromMaybe defaultType - (parseContentType =<< lookupField "content-type" (paramPairs headers)) -defaultType :: Type -defaultType = Type { mimeType = Text "plain" - , mimeParams = [MIMEParam "charset" "us-ascii"] - } - -parseContentDisp :: [MIMEParam] -> Maybe Disposition -parseContentDisp headers = - (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" (paramPairs headers) - where - processDisp t | T.null t = Nothing - | T.null bs = Just $ Disposition { dispType = toDispType as - , dispParams = [] - } - | otherwise = Just $ Disposition { dispType = toDispType as - , dispParams = processParams (parseParams bs) - } - where (as,bs) = T.break (\ch -> isSpace ch || ch == ';') t - - processParams = map procP - where - procP (MIMEParam k val) - | "name" == k = Name val - | "filename" == k = Filename val - | "creation-date" == k = CreationDate val - | "modification-date" == k = ModDate val - | "read-date" == k = ReadDate val - | "size" == k = Size val - | otherwise = OtherParam k val - - toDispType t = if t == "inline" then DispInline - else if t == "attachment" then DispAttachment - else if t == "form-data" then DispFormData - else DispOther t - -paramPairs :: [MIMEParam] -> [(CI T.Text, T.Text)] -paramPairs = map paramPair - where - paramPair (MIMEParam a b) = (a,b) - -processBody :: [MIMEParam] -> T.Text -> T.Text -processBody headers body = - case lookupField "content-transfer-encoding" $ paramPairs headers of - Nothing -> body - Just v -> T.pack $ decodeBody (T.unpack v) $ T.unpack body - -normalizeCRLF :: T.Text -> T.Text -normalizeCRLF t - | T.null t = "" - | "\r\n" `T.isPrefixOf` t = "\r\n" <> normalizeCRLF (T.drop 2 t) - | any (`T.isPrefixOf` t) ["\r", "\n"] = "\r\n" <> normalizeCRLF (T.drop 1 t) - | otherwise = let (a,b) = T.break (`elem` ("\r\n" :: String)) t in a <> normalizeCRLF b - -parseMIMEMessage :: T.Text -> MIMEValue -parseMIMEMessage entity = - case parseHeaders (normalizeCRLF entity) of - (as,bs) -> parseMIMEBody as bs - -parseHeaders :: T.Text -> ([MIMEParam], T.Text) -parseHeaders str = - case findFieldName "" str of - Left (nm, rs) -> parseFieldValue (CI.mk nm) (dropFoldingWSP rs) - Right body -> ([],body) - where - findFieldName acc t - | T.null t = Right "" - | "\r\n" `T.isPrefixOf` t = Right $ T.drop 2 t - | ":" `T.isPrefixOf` t = Left (T.reverse $ T.dropWhile isHSpace acc, T.drop 1 t) - | otherwise = findFieldName (T.take 1 t <> acc) $ T.drop 1 t - - parseFieldValue nm xs - | T.null bs = ([MIMEParam nm as], "") - | otherwise = let (zs,ys) = parseHeaders bs in (MIMEParam nm as :zs, ys) - where - (as,bs) = takeUntilCRLF xs - -parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text) -parseMultipart mty body = - case lookupField "boundary" (paramPairs $ mimeParams mty) of - Nothing -> doTrace ("Multipart mime type, " ++ T.unpack (showType mty) ++ - ", has no required boundary parameter. Defaulting to text/plain") $ - (nullMIMEValue{ mime_val_type = defaultType - , mime_val_disp = Nothing - , mime_val_content = Single body - }, "") - Just bnd -> (nullMIMEValue { mime_val_type = mty - , mime_val_disp = Nothing - , mime_val_content = Multi vals - }, rs) - where (vals,rs) = splitMulti bnd body - -splitMulti :: T.Text -> T.Text -> ([MIMEValue], T.Text) -splitMulti bnd body_in = - -- Note: we insert a CRLF if it looks as if the boundary string starts - -- right off the bat. No harm done if this turns out to be incorrect. - let body | "--" `T.isPrefixOf` body_in = "\r\n" <> body_in - | otherwise = body_in - in case untilMatch dashBoundary body of - Nothing -> mempty - Just xs | "--" `T.isPrefixOf` xs -> ([], T.drop 2 xs) - | otherwise -> splitMulti1 (dropTrailer xs) - - where - dashBoundary = ("\r\n--" <> bnd) - - splitMulti1 xs - | T.null as && T.null bs = ([], "") - | T.null bs = ([parseMIMEMessage as],"") - | T.isPrefixOf "--" bs = ([parseMIMEMessage as], dropTrailer bs) - | otherwise = let (zs,ys) = splitMulti1 (dropTrailer bs) - in ((parseMIMEMessage as) : zs,ys) - - where - (as,bs) = matchUntil dashBoundary xs - - dropTrailer xs - | "\r\n" `T.isPrefixOf` xs1 = T.drop 2 xs1 - | otherwise = xs1 -- hmm, flag an error? - where - xs1 = T.dropWhile isHSpace xs - -parseMIMEType :: T.Text -> Maybe Type -parseMIMEType = parseContentType - -parseContentType :: T.Text -> Maybe Type -parseContentType str - | T.null minor0 = doTrace ("unable to parse content-type: " ++ show str) $ Nothing - | otherwise = Just Type { mimeType = toType (CI.mk maj) as - , mimeParams = parseParams (T.dropWhile isHSpace bs) - } - where - (maj, minor0) = T.break (=='/') (dropFoldingWSP str) - minor = T.drop 1 minor0 - (as, bs) = T.break (\ ch -> isHSpace ch || isTSpecial ch) minor - toType a b = case lookupField a mediaTypes of - Just ctor -> ctor b - _ -> Other a b - -parseParams :: T.Text -> [MIMEParam] -parseParams t | T.null t = [] - | ';' == T.head t = let (nm_raw, vs0) = T.break (=='=') (dropFoldingWSP $ T.tail t) - nm = CI.mk nm_raw in - if T.null vs0 - then [] - else let vs = T.tail vs0 in - if not (T.null vs) && T.head vs == '"' - then let vs1 = T.tail vs - (val, zs0) = T.break (=='"') vs1 in - if T.null zs0 - then [MIMEParam nm val] - else MIMEParam nm val : parseParams (T.dropWhile isHSpace $ T.tail zs0) - else let (val, zs) = T.break (\ch -> isHSpace ch || isTSpecial ch) vs in - MIMEParam nm val : parseParams (T.dropWhile isHSpace zs) - | otherwise = doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show t) [] - -mediaTypes :: [(CI T.Text, T.Text -> MIMEType)] -mediaTypes = - [ ("multipart", (Multipart . toMultipart)) - , ("application", Application) - , ("audio", Audio) - , ("image", Image) - , ("message", Message) - , ("model", Model) - , ("text", Text) - , ("video", Video) - ] - where toMultipart b = fromMaybe other (lookupField (CI.mk b) multipartTypes) - where other | T.isPrefixOf "x-" b = Extension b - | otherwise = OtherMulti b - -multipartTypes :: [(CI T.Text, Multipart)] -multipartTypes = - [ ("alternative", Alternative) - , ("byteranges", Byteranges) - , ("digest", Digest) - , ("encrypted", Encrypted) - , ("form-data", FormData) - , ("mixed", Mixed) - , ("parallel", Parallel) - , ("related", Related) - , ("signed", Signed) - ] - -untilMatch :: T.Text -> T.Text -> Maybe T.Text -untilMatch a b | T.null a = Just b - | T.null b = Nothing - | a `T.isPrefixOf` b = Just $ T.drop (T.length a) b - | otherwise = untilMatch a $ T.tail b - -matchUntil :: T.Text -> T.Text -> (T.Text, T.Text) --- searching str; returning parts before str and after str -matchUntil str = second (T.drop $ T.length str) . T.breakOn str - -{- -matchUntil' :: T.Text -> T.Text -> (T.Text, T.Text) -matchUntil' _ "" = ("", "") -matchUntil' str xs - | T.null xs = mempty - -- slow, but it'll do for now. - | str `T.isPrefixOf` xs = ("", T.drop (T.length str) xs) - | otherwise = let (as,bs) = matchUntil' str $ T.tail xs in (T.take 1 xs <> as, bs) --} - -isHSpace :: Char -> Bool -isHSpace c = c == ' ' || c == '\t' - -isTSpecial :: Char -> Bool -isTSpecial x = x `elem` ("()<>@,;:\\\"/[]?=" :: String) -- " - -dropFoldingWSP :: T.Text -> T.Text -dropFoldingWSP t | T.null t = "" - | isHSpace (T.head t) = dropFoldingWSP $ T.tail t - | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t) - = dropFoldingWSP $ T.drop 3 t - | otherwise = t - -takeUntilCRLF :: T.Text -> (T.Text, T.Text) -takeUntilCRLF str = go "" str - where - go acc t | T.null t = (T.reverse (T.dropWhile isHSpace acc), "") - | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t) - = go (" " <> acc) (T.drop 3 t) - | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) - = (T.reverse (T.dropWhile isHSpace acc), T.drop 2 t) - | otherwise = go (T.take 1 t <> acc) $ T.tail t - --- case in-sensitive lookup of field names or attributes\/parameters. -lookupField :: CI T.Text -> [(CI T.Text,a)] -> Maybe a -lookupField n ns = - -- assume that inputs have been mostly normalized already - -- (i.e., lower-cased), but should the lookup fail fall back - -- to a second try where we do normalize before giving up. - case lookup n ns of - x@Just{} -> x - Nothing -> - fmap snd $ L.find ((n==) . fst) ns - diff --git a/Codec/MIME/QuotedPrintable.hs b/Codec/MIME/QuotedPrintable.hs deleted file mode 100644 index cdc2266..0000000 --- a/Codec/MIME/QuotedPrintable.hs +++ /dev/null @@ -1,66 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : Codec.MIME.QuotedPrintable --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- Stability : provisional --- Portability: --- --- To and from QP content encoding. --- --------------------------------------------------------------------- -module Codec.MIME.QuotedPrintable - ( decode -- :: String -> String - , encode -- :: String -> String - ) where - -import Data.Char - --- | 'decode' incoming quoted-printable content, stripping --- out soft line breaks and translating @=XY@ sequences --- into their decoded byte\/octet. The output encoding\/representation --- is still a String, not a sequence of bytes. -decode :: String -> String -decode "" = "" -decode ('=':'\r':'\n':xs) = decode xs -- soft line break. -decode ('=':x1:x2:xs) - | isHexDigit x1 && isHexDigit x2 = - chr (digitToInt x1 * 16 + digitToInt x2) : decode xs -decode ('=':xs) = '=':decode xs - -- make it explicit that we propagate other '=' occurrences. -decode (x1:xs) = x1:decode xs - --- | 'encode' converts a sequence of characeter _octets_ into --- quoted-printable form; suitable for transmission in MIME --- payloads. Note the stress on _octets_; it is assumed that --- you have already converted Unicode into a <=8-bit encoding --- (UTF-8, most likely.) -encode :: String -> String -encode xs = encodeLength 0 xs - --- | @encodeLength llen str@ is the worker function during encoding. --- The extra argument @llen@ tracks the current column for the line --- being processed. Soft line breaks are inserted if a line exceeds --- a max length. -encodeLength :: Int -> String -> String -encodeLength _ "" = "" -encodeLength n (x:xs) - | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) -encodeLength _ ('=':xs) - = '=':'3':'D':encodeLength 0 xs -encodeLength n (x:xs) - | ox >= 0x100 = error ("QuotedPrintable.encode: encountered > 8 bit character: " ++ show (x,ox)) - | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) - | ox >= 0x21 && ox <= 0x7e = x : encodeLength (n+1) xs - | ox == 0x09 || ox == 0x20 = x : encodeLength (n+1) xs - | otherwise = '=':showH (ox `div` 0x10): showH (ox `mod` 0x10):encodeLength (n+3) xs - where - ox = ord x - showH v - | v < 10 = chr (ord_0 + v) - | otherwise = chr (ord_A + (v-10)) - - ord_0 = ord '0' - ord_A = ord 'A' diff --git a/Codec/MIME/Type.hs b/Codec/MIME/Type.hs deleted file mode 100644 index 72ec94f..0000000 --- a/Codec/MIME/Type.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------- --- | --- Module : Codec.MIME.Type --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- Stability : provisional --- Portability: portable --- --- --- Representing MIME types and values. --- --------------------------------------------------------------------- -module Codec.MIME.Type where - -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import qualified Data.Text as T -import Data.Monoid ((<>)) - -data MIMEParam = MIMEParam { paramName :: CI T.Text - , paramValue :: T.Text } - deriving (Show, Ord, Eq) - -data Type = Type - { mimeType :: MIMEType - , mimeParams :: [MIMEParam] - } deriving ( Show, Ord, Eq ) - --- | The @null@ MIME record type value; currently a @text/plain@. -nullType :: Type -nullType = Type - { mimeType = Text "plain" - , mimeParams = [] - } - -showType :: Type -> T.Text -showType t = showMIMEType (mimeType t) <> showMIMEParams (mimeParams t) - -showMIMEParams :: [MIMEParam] -> T.Text -showMIMEParams ps = T.concat $ map showP ps - where - showP (MIMEParam k v) = "; " <> CI.original k <> "=\"" <> v <> "\"" - - -data MIMEType - = Application SubType - | Audio SubType - | Image SubType - | Message SubType - | Model SubType - | Multipart Multipart - | Text TextType - | Video SubType - | Other {otherType :: CI T.Text, otherSubType :: SubType} - deriving ( Show, Ord, Eq ) - -showMIMEType :: MIMEType -> T.Text -showMIMEType t = - case t of - Application s -> "application/"<>s - Audio s -> "audio/"<>s - Image s -> "image/"<>s - Message s -> "message/"<>s - Model s -> "model/"<>s - Multipart s -> "multipart/"<>showMultipart s - Text s -> "text/"<>s - Video s -> "video/"<>s - Other a b -> CI.original a <> "/" <> b - --- | a (type, subtype) MIME pair. -data MIMEPair - = MIMEPair T.Text SubType - deriving ( Eq ) - -showMIMEPair :: MIMEPair -> T.Text -showMIMEPair (MIMEPair a b) = a <> "/" <> b - --- | default subtype representation. -type SubType = T.Text - --- | subtype for text content; currently just a string. -type TextType = SubType - -subTypeString :: Type -> T.Text -subTypeString t = T.drop 1 $ snd $ T.break (=='/') (showMIMEType (mimeType t)) - -majTypeString :: Type -> T.Text -majTypeString t = fst $ T.break (=='/') (showMIMEType (mimeType t)) - -data Multipart - = Alternative - | Byteranges - | Digest - | Encrypted - | FormData - | Mixed - | Parallel - | Related - | Signed - | Extension T.Text -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit) - | OtherMulti T.Text -- unrecognized\/uninterpreted. - -- (e.g., appledouble, voice-message, etc.) - deriving ( Show, Ord, Eq ) - -isXmlBased :: Type -> Bool -isXmlBased t = - case mimeType t of - Multipart{} -> False - _ -> "+xml" `T.isSuffixOf` subTypeString t - -isXmlType :: Type -> Bool -isXmlType t = isXmlBased t || - case mimeType t of - Application s -> s `elem` xml_media_types - Text s -> s `elem` xml_media_types - _ -> False - where - -- Note: xml-dtd isn't considered an XML type here. - xml_media_types :: [T.Text] - xml_media_types = - [ "xml" - , "xml-external-parsed-entity" - ] - - -showMultipart :: Multipart -> T.Text -showMultipart m = - case m of - Alternative -> "alternative" - Byteranges -> "byteranges" - Digest -> "digest" - Encrypted -> "encrypted" - FormData -> "form-data" - Mixed -> "mixed" - Parallel -> "parallel" - Related -> "related" - Signed -> "signed" - Extension e -> e - OtherMulti e -> e - -type Content = T.Text - -data MIMEValue = MIMEValue - { mime_val_type :: Type - , mime_val_disp :: Maybe Disposition - , mime_val_content :: MIMEContent - , mime_val_headers :: [MIMEParam] - , mime_val_inc_type :: Bool - } deriving ( Show, Eq ) - -nullMIMEValue :: MIMEValue -nullMIMEValue = MIMEValue - { mime_val_type = nullType - , mime_val_disp = Nothing - , mime_val_content = Multi [] - , mime_val_headers = [] - , mime_val_inc_type = True - } - -data MIMEContent - = Single Content - | Multi [MIMEValue] - deriving (Eq,Show) - -data Disposition - = Disposition - { dispType :: DispType - , dispParams :: [DispParam] - } deriving ( Show, Eq ) - -data DispType - = DispInline - | DispAttachment - | DispFormData - | DispOther T.Text - deriving ( Show, Eq) - -data DispParam - = Name T.Text - | Filename T.Text - | CreationDate T.Text - | ModDate T.Text - | ReadDate T.Text - | Size T.Text - | OtherParam (CI T.Text) T.Text - deriving ( Show, Eq) diff --git a/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs deleted file mode 100644 index dd54860..0000000 --- a/Codec/MIME/Utils.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : Codec.MIME.Utils --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne --- Stability : provisional --- Portability: portable --- --- Extracting content from MIME values and types. --- --------------------------------------------------------------------- -module Codec.MIME.Utils - ( findMultipartNamed -- :: String -> MIMEValue -> Maybe MIMEValue - ) where - -import Codec.MIME.Type -import Data.List ( find ) -import Control.Monad ( msum ) -import Data.Text(Text) - --- | Given a parameter name, locate it within a MIME value, --- returning the corresponding (sub) MIME value. -findMultipartNamed :: Text -> MIMEValue -> Maybe MIMEValue -findMultipartNamed nm mv = - case mime_val_content mv of - Multi ms -> msum (map (findMultipartNamed nm) ms) - Single {} -> do cd <- mime_val_disp mv - _ <- find (withDispName nm) (dispParams cd) - return mv - where withDispName a (Name b) = a == b - withDispName _ _ = False diff --git a/Core.hs b/Core.hs deleted file mode 100644 index 5971769..0000000 --- a/Core.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Core where - -import Action -import Blessings.String (Blessings(Plain,SGR),pp) -import Control.Concurrent -import Control.Monad -import Data.Time -import Event -import RenderTreeView (renderTreeView) -import Scanner (scan,Scan(..)) -import Screen -import State -import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) -import System.Environment -import System.IO -import System.Posix.Signals -import TreeSearch -import TreeView -import Utils -import qualified Blessings.Internal as Blessings -import qualified Data.Tree as Tree -import qualified Data.Tree.Zipper as Z -import qualified Notmuch -import qualified System.Console.Terminal.Size as Term - - - -emptyState :: State -emptyState = State - { cursor = Z.fromTree (Tree.Node (TVSearch "") []) - , xoffset = 0 - , yoffset = 0 - , flashMessage = "Welcome to much; quit with ^C" - , screenWidth = 0 - , screenHeight = 0 - , headBuffer = [] - , treeBuffer = [] - , now = UTCTime (fromGregorian 1984 5 23) 49062 - , signalHandlers = [] - , query = "tag:inbox AND NOT tag:killed" - , keymap = displayKey - , mousemap = displayMouse - , colorConfig = ColorConfig - { tagMap = - [ ("killed", SGR [38,5,088]) - , ("star", SGR [38,5,226]) - , ("draft", SGR [38,5,202]) - ] - , alt = SGR [38,5,182] - , search = SGR [38,5,162] - , focus = SGR [38,5,160] - , quote = SGR [38,5,242] - , boring = SGR [38,5,240] - , prefix = SGR [38,5,235] - , date = SGR [38,5,071] - , tags = SGR [38,5,036] - , boringMessage = SGR [38,5,023] - , unreadMessage = SGR [38,5,117] - , unreadSearch = SGR [38,5,250] - } - , tagSymbols = [] - } - -notmuchSearch :: State -> IO State -notmuchSearch q@State{query} = do - r_ <- either error id <$> Notmuch.search - [ "--offset=0" - , "--limit=100" - , query - ] - - return q { cursor = Z.fromTree $ fromSearchResults query r_ } - -mainWithState :: State -> IO () -mainWithState state = mainWithStateAndArgs state =<< getArgs - -mainWithStateAndArgs :: State -> [String] -> IO () -mainWithStateAndArgs state@State{query = defaultSearch} args = do - usage' <- parseUsageOrExit usage - args' <- parseArgsOrExit usage' args - let query = getArgWithDefault args' defaultSearch (shortOption 'q') - withScreen s0 (\_-> notmuchSearch state { query = query } >>= runState) - where - usage = unlines - [ "Command-line MUA using notmuch." - , "" - , "Usage:" - , " much [-q ]" - , "" - , "Options:" - , " -q , --query=" - , " Open specific search, defaults to " ++ show defaultSearch - ] - - s0 = Screen False NoBuffering (BlockBuffering $ Just 4096) - [ 1000 -- X & Y on button press and release - , 1005 -- UTF-8 mouse mode - , 1047 -- use alternate screen buffer - ] - [ 25 -- hide cursor - ] - -runState :: State -> IO () -runState q0 = do - - -- load-env hack - maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME" - - (putEvent, getEvent) <- do - v <- newEmptyMVar - return (putMVar v, takeMVar v) - - let q1 = q0 { signalHandlers = - [ (sigINT, putEvent EShutdown) - , (28, winchHandler putEvent) - ] } - - installHandlers (signalHandlers q1) - - threadIds <- mapM forkIO - [ forever $ scan stdin >>= putEvent . EScan - ] - - winchHandler putEvent - - run getEvent q1 - mapM_ killThread threadIds - - -installHandlers :: [(Signal, IO ())] -> IO () -installHandlers = - mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) - -uninstallHandlers :: [(Signal, IO ())] -> IO () -uninstallHandlers = - mapM_ (\(s, _) -> installHandler s Ignore Nothing) - - -winchHandler :: (Event -> IO ()) -> IO () -winchHandler putEvent = - Term.size >>= \case - Just Term.Window {Term.width = w, Term.height = h} -> - putEvent $ EResize w h - Nothing -> - return () - -run :: IO Event -> State -> IO () -run getEvent = rec . Right where - rec = \case - Right q -> rec =<< do - t <- getCurrentTime - let q' = render q { now = t } - redraw q' >> getEvent >>= processEvent q' - Left _q -> return () - - -processEvent :: State -> Event -> IO (Either State State) -processEvent q = \case - EFlash t -> - return $ Right q { flashMessage = t } - EScan (ScanKey s) -> - Right <$> keymap q s q - EScan info@ScanMouse{..} -> - Right <$> mousemap q info q - EShutdown -> - return $ Left q - EResize w h -> - return $ Right q - { screenWidth = w, screenHeight = h - , flashMessage = Plain $ "resize " <> show (w,h) - } - ev -> - return $ Right q - { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev - } - - -render :: State -> State -render q@State{..} = - q { treeBuffer = newTreeBuf - , headBuffer = newHeadBuf - } - where - newTreeBuf = renderTreeView q (Z.root cursor) - newHeadBuf = - [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight) - <> " " <> Plain (show $ linearPos cursor - yoffset) - <> " " <> Plain (show $ topOverrun q) - <> " " <> Plain (show $ botOverrun q) - <> " " <> flashMessage - <> " " <> Plain (show (xoffset, yoffset)) - ] - -render0 :: State -> [Blessings String] -render0 _q@State{..} = do - let buffer = - map (Blessings.take screenWidth . Blessings.drop xoffset) $ - take screenHeight $ - headBuffer ++ drop yoffset treeBuffer - buffer ++ replicate (screenHeight - length buffer) "~" - - -redraw :: State -> IO () -redraw q@State{..} = do - hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ pp (mintercalate "\n" $ map eraseRight $ render0 q) - hFlush stdout - where - sub x x' c = if c == x then x' else c - eraseRight s = - if Blessings.length s < screenWidth - then s <> "\ESC[K" - else s diff --git a/Data/Aeson/Extends.hs b/Data/Aeson/Extends.hs deleted file mode 100644 index d78f81d..0000000 --- a/Data/Aeson/Extends.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Data.Aeson.Extends (module Data.Aeson.Extends) where - -import Data.Aeson as Data.Aeson.Extends - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text.Encoding.Error as TE -import qualified Data.Text.Lazy.Encoding as LT - - -eitherDecodeLenient' :: FromJSON a => LBS.ByteString -> Either String a -eitherDecodeLenient' s = - either (const $ eitherDecode' $ lenientReencode s) id (eitherDecode' s) - where - lenientReencode = LT.encodeUtf8 . LT.decodeUtf8With TE.lenientDecode - diff --git a/Event.hs b/Event.hs deleted file mode 100644 index 5790aac..0000000 --- a/Event.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Event where - -import Blessings -import Scanner - -data Event = - EFlash (Blessings String) | - EScan Scan | - EShutdown | - EReload | - EResize Int Int - deriving Show diff --git a/MBox.hs b/MBox.hs deleted file mode 100644 index 5071e48..0000000 --- a/MBox.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module MBox - ( - -- TODO don't re-export MBox but use our own Message type - module Export - , getMessageId - , toForest - ) where - -import qualified Data.MBox as Export - -import Control.Applicative -import qualified Data.CaseInsensitive as CI -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.MBox -import Data.Ord -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text.Lazy (Text) -import Data.Time -import Data.Tree (Tree, Forest) -import qualified Data.Tree as Tree -import qualified MappedSets -import qualified Data.Text.Lazy as Text -import Safe -import System.Locale -import qualified Text.ParserCombinators.Parsec.Rfc2822 as P -import qualified Text.ParserCombinators.Parsec as P - - -type Ident = Text - - -data IdentFields = IdentFields - { messageId :: Ident - , inReplyTo :: [Ident] - , references :: [Ident] - } - deriving Show - - -toForest :: MBox -> Forest Message -toForest mbox = - map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $ - concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs) - where - - mkSubTree rootLabel = - Tree.Node rootLabel $ - map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs) - - refs = mboxRefs mbox - backRefs = MappedSets.invert refs - msgs = unpackMBox mbox - - --- TODO finde a new home for roots -roots :: Ord a => Map a (Set a) -> Set a -roots refs = - Set.unions $ Map.elems $ Map.filter p refs - where - messageIDs = Set.fromList $ Map.keys refs - p = Set.null . Set.intersection messageIDs - - --- TODO finde a new home for sortTree -sortTree :: Tree Message -> Tree Message -sortTree t = - Tree.Node (Tree.rootLabel t) $ - map sortTree $ - List.sortOn (getMessageDate . Tree.rootLabel) $ - Tree.subForest t - - -getMessageDate :: Message -> Maybe UTCTime -getMessageDate msg = - parseTime defaultTimeLocale rfc822DateFormat =<< - Text.unpack . snd <$> - (lastMay $ - filter ((==CI.mk "Date") . CI.mk . Text.unpack . fst) $ - headers msg) - - -unpackMBox :: MBox -> Map Ident Message -unpackMBox = - Map.fromList . - map (\msg -> (getMessageId $ headers msg, msg)) - - -getIdentFields :: Message -> IdentFields -getIdentFields m = - IdentFields - { messageId = getMessageId hdrs - , inReplyTo = getInReplyTo hdrs - , references = getReferences hdrs - } - where - hdrs = headers m - - --- TODO generate default Message-ID if not present -getMessageId :: [Header] -> Ident -getMessageId = - head . - headerMessageIds "Message-ID" - - -getInReplyTo :: [Header] -> [Ident] -getInReplyTo = - headerMessageIds "In-Reply-To" - - -getReferences :: [Header] -> [Ident] -getReferences = - headerMessageIds "References" - - -headerMessageIds :: P.SourceName -> [Header] -> [Ident] -headerMessageIds headerName = - concatMap ( - either ((:[]) . Text.pack . show) id . - parseMsgIds headerName . - snd - ) . - filter ((==CI.mk headerName) . CI.mk . Text.unpack . fst) - - -parseMsgIds :: P.SourceName -> Text -> Either P.ParseError [Ident] -parseMsgIds srcName = - fmap (map (Text.init . Text.tail . Text.pack)) . - P.parse obs_in_reply_to_parser srcName . - Text.unpack - where - --obs_in_reply_to_parser :: CharParser a [String] - obs_in_reply_to_parser = - --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id) - P.many1 P.msg_id - - -messageRefs :: IdentFields -> [Ident] -messageRefs IdentFields{..} = - if null inReplyTo - then maybe [""] (:[]) (lastMay references) - else inReplyTo - - -mboxRefs :: MBox -> Map Ident (Set Ident) -mboxRefs = - MappedSets.mk . - map (\m -> - let x = getIdentFields m - in (messageId x, messageRefs x)) diff --git a/MappedSets.hs b/MappedSets.hs deleted file mode 100644 index c3045c6..0000000 --- a/MappedSets.hs +++ /dev/null @@ -1,28 +0,0 @@ -module MappedSets (invert, mk) where - -import Control.Arrow -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set - - -mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b) -mk = - Map.fromList . map (second Set.fromList) - - -invert :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a) -invert = - Map.foldrWithKey invert1 Map.empty - - -invert1 :: (Ord a, Ord b) => a -> Set b -> Map b (Set a) -> Map b (Set a) -invert1 k v a = - Set.foldr (upsert k) a v - - -upsert :: (Ord a, Ord b) => a -> b -> Map b (Set a) -> Map b (Set a) -upsert k = - Map.alter (Just . Set.insert k . fromMaybe Set.empty) diff --git a/Network/Mail/Mime.hs b/Network/Mail/Mime.hs deleted file mode 100644 index 8fd9fe1..0000000 --- a/Network/Mail/Mime.hs +++ /dev/null @@ -1,575 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} -module Network.Mail.Mime - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachments - , addAttachmentBS - , addAttachmentsBS - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - (:) ("Content-Type", contentType) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\r\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\r\n" - , finalBuilder - ] - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString k - , fromByteString ": " - , encodeIfNeeded v - , fromByteString "\r\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\r\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((`mappend` fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (addressEmail a) - , fromByteString ">" - ] - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\r\n" - , mconcat $ map showHeader headers - , fromByteString "\r\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\r\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -#ifdef MIME_MAIL_SENDMAIL_PATH -sendmailPath = MIME_MAIL_SENDMAIL_PATH -#else -sendmailPath = "/usr/sbin/sendmail" -#endif - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = do - (Just hin, _, _, phandle) <- createProcess $ - (proc sm opts) { std_in = CreatePipe } - L.hPut hin lbs - hClose hin - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> return () - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart bo