From e28b7def6cb2e4542c5fcbfc478dde85cd73ea3f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 Sep 2018 17:29:54 +0200 Subject: Better mlmmj-expose --- ymir/mlmmj-expose/FoxReplace.hs | 67 ++++++++++++++++++ ymir/mlmmj-expose/mlmmj-expose.hs | 143 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 210 insertions(+) create mode 100644 ymir/mlmmj-expose/FoxReplace.hs create mode 100644 ymir/mlmmj-expose/mlmmj-expose.hs (limited to 'ymir/mlmmj-expose') 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 ( )") >> 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 ( )") >> 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 ( [ [...]])") >> 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 ()" >> 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)) -- cgit v1.2.3