{-# LANGUAGE ViewPatterns, RecordWildCards, DataKinds #-}

import System.IO
import System.IO.Error
import System.FilePath
import System.Environment
import System.Exit
import System.Directory
import System.Process
import Text.Printf

import Data.Char

import Control.Monad
import Control.Monad.State

import Control.Exception (bracket_)

import Crypto.Hash

import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS

import qualified Data.UUID as UUID (toString)
import qualified Data.UUID.V4 as UUID (nextRandom)

import Data.Aeson
import Data.Aeson.Encode.Pretty

import Data.Set (Set)
import qualified Data.Set as Set


import FoxReplace


data SubscriberIdent = SubscriberIdent
  { siList, siIdent, siEmail :: String
  } deriving (Ord, Eq, Show)

hashIdent :: SubscriberIdent -> String
hashIdent SubscriberIdent{..} = map toLower . show $ digest
  where
    digest :: Digest (SHAKE128 128)
    digest = hashFinalize . flip execState hashInit $ do
      let hashUpdate' = modify . flip hashUpdate . CBS.pack
      hashUpdate' siList
      hashUpdate' siIdent
      hashUpdate' siEmail

identEmail :: Bool {- ^ RegEx? -}
           -> SubscriberIdent
           -> String
identEmail False si@SubscriberIdent{..} = siList ++ "+" ++ hashIdent si ++ "@subs.lists.yggdrasil.li"
identEmail True si@SubscriberIdent{..} = siList ++ "\\+" ++ hashIdent si ++ "(@subs\\.lists\\.yggdrasil\\.li)?"


main :: IO ()
main = do
  progName <- takeFileName <$> getProgName
  case progName of
    "mlmmj-exposed" -> do
      args <- getArgs
      case args of
        [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)), (map toLower -> extension)] -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          subscribers <- getSubscribers
          let hashes = filter ((==) extension . snd) [((siIdent, siEmail), hashIdent SubscriberIdent{..}) | siIdent <- identities, siEmail <- subscribers ]
          case hashes of
            [((siIdent, siEmail), _)] -> do
              uuid <- UUID.nextRandom
              let fName = "queue" </> "exposed" <.> uuidTrans uuid
                  uuidTrans = uuidTrans' . UUID.toString
                    where
                      uuidTrans' []       = []
                      uuidTrans' ('-':xs) =       uuidTrans' xs
                      uuidTrans' (x:xs)   =   x : uuidTrans' xs
                  writeQueueFile = getContents >>= writeFile fName
                  removeQueueFile = removeFile fName
              hPrintf stdout "Forwarding mail for %s to <%s>, subscribed to %s\n" siIdent siEmail siList
              bracket_ writeQueueFile removeQueueFile $
                callProcess "@mlmmj@/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", fName, "-T", siEmail]
            [] -> die "Unknown extension"
            _  -> die "Ambiguous extension"
        _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2)
    "mlmmj-expose" -> do
      args <- getArgs
      case args of
        [listDir, (map toLower -> ident)] -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          case ident `elem` identities of
            True  -> putStrLn "Identity is already known"
            False -> writeFile "exposed.ids" . unlines $ ident : identities
        _     -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
    "mlmmj-get-exposed" -> do
      args <- getArgs
      case args of
        [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)), (map toLower -> siIdent)] -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          unless (siIdent `elem` identities) . die $ "Unknown sender: ‘" ++ siIdent ++ "’"
          mapM_ (\siEmail -> putStrLn $ siEmail ++ " " ++ identEmail False SubscriberIdent{..}) =<< getSubscribers
        (dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)) : (map toLower -> siIdent) : (map (map toLower) -> recipients) -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          unless (siIdent `elem` identities) . die $ "Unknown sender: ‘" ++ siIdent ++ "’"
          subscribers <- getSubscribers
          forM_ recipients $ \siEmail -> do
            unless (siEmail `elem` subscribers) . die $ "Unknown recipient: ‘" ++ siEmail ++ "’"
            putStrLn $ identEmail False SubscriberIdent{..}
        _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
    "mlmmj-serve-exposed" -> do
      args <- getArgs
      case args of
        [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList))] -> do
          setCurrentDirectory listDir
          subscribers <- getSubscribers
          identities <- getIdentities

          let
            replaceGroup siIdent = FoxReplaceGroup { groupName = siIdent ++ "." ++ siList
                                                   , groupHtmlMode = NoHTML
                                                   , groupUrls = Set.empty
                                                   , groupSubs = Set.fromList $ map (replaceSub siIdent) subscribers
                                                   }
            replaceSub siIdent siEmail = FoxReplaceSub { rInput = identEmail True SubscriberIdent{..}
                                                       , rOutput = siEmail
                                                       , rInputType = RegexpInput
                                                       , rCaseSensitive = False
                                                       }

          LBS.putStr . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
          putChar '\n'
        _ -> hPutStrLn stderr "Called without expected arguments (<listDirectory>)" >> exitWith (ExitFailure 2)
    _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)


getIdentities :: IO [String]
getIdentities = (filter (not . null) . lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)

getSubscribers :: IO [String]
getSubscribers = map (map toLower) . concat <$> mapM (flip catchIOError (\e -> if isDoesNotExistError e then return [] else ioError e) . readDir) ["subscribers.d", "digesters.d"]
  where
    readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir))