Better mlmmj-expose

2 files changed, 210 insertions, 0 deletions

diff --git a/ymir/mlmmj-expose/FoxReplace.hs b/ymir/mlmmj-expose/FoxReplace.hs
new file mode 100644
index 00000000..ca28fa43
--- /dev/null
+++ b/ymir/mlmmj-expose/FoxReplace.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
+
+module FoxReplace where
+
+import Data.Aeson
+
+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"
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))