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

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 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

newtype FoxReplace = FoxReplace (Set FoxReplaceGroup)
  deriving (Ord, Eq, Show)

data FoxReplaceGroup = FoxReplaceGroup
                       { groupName :: String
                       , groupUrls :: Set String
                       , groupSubs :: Set FoxReplaceSub
                       , groupHtmlMode  :: FoxReplaceHTML
                       }
  deriving (Ord, Eq, Show)

data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
  deriving (Ord, Eq, Enum, Show)

data FoxReplaceSub = FoxReplaceSub
                     { rInput, rOutput :: String
                     , rInputType :: SubInput
                     , rCaseSensitive :: Bool
                     }
  deriving (Ord, Eq, Show)

data SubInput = TextInput | WordInput | RegexpInput
  deriving (Ord, Eq, Enum, Show)


instance ToJSON FoxReplace where
  toJSON (FoxReplace groupSet) = object
                                 [ "version" .= ("0.15" :: String)
                                 , "groups" .= groupSet
                                 ]

instance ToJSON FoxReplaceGroup where
  toJSON FoxReplaceGroup{..} = object
                               [ "name" .= groupName
                               , "html" .= groupHtmlMode
                               , "enabled" .= True
                               , "urls" .= groupUrls
                               , "substitutions" .= groupSubs
                               ]

instance ToJSON FoxReplaceHTML where
  toJSON NoHTML         = String "none"
  toJSON OutputOnlyHTML = String "output"
  toJSON BothHTML       = String "inputoutput"

instance ToJSON FoxReplaceSub where
  toJSON FoxReplaceSub{..} = object
                             [ "input" .= rInput
                             , "output" .= rOutput
                             , "inputType" .= rInputType
                             , "caseSensitive" .= rCaseSensitive
                             ]

instance ToJSON SubInput where
  toJSON TextInput   = String "text"
  toJSON WordInput   = String "wholewords"
  toJSON RegexpInput = String "regexp"


main :: IO ()
main = do
  progName <- takeFileName <$> getProgName
  case progName of
    "mlmmj-exposed" -> do
      args <- getArgs
      case args of
        [listDir, (map toLower -> extension)] -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          subscribers <- getSubscribers
          let hashes = filter ((==) extension . snd) [((ident, sub), hash' (ident, sub)) | ident <- identities, sub <- subscribers]
          case hashes of
            [((_, recipient), _)] -> 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
              getContents >>= writeFile fName
              hPrintf stdout "Forwarding mail to <%s>, subscribed to %s\n" recipient (takeBaseName listDir)
              callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", fName, "-T", recipient]
              removeFile fName
            [] -> 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), (map toLower -> ident)] -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
          mapM_ (\sub -> putStrLn $ sub ++ " " ++ takeFileName listDir ++ "+" ++ hash' (ident, sub) ++ "@subs.lists.yggdrasil.li") =<< getSubscribers
        (dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do
          setCurrentDirectory listDir
          identities <- getIdentities
          unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
          subscribers <- getSubscribers
          forM_ recipients $ \recipient -> do
            unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’";
            putStrLn $ takeFileName listDir ++ "+" ++ hash' (ident, recipient) ++ "@subs.lists.yggdrasil.li";
        _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
    "mlmmj-serve-exposed" -> do
      args <- getArgs
      case args of
        [(dropTrailingPathSeparator -> listDir)] -> do
          setCurrentDirectory listDir
          subscribers <- getSubscribers
          identities <- getIdentities

          let
            listName = takeBaseName listDir
            replaceGroup ident = FoxReplaceGroup { groupName = ident ++ "." ++ listName
                                                 , groupHtmlMode = NoHTML
                                                 , groupUrls = Set.empty
                                                 , groupSubs = Set.fromList $ map (replaceSub ident) subscribers
                                                 }
            replaceSub ident sub = FoxReplaceSub { rInput = listName ++ "\\+" ++ hash' (ident, sub) ++ "(@subs\\.lists\\.yggdrasil\\.li)?"
                                                 , rOutput = sub
                                                 , rInputType = RegexpInput
                                                 , rCaseSensitive = True
                                                 }

          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))

hash' :: Show a => a -> String
hash' = take len . map toLower . show . (hash :: CBS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show

len :: Int
len = 32