1 files changed, 143 insertions, 0 deletions

diff --git a/ymir/mlmmj-expose/mlmmj-expose.hs b/ymir/mlmmj-expose/mlmmj-expose.hs
new file mode 100644
index 00000000..a7b9ec48
--- /dev/null
+++ b/ymir/mlmmj-expose/mlmmj-expose.hs
@@ -0,0 +1,143 @@
+{-# 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 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
+            [((_, 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 "@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@(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))