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 -------------------------------------- ymir/mlmmj-expose.nix | 25 +++--- ymir/mlmmj-expose/FoxReplace.hs | 67 ++++++++++++++ ymir/mlmmj-expose/mlmmj-expose.hs | 143 ++++++++++++++++++++++++++++++ 4 files changed, 225 insertions(+), 192 deletions(-) delete mode 100644 ymir/mlmmj-expose.hs create mode 100644 ymir/mlmmj-expose/FoxReplace.hs create mode 100644 ymir/mlmmj-expose/mlmmj-expose.hs (limited to 'ymir') 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 diff --git a/ymir/mlmmj-expose.nix b/ymir/mlmmj-expose.nix index 2bb82013..f1cf4dcc 100644 --- a/ymir/mlmmj-expose.nix +++ b/ymir/mlmmj-expose.nix @@ -12,18 +12,23 @@ let in rec { nixpkgs.overlays = [(self: super: { - mlmmj-exposed = super.stdenv.mkDerivation { + mlmmj-exposed = super.stdenv.mkDerivation rec { name = "mlmmj-expose"; - src = super.substituteAll { - src = ./mlmmj-expose.hs; - inherit (pkgs) mlmmj; - }; - buildCommand = let - haskellEnv = self.haskellPackages.ghcWithPackages dependencies; - in '' + + src = ./mlmmj-expose; + + phases = [ "unpackPhase" "buildPhase" "installPhase" ]; + + env = self.haskellPackages.ghcWithPackages dependencies; + + buildPhase = '' + ${env}/bin/ghc -o mlmmj-expose -odir . -hidir . mlmmj-expose.hs + ''; + + installPhase = '' mkdir -p $out/bin - #cp $src $out/bin/.mlmmj-exposed - ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-expose -odir . -hidir . $src + cp mlmmj-expose $out/bin/.mlmmj-expose + for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do ln -s .mlmmj-expose $out/bin/$f done 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