{-# LANGUAGE
     LambdaCase
   , OverloadedStrings
   , ViewPatterns
   #-}

import Control.Monad
import Control.Concurrent.Thread.Delay (delay)
import Data.Attoparsec.ByteString (parseOnly)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as L
import Data.Maybe
import qualified Data.Set as Set
import Data.Time
import Data.Time.LocalTime
-- import Network.Curl
import System.Directory
import System.Environment
import System.Exit
import System.FilePath (takeFileName, takeExtension)
import System.Process
import Text.Printf (printf)
import Text.Read

import MMS
import ReadMessages
import Settings

main :: IO ()
main = do
   homePath <- getHomeDirectory
   canSend <- doesFileExist (homePath++"/"++mmsSenderLoc) >>= \case
      True -> pure CanSend
      False -> pure CantSend
   mainWSend canSend

mainWSend :: CanSend -> IO ()
mainWSend canSend = getArgs >>= \case
   [] -> do
      putStrLn "jmms"
      printHowManyStubborn
      putStrLn $ "Possible args: "++possibleArgs
   ["--get"] -> main'
   ["--rm", list] -> do
      let ls :: [String]
          ls = case readMaybe list of
             Just x -> x
             Nothing -> error $ "Couldn't read as list of strings: "++show list
      removeMessages ls
   ["--rm-oldest-stubborn"] ->
      removeOldestStubbornSMS
   ["--read"] -> readUnreadMessages canSend
   ["--poll", numMinutesStr] ->
      case readMaybe numMinutesStr of
         Nothing -> error $ "Could not read number of minutes: "++show numMinutesStr
         Just numMinutes -> forever $ do
            getMessages
            z <- (localTimeOfDay . zonedTimeToLocalTime) <$> getZonedTime
            putStrLn $ (printf "%0.2d:%0.2d" (todHour z) (todMin z))++ ": Waiting "++show numMinutes++" minutes..."
            delay (numMinutes * 60 * (10^(6::Int)))
   ["--thread"] -> readThreads canSend
   ["--alert-if-n-stuck", ns] ->
      case readMaybe ns of
         Nothing -> error $ "Could not read number of stuck messages: "++show ns
         Just n -> alertIfNStuckMessages n
   args -> error $ "not understood: " ++ show args++"; should be "++possibleArgs

possibleArgs :: String
possibleArgs = "(|--get | --read | --poll [num minutes] | --rm [msg ids] | --rm-oldest-stubborn | --thread | --alert-if-n-stuck [n])"

-- arg could be list of ints instead of strings:
removeMessages :: [String] -> IO ()
removeMessages ls = do
   withModemNum $ \modemNum ->
      forM_ ls $ \x -> do
         putStrLn $ "Removing: "++show x
         readProcessWithExitCode "mmcli" ["-m", modemNum, "--messaging-delete-sms="++x] "" >>= \case
            (ExitSuccess, o, e) -> do
               print (o, e)
            e -> do
               print e
               notificationAction $ "jmms: error removing sms"
         pure ()

-- Assumption is that "0" is older than "1", etc.:
removeOldestStubbornSMS :: IO ()
removeOldestStubbornSMS = do
   withModemNum $ \modemNum -> do
      getReceivingSMSes modemNum >>= \case
         Nothing -> putStrLn "Can't get stubborn"
         Just smsNums ->
            case L.sortOn (read::String->Int) smsNums of
                  [] -> putStrLn "No stubborn SMSes!"
                  (oldestMessageNum:_) -> do
                     nowStr <- getNowString
                     let fName = smsPathFromNowStr nowStr oldestMessageNum
                     putStrLn $ "Attempting to save SMS as "++show fName++"..."
                     print =<< getSMSByNum modemNum oldestMessageNum fName
                     removeMessages [oldestMessageNum]
                     getNumStubbornSMS modemNum >>= \case
                        Nothing -> putStrLn "Can't list further stubborn"
                        Just numStubborn -> putStrLn $
                           show numStubborn ++ " more stubborn messages exist"

alertIfNStuckMessages :: Int -> IO ()
alertIfNStuckMessages n = do
   withModemNum $ \modemNum -> do
      getReceivingSMSes modemNum >>= \case
         Nothing -> putStrLn "Can't get stubborn"
         Just smsNums ->
            let numStubborn = ((length::[String]->Int) smsNums)
            in case compare numStubborn n of
                  LT -> pure ()
                  _ -> notificationAction $ show numStubborn ++ " stubborn SMSes"

getReceivingSMSes :: String -> IO (Maybe [String])
getReceivingSMSes modemNum = do
      messageLinesFromModemNum modemNum >>= \case
         Nothing -> pure Nothing
         Just messageLines ->
            let smsNums = map parseModemNum $ filter isReceiving messageLines
            in pure $ Just smsNums

printHowManyStubborn :: IO ()
printHowManyStubborn =
   withModemNum $ \modemNum -> do
      getNumStubbornSMS modemNum >>= \case
         Nothing -> putStrLn "Can't get stubborn messages"
         Just numStubborn -> do
            putStrLn $ show numStubborn ++ " stubborn SMSes"
            when (numStubborn > 0) $
               putStrLn "(Remove with --rm-oldest-stubborn)"

getNumStubbornSMS :: String -> IO (Maybe Int)
getNumStubbornSMS modemNum = do
      getReceivingSMSes modemNum >>= \case
         Nothing -> pure Nothing
         Just stubborn -> do
            pure $ Just $ (length::[String]->Int) stubborn

main' :: IO ()
main' = do
   createDirectoryIfMissing True smsDir
   createDirectoryIfMissing True mmsDir
   doesDirectoryExist (msgDataDir++"/.git") >>= \case
      True -> pure ()
      False -> do
         putStrLn "git init"
         ExitSuccess <- system $ "cd "++msgDataDir++" && git init"
         pure ()

   doesDirectoryExist (msgDataDir++"/.git/annex") >>= \case
      True -> pure ()
      False -> do
         putStrLn "git annex init"
         ExitSuccess <- system $ "cd "++msgDataDir++" && git annex init" -- this'll error if git annex isn't installed
         pure ()

{-
   x <- listDirectory "."
   forM_ (x L.\\ [".git"]) $ \y -> do
      c <- BS.readFile y
      print c
      print $ BS.length c
      print $ dropNullOnEnd $ dropTillHTTP c
-}
   getMessages

messageLinesFromModemNum :: String -> IO (Maybe [String])
messageLinesFromModemNum modemNum = do
   -- putStrLn $ "Modem #: "++show modemNum
   putStrLn ""
   readProcessWithExitCode "mmcli" ["-m", modemNum, "--messaging-list-sms"] "" >>= \case
      -- TODO: print _err:
      (ExitSuccess, lines -> messageLines, _err) -> do
         pure (Just messageLines)
      e -> do
         putStrLn $ "Couldn't get sms list: "++show e
         pure Nothing

isReceiving :: String -> Bool
isReceiving = (" (receiving)"  `L.isSuffixOf`)

getMessages :: IO ()
getMessages =  withModemNum $ \modemNum ->
   messageLinesFromModemNum modemNum >>= \case
      Nothing -> pure ()
      Just messageLines -> do
         -- TODO: dedupe this whole thing - or maybe use StateT:
         let (receiving, notReceiving) = L.partition isReceiving messageLines
         case receiving of
            [] -> pure ()
            _ -> putStrLn $ show (len receiving) ++ " messages in \"receiving\" state"
         let (sending, notReceivingOrSending) = L.partition (" (sending)"  `L.isSuffixOf`) notReceiving
         case sending of
            [] -> pure ()
            _ -> putStrLn $ show (len sending) ++ " messages in \"sending\" state"
         let (sent, notReceivingOrSendingOrSent) = L.partition (" (sent)" `L.isSuffixOf`) notReceivingOrSending
         case sent of
            [] -> pure ()
            _ -> putStrLn $ show (len sent) ++ " messages in \"sent\" state"
         let (unknown, notReceivingOrSendingOrSentOrUnknown) = L.partition (" (unknown)" `L.isSuffixOf`) notReceivingOrSendingOrSent
         case unknown of
            [] -> pure ()
            _ -> putStrLn $ show (len unknown) ++ " messages in \"unknown\" state"
         let (receivedLines, unrecognized) = L.partition (" (received)"  `L.isSuffixOf`) notReceivingOrSendingOrSentOrUnknown
         case filter (`notElem` ["No sms messages were found"]) unrecognized of
            [] -> pure ()
            _ -> putStrLn $ "Unrecognized lines: "++show unrecognized
         case receivedLines of
            [] -> do
               _ <- getMmMessages
               -- gitAnnexAddMMS
               putStrLn "No new messages received (or mmsd got 'em)"
            _ -> do
               putStrLn $ show (len receivedLines) ++ " messages in \"received\" state - fetching..."
               _ <- getMmMessages -- Do this before 'getMessageNums' because that step `git-annex-save`s
               getMessageNums modemNum $ map parseModemNum receivedLines

-- Monomorphic:
len :: [x] -> Int
len = length

tryToFetchMMS :: FilePath -> IO (Maybe FilePath)
tryToFetchMMS fPath = do
      doesFileExist fPath >>= \case
         True -> do
            contents <- BS.readFile fPath
            case getURL contents of
               Left e -> do
                  putStrLn $ "Can't get URL: "<>show contents
                  putStrLn e
                  pure Nothing
               Right url -> fetchMMSFromURL url
         False -> pure Nothing

fetchMMSFromURL :: BS.ByteString -> IO (Maybe FilePath)
fetchMMSFromURL url = do
   --       _ <- system $ "cat mms-"++nowStr++"*.txt"
            -- _ <- Curl.initialize
            -- We download MMS with curl so we can use the --interface=wwan0 option:
-- Switch back to curl when we can get a stable "wwan0"-type name:
{-
            withCurlDo $ do
               rsp <- curlGetResponse_ (BS8.unpack url) [CurlInterface "wwan0"]
               case rsp :: CurlResponse_ [(String, String)] BSL.ByteString of
                  CurlResponse { respCurlCode = CurlOK, respStatus = 200 } -> do
                     BSL.writeFile (mmsDir++"/"++nowStr++"-"++messageNum++".dat") $ respBody rsp
                     pure (Just messageNum)
                  _ -> do
                     putStrLn $ "Could not get message "++show messageNum++":"
                     print (respCurlCode rsp, respStatus rsp, respStatusLine rsp, respHeaders rsp, respBody rsp)
                     pure Nothing
-}
            wgetResult <- readCreateProcessWithExitCode
               (shell $ "cd "++mmsDir++" && wget "++BS8.unpack url)
               ""
            print wgetResult
            case wgetResult of
               (ExitSuccess, wgetStdOut, wgetStdErr)
                  |    ("HTTP request sent, awaiting response... 200 OK" `L.isInfixOf` wgetStdOut)
                    || ("HTTP request sent, awaiting response... 200 OK" `L.isInfixOf` wgetStdErr) ->
                     pure (Just (takeFileName $ BS8.unpack url))
               _ -> pure Nothing

-- | This used to read SMS files in the .mms/modemmanager directory. Now it lets
--     mmsd do it and copies over the ones that are well-formed MMS messages
getMmMessages :: IO [FilePath]
getMmMessages = do
   -- Annoying workaround for the ~/.mms/modemmanager dir:
   mmMMSDir <- (++"/.mms/modemmanager") <$> getHomeDirectory -- TODO: could be in Settings.hs?

-- No longer fetching; we led mmsd do that (because it won't not):
{-
   let fetchedFile = msgDataDir++"/fetched-mm-mms.txt"
   fetchedMmMms <- doesFileExist fetchedFile >>= \case
      False -> pure []
      True -> (filter (/="") . lines) <$> readFile fetchedFile
-}

   -- Including old ones:
   -- Note only relative paths:
   mmSmsFiles <- doesDirectoryExist mmMMSDir >>= \case
      False -> pure []
      -- TODO: there could end up being other files in this directory, with different extensions:
      True -> filter (\f -> (takeExtension f/=".status") && (f /= "mms")) <$> listDirectory mmMMSDir

   newMessageSuccesses <- (catMaybes <$>) $
      forM mmSmsFiles $ \mmFile -> do
         let oldLocation = (mmMMSDir++"/"++mmFile)
             newLocation = (mmsDir++"/"++mmFile)
         doesFileExist newLocation >>= \case
            True -> pure Nothing
            False -> do
               (parseOnly parseMMS <$> BS.readFile oldLocation) >>= \case
                  Left e -> do
                     putStrLn $ "Unable to parse: "++show (mmFile, e)
                     pure Nothing
                  Right _ -> do
                     copyFile oldLocation newLocation
                     pure $ Just mmFile
      -- unable to parse

{-
   forM_ mmSmsFiles $ \f -> do
      c <- BS.readFile (mmMMSDir++"/"++f)
      print $ getURL c

   -- error $ show mmSmsFiles

   let newMmMessages = mmSmsFiles L.\\ fetchedMmMms

   newMessageSuccesses <- (catMaybes <$>) $ (`mapM` newMmMessages) $ \newMmMessage -> do
      r <- tryToFetchMMS (mmMMSDir++"/"++newMmMessage)
      case r of
         Just _ -> do
            putStrLn $ "Got msg: "++show newMmMessage
            appendFile fetchedFile ("\n"++newMmMessage)
         Nothing -> do
            putStrLn $ "Couldn't get msg: "++show newMmMessage
      pure r
   case newMessageSuccesses of
      [] -> pure ()
      _ -> do
         ExitSuccess <- system $ "cd "++msgDataDir++" && git add "++fetchedFile++" && git commit -m auto "
         pure ()
-}

   pure newMessageSuccesses
   -- TODO: print mm-mms failures and successes
   -- case newMessages L.\\ newMessageSucc

gitAnnexAddMMS :: IO ()
gitAnnexAddMMS = do
   (system $ "cd "++msgDataDir++" && git annex add mms sms && git commit -m autosave") >>= \case
      ExitSuccess -> pure ()
      e -> notificationAction $ "jmms: unable to save: "++show e

getNowString :: IO String
getNowString =
   (filter (`elem`['0'..'9']) . show) <$> getCurrentTime

-- TODO: newtypes:
getSMSByNum :: String -> String -> FilePath -> IO (ExitCode, String, String)
getSMSByNum modemNum messageNum fPath = do
   readProcessWithExitCode "mmcli" ["-m", modemNum, "-s", messageNum, "--create-file-with-data="++fPath] ""

smsPathFromNowStr :: String -> String -> FilePath
smsPathFromNowStr nowStr messageNum =
   smsDir++"/sms-"++nowStr++"-"++messageNum++".dat"

getMessageNums :: String -> [String] -> IO ()
getMessageNums modemNum messageNums = do
   putStrLn $ "Attempting to get message numbers: "++show messageNums
   nowStr <- getNowString
   msgSuccesses <- (catMaybes <$>) $ forM messageNums $ \messageNum -> do
      let fPath = smsPathFromNowStr nowStr messageNum
      -- This will fail if it's a regular SMS - i.e. it's a text message not a binary MMS info message
      print =<< getSMSByNum modemNum messageNum fPath
      r <- tryToFetchMMS fPath
      pure $ (\x-> (messageNum,x)) <$> r

   gitAnnexAddMMS
   putStrLn $ "attempted to get: "++show messageNums
   putStrLn $ "successes: "++show (map fst msgSuccesses)
   case msgSuccesses of
      [] -> pure ()
      _ -> printMessageSuccesses $ map snd msgSuccesses
   case messageNums L.\\ map fst msgSuccesses of
      [] -> pure ()
      failures -> notificationAction $ "jmms: "++show (length failures)++" messages not received"


   -- This seems to be safe to do automatically
   removeMessages $ map fst msgSuccesses
   pure ()




printMessageSuccesses :: [FilePath] -> IO ()
printMessageSuccesses msgSuccesses = do
   fromVals <- forM (map (\p -> mmsDir++"/"++p) msgSuccesses) $ \f -> do
      doesFileExist f >>= \case
         False -> do
            notificationAction $ "jmms: missing file: "++show f
            pure Nothing
         True -> do
            (parseOnly parseAllMMSHeaders <$> BS.readFile f) >>= \case
               Left e -> do
                  notificationAction $ "Can't parse: "++show e
                  pure Nothing
               Right allHeaders ->
                  case [ from | (MMSH_From from) <- allHeaders ] of
                     [] -> do
                        notificationAction $ "jmms: no 'from': "++show f
                        pure Nothing
                     [from] -> do
                        pure (Just $ idContacts $ unPlmn $ fromValueString from)
                     _ -> do
                        notificationAction $ "jmms: multiple 'from': "++show f
                        pure Nothing

   -- notificationAction $ "jmms: "++show (length msgSuccesses)++" new messages"
   let counts :: [(BS.ByteString, Int)]
       counts = map (\l@(x:_) -> (x, (length::[x]->Int) l)) $
          (L.group $ L.sort $ catMaybes fromVals :: [[BS.ByteString]])
   forM_ counts $ \(addr, count) -> do
      notificationAction $ "jmms: "++show count++" msgs from "++BS8.unpack (idContacts addr)

parseModemNum :: String -> String
parseModemNum s =
   reverse $
      takeWhile (/='/') $
      reverse $
      takeWhile (/=' ') $
      dropWhile (==' ') $
      s

-- /org/freedesktop/ModemManager1/Modem/1

-- Janky - we should parse these instead:
dropTillHTTP :: BS.ByteString -> Either String BS.ByteString
dropTillHTTP b = dth' $ BS.unpack b
 where
   dth' = \case
      (104:116:116:112: {- 'h':'t':'t':'p': -} rest) -> Right $ "http"<>BS.pack rest
      (_x:xs) -> dth' xs
      [] -> Left "end of input"

dropNullOnEnd :: BS.ByteString -> Either String BS.ByteString
dropNullOnEnd b = BS.pack <$> case reverse $ BS.unpack b of
   (0 : rest) -> Right $ reverse rest
   [] -> Right [] -- TODO: note empty
   (128 : 134 : 0 : rest) -> Right $ reverse rest -- super janky hack. I do not know why this is needed!
   _ -> Left $ "no null:"++ show b

getURL :: BS8.ByteString -> Either String BS8.ByteString
getURL = dropNullOnEnd <=< dropTillHTTP

withModemNum :: (String -> IO ()) -> IO ()
withModemNum action = do
   readProcessWithExitCode "mmcli" ["-L"] "" >>= \case
      (ExitSuccess, dashL, _stderr) -> do
         let modemNum = parseModemNum dashL
         action modemNum
      e -> do
         notificationAction $ "jmms: error getting modem num"
         putStrLn "Error getting modem num:"
         print e