{-# 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"