mlmmj-serve-exposed

1 files changed, 180 insertions, 0 deletions

diff --git a/ymir/mlmmj-expose.hs b/ymir/mlmmj-expose.hs
new file mode 100644
index 00000000..faf4e3b6
--- /dev/null
+++ b/ymir/mlmmj-expose.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE ViewPatterns, RecordWildCards #-}
+
+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)
+
+data FoxReplaceGroup = FoxReplaceGroup
+                       { groupName :: String
+                       , groupUrls :: Set String
+                       , groupSubs :: Set FoxReplaceSub
+                       , groupHtmlMode  :: FoxReplaceHTML
+                       }
+  deriving (Ord, Eq)
+
+data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
+  deriving (Ord, Eq, Enum)
+
+data FoxReplaceSub = FoxReplaceSub
+                     { rInput, rOutput :: String
+                     , rInputType :: SubInput
+                     , rCaseSensitive :: Bool
+                     }
+  deriving (Ord, Eq)
+
+data SubInput = TextInput | WordInput | RegexpInput
+  deriving (Ord, Eq, Enum)
+
+
+instance ToJSON FoxReplace where
+  toJSON (FoxReplace groupSet) = object
+                                 [ "version" .= "0.15"
+                                 , "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
+          subscribers <- getSubscribers
+          identities <- getIdentities
+
+          let
+            listName = takeBaseName listDir
+            replaceGroup ident = FoxReplaceGroup { groupName = ident ++ "." ++ listName
+                                                 , groupHtmlMode = False
+                                                 , groupUrls = Set.empty
+                                                 , groupSubs = Set.fromList $ map (replaceSub ident) subscribers
+                                                 }
+            replaceSub ident sub = FoxReplaceSub { rInput = hash' (ident, sub)
+                                                 , rOutput = sub
+                                                 , rInputType = WordInput
+                                                 , rCaseSensitive = True
+                                                 }
+
+          CLBS.putStrLn . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
+        _ -> 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