{-# LANGUAGE OverloadedStrings #-}
import System.Environment
import HSH
import Control.Monad
import Control.Applicative
import Control.Arrow
import Data.Char
-- import Data.Time.Clock
-- import Data.Time.Calendar
import Data.Either
import Data.List
import Data.List.Split (chunk)
import Data.Monoid
import qualified Data.ByteString.Char8 as C
import Data.ByteString (ByteString)
import System.Cmd
import System.IO
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
type Folder = ByteString
type MsgLabel = ByteString
type MsgID = ByteString
data Msg = MsgPath FilePath
| MsgInFolder Folder Int
| MsgByID MsgID
data Labeling a = Label a
| Unlabel a
type MsgLabeling = Labeling MsgLabel
parseLabeling :: String -> Either String (Labeling ByteString)
parseLabeling ('+':lbl) = Right . Label . C.pack $ lbl
parseLabeling ('-':lbl) = Right . Unlabel . C.pack $ lbl
parseLabeling s = Left s
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
[(x, s')] | all isSpace s' -> Just x
_ -> Nothing
parseMsg :: String -> Either String Msg
parseMsg ('<':s) = fmap MsgByID . dropEndThis '>' . C.pack $ s
parseMsg ('@':s) = MsgInFolder (C.pack ('+':folder)) <$> maybe err return (maybeRead ix)
where (folder,ix) = cutOn '/' s
err = Left $ "parseMsg: cannot parse message spec: @" ++ s
parseMsg s = return (MsgPath s)
folderFromMsgLabel :: MsgLabel -> Folder
folderFromMsgLabel = C.cons '+'
cutOnC :: Char -> ByteString -> (ByteString, ByteString)
cutOnC c = second (C.drop 1) . C.break (==c)
cutOn :: Eq a => a -> [a] -> ([a], [a])
cutOn c = second (drop 1) . break (==c)
dropEndThis :: Char -> ByteString -> Either String ByteString
dropEndThis c s | C.last s == c = Right $ C.init s
| otherwise = Left $ unwords [ "dropEndThis: unexpected"
, show (C.last s) ++ ","
, show c, "was expected" ]
-- dropIt :: Eq a => a -> [a] -> Maybe [a]
-- dropIt x (y:ys) | x == y = Just ys
-- dropIt _ _ = Nothing
pathFromMsgID :: FilePath -> MsgID -> IO (Either String FilePath)
pathFromMsgID message_ids msgID
= maybe (Left err) (return . C.unpack . snd) . find ((==msgID') . fst) . map (cutOnC ' ') . C.lines
<$> C.readFile message_ids
where
err = C.unpack msgID ++ " not found"
msgID' = '<' `C.cons` msgID `C.snoc` '>'
pathFromMsg :: FilePath -> Msg -> IO (Either String FilePath)
pathFromMsg _ (MsgPath path) = return . return $ path
pathFromMsg e (MsgByID mID) = pathFromMsgID e mID
pathFromMsg _ (MsgInFolder folder ix) = return <$> runSL ("mhpath" :: String, [C.unpack folder, show ix])
-- mv :: Folder -> Folder -> [Int] -> IO ()
-- mv src dst msgs = run ("refile", msgs ++ [dst, "-nolink", "-src", src])
cp :: [Msg] -> [Folder] -> IO ()
cp msgs dsts | null msgs || null dsts = return ()
cp msgs dsts = do
message_ids <- getEnv "NMH_MESSAGE_IDS"
(errs, pathss) <- second (chunk 1000) . partitionEithers <$> mapM (pathFromMsg message_ids) msgs
forM_ pathss $ \paths ->
-- runIO ("refile", "-link" : (concatMap (("-file":) . pure) paths ++ dsts))
rawSystem "refile" ("-link" : (concatMap (("-file":) . pure) paths ++ map C.unpack dsts))
when (not . null $ errs) $ hPutStr stderr $ unlines errs
-- rm :: [Msg] -> [Folder] -> IO ()
-- rm msgs = do
-- msgsargs <- concat <$> mapM cmdSpecFromMsg msgs
-- run ("rmm", "-unlink" : (msgsargs ++ dsts))
-- archive :: ArchiveFolder -> [Msg] -> IO ()
-- archive archiveFolder = mv "+inbox" archiveFolder
-- unarchive :: ArchiveFolder -> [Msg] -> IO ()
-- unarchive archiveFolder = mv archiveFolder "+inbox"
addLabels :: [MsgLabel] -> [Msg] -> IO ()
addLabels lbls msgs = cp msgs (map folderFromMsgLabel lbls)
remLabels :: [MsgLabel] -> [Msg] -> IO ()
remLabels _lbls _msgs = fail "remLabels: not yet implemented"
label :: [MsgLabeling] -> [Msg] -> IO ()
label labels msgs = sequence_ [ labelOne lbl msgs | lbl <- labels ]
where
labelOne (Label lbl) = addLabels [lbl]
labelOne (Unlabel lbl) = remLabels [lbl]
applyLabelMap :: [(MsgID, [MsgLabel])] -> IO ()
applyLabelMap lblMap =
sequence_
[ addLabels lbls [MsgByID msgID]
| (msgID, lbls) <- lblMap ]
applyLabelMapForMIDs :: [(MsgID, [MsgLabel])] -> [MsgID] -> IO ()
applyLabelMapForMIDs lmap mids =
sequence_
[ maybe (err msgID) (flip addLabels [MsgByID msgID]) lbls
| msgID <- mids
, let lbls = lookup msgID lmap
]
where err msgID = C.hPutStrLn stderr $ "not found: " <> msgID
parseEntries :: ByteString -> [(MsgID,[MsgLabel])]
parseEntries = map (second (C.words . C.takeWhile (/=')') . C.dropWhile (=='(') . C.tail)
. C.break (==' ')) . C.lines
-- if "+inbox" `elem` labelsToAdd
-- then unarchive archiveFolder msgs
-- else if "-inbox" `elem` labelsToRem
-- then archive archiveFolder msgs
-- else fail "Error: both -inbox and +inbox on the command line"
-- cp archiveFolder (delete "+inbox" labelsToAdd)
-- refile ["-nolink"] (delete "-inbox" labelsToRem)
-- where (labelsToAdd, labelsToRem) = partition isAddLabel labels
-- refile _ [] = return ()
-- refile options lbls =
-- run $ ("refile", msgs ++ ["-src", archiveFolder] ++ options ++ map folderFromMsgLabel lbls)
-- -src is excluded on purpose
-- validOptions :: [Option]
-- validOptions = words "draft link nolink preserve nopreserve unlink nounlink file rmmproc normmproc version help"
main :: IO ()
main = do (options, args) <- partition ("--" `isPrefixOf`) <$> getArgs
case (sort options, args) of
(["--lmap"], []) -> applyLabelMap . parseEntries =<< C.getContents
(["--mids"], [lmapf]) -> do lmap <- parseEntries <$> C.readFile lmapf
applyLabelMapForMIDs lmap . C.lines =<< C.getContents
([], _) ->
let (msgs, lbls) = partitionEithers $ map parseLabeling args in
label lbls =<< either fail return (mapM parseMsg msgs)
-- (year, _, _) <- (toGregorian . utctDay) `fmap` getCurrentTime
-- let archiveFolder = "+archive-"++show year
-- (labels, msgs) = partition isLabel args
-- label archiveFolder labels msgs
(_, _) -> fail "Bad arguments"