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.hs | 182 --------------------------------------------------- 1 file changed, 182 deletions(-) delete mode 100644 ymir/mlmmj-expose.hs (limited to 'ymir/mlmmj-expose.hs') diff --git a/ymir/mlmmj-expose.hs b/ymir/mlmmj-expose.hs deleted file mode 100644 index f074659b..00000000 --- a/ymir/mlmmj-expose.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# 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 "@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), (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 ( [ [...]])") >> 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 ()" >> 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 -- cgit v1.2.3