FmtComb.hs

--------------------------------------------------------------------
-- |
-- Module    : FmtComb
-- Copyright : (c) Nicolas Pouillard 2010, 2011
-- License   : BSD3
--
-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------

{-# LANGUAGE BangPatterns,
             OverloadedStrings, GeneralizedNewtypeDeriving #-}
module FmtComb where

import Control.Applicative
import Control.Monad.Reader
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as B
{- TMP-NO-MIME
import Codec.MIME.Type (MIMEValue(..), Type(..), showMIMEType)
-}
import Codec.Mbox (MboxMessage(..), showMboxMessage)
import qualified Data.Digest.Pure.MD5 as MD5 (md5)
import Data.Maybe (fromMaybe)
import Data.List (intersperse)
import Data.Monoid (Monoid(..))
import Data.Char (isSpace)
import Email

type Message = (Email, MboxMessage B.ByteString)

newtype ReaderMsg a = ReaderMsg { runReaderMsg :: Reader Message a }
  deriving (Monad, Functor, Applicative, MonadReader Message)

type FmtComb = ReaderMsg B.ByteString
type FmtMod = FmtComb -> FmtComb

instance Monoid w => Monoid (ReaderMsg w) where
  mempty = pure mempty
  mappend x y = mappend <$> x <*> y

evalReaderMsg :: Message -> ReaderMsg a -> a
evalReaderMsg msg = flip runReader msg . runReaderMsg

-- read/show extras
mayRead :: Read a => String -> Maybe a
mayRead s = case reads s of
              [(x, "")] -> Just x
              _         -> Nothing

showC ::Show a => a -> B.ByteString
showC = C.pack . show

viaS :: (S.ByteString -> S.ByteString) -> B.ByteString -> B.ByteString
viaS f = C.fromChunks . pure . f . foldr S.append S.empty . C.toChunks

stripS ::S.ByteString -> S.ByteString
stripS = S8.dropWhile isSpace . fst . S8.spanEnd isSpace

stripC ::B.ByteString -> B.ByteString
stripC = viaS stripS

strip ::String -> String
strip = S8.unpack . stripS . S8.pack

split :: Char -> String -> [String]
split c = map S8.unpack . S8.split c . S8.pack

mkF :: (MboxMessage B.ByteString -> a) -> ReaderMsg a
mkF f = asks (f . snd)

mboxMsgSenderF, mboxMsgTimeF, mboxFromF, mboxMsgFileF, mboxMsgOffsetF,
  mboxMsgF, mboxMsgBodyF, messageIDF, subjectF, {-TMP-NO-MIME mimeTypeF,-} emailShown,
  oneLinerF :: FmtComb

mboxMsgTimeF   = mkF _mboxMsgTime
mboxMsgSenderF = mkF _mboxMsgSender
mboxMsgFileF   = mkF $ C.pack . _mboxMsgFile
mboxMsgOffsetF = mkF $ showC . _mboxMsgOffset
mboxMsgF       = mkF $ flip C.snoc '\n' . showMboxMessage
mboxMsgBodyF   = mkF _mboxMsgBody
emailShown     = showC . fst <$> ask
mboxFromF
  = mconcat [pure "From ", mboxMsgSenderF, pure " ", mboxMsgTimeF]
messageIDF
  = C.pack . fromMaybe "<NO-VALID-MESSAGE-ID>"
           . (>>= unquote) . messageId . fst <$> ask
subjectF
  = C.pack . fromMaybe "<NO-VALID-SUBJECT>" . messageSubject . fst <$> ask
{- TMP-NO-MIME
mimeTypeF
  = C.pack . showMIMEType . mimeType . mime_val_type
           . get emailContent . fst <$> ask
-}
oneLinerF
  = mconcat $ intersperse (pure " | ")
       [ align 40 $ ellipse 40 $ subjectF
       , {- TMP-NO-MIME align 15 $ mimeTypeF,-} messageIDF ]

align :: Int -> FmtMod
align n x = B.take (fi n) <$> (x `mappend` pure (C.repeat ' '))

ellipse :: Int -> FmtMod
ellipse n s = (B.take (fi n) <$> s) `mappend` pure "..."

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral

size, md5 :: FmtMod
size = fmap (showC . C.length)
md5  = fmap (showC . MD5.md5)

fmtCombs :: [(String, (FmtComb, String))]
fmtCombs = [ ("one",           (oneLinerF      , "One line per email with: subject, mimetype and message ID (default)"))
           , ("subj",          (subjectF       , "Subject"))
           , ("mboxmsgsender", (mboxMsgSenderF , "Mbox Sender"))
           , ("mboxmsgtime",   (mboxMsgTimeF   , "Mbox Msg Time"))
           , ("mboxmsgfile",   (mboxMsgFileF   , "Mbox Msg File"))
           , ("offset",        (mboxMsgOffsetF , "Mbox Offset"))
           , ("mboxmsg",       (mboxMsgF       , "Mbox Msg"))
           , ("mboxmsgbody",   (mboxMsgBodyF   , "Mbox Msg Body"))
           -- TMP-NO-MIME , ("mimetype",      (mimeTypeF      , "MIME type"))
           , ("fromline",      (mboxFromF      , "Mbox From Line [as 'From %(mboxmsgsender) %(mboxmsgtime)']"))
           , ("mid",           (messageIDF     , "Message ID"))
           ]

fmtMods :: [(String, (FmtMod, String))]
fmtMods = [ ("size",  (size, "Commpute the size of the input"))
          , ("md5",   (md5,  "Hash the input with MD5"))
          , ("strip", (fmap stripC, "Strip leading and trailling spaces"))
          ]

intFmtMods :: [(String, ((Int -> FmtMod), String))]
intFmtMods = [ ("ellipse",  (ellipse, "Truncate at N and put an ellipse"))
             , ("align",    (align,   "Fill upto N with spaces"))
             , ("take",     (fmap . C.take . fi, "Take the N firsts"))
             , ("drop",     (fmap . C.take . fi, "Drop the N firsts"))
             ]

mayEvalStr :: String -> Maybe String
mayEvalStr = mayRead . ('\"' :) . foldr escapeDQuote "\""
  where escapeDQuote '"' = ('\\':).('"':)
        escapeDQuote c   = (c:)

mayReadIntFmtMod :: String -> Maybe FmtMod
mayReadIntFmtMod s = fst <$> lookup s1 intFmtMods <*> mayRead s2
  where (s1, s2) = break isSpace s

mayReadFmtMod :: String -> Maybe FmtMod
mayReadFmtMod s = (fst <$> lookup s fmtMods) `mplus` mayReadIntFmtMod s

mayReadFmtComb :: String -> Maybe FmtComb
mayReadFmtComb s = case reverse (split '.' s) of
  []       -> Nothing
  lst : xs -> do cmb  <- fst <$> lookup lst fmtCombs
                 mods <- mapM (mayReadFmtMod . strip) (reverse xs)
                 return $ foldr (.) id mods cmb

mayReadShowFmts :: String -> Maybe FmtComb
mayReadShowFmts = f
  where f []          = Just mempty
        f ('%':'(':s) = let (s1,s2) = break (==')') s in
                        mappend <$> (mayReadFmtComb s1) <*> f (drop 1 s2)
        f s           = let (s1,s2) = break (=='%') s in
                        mappend <$> (pure . C.pack <$> mayEvalStr s1) <*> f s2

renderFmtComb :: FmtComb -> Message -> B.ByteString
renderFmtComb = flip evalReaderMsg