From 692a3961f1788abe8fd284d744e7389888dc2353 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 12 Dec 2016 15:21:04 +0100 Subject: mlmmj-serve-exposed --- ymir/mlmmj-expose.hs | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++ ymir/mlmmj-expose.nix | 114 ++++---------------------------- 2 files changed, 194 insertions(+), 100 deletions(-) create mode 100644 ymir/mlmmj-expose.hs (limited to 'ymir') 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 ( )") >> 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 + 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 ()" >> 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 2bdcf619..370219d3 100644 --- a/ymir/mlmmj-expose.nix +++ b/ymir/mlmmj-expose.nix @@ -1,110 +1,24 @@ { config, pkgs, ... }: let - haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory cryptonite bytestring uuid ]); + haskellEnv = pkgs.haskellPackages.ghcWithPackages dependencies; + dependencies = pkgs: with pkgs; [ filepath + directory + cryptonite + bytestring + uuid + aeson + aeson-pretty + ]; mlmmj-exposed = pkgs.stdenv.mkDerivation { - name = "mlmmj-exposed"; - src = pkgs.writeText "mlmmj-exposed.hs" '' - {-# LANGUAGE ViewPatterns #-} - - 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) - - 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 ( )") >> 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) - _ -> 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 - ''; + name = "mlmmj-expose"; + src = ./mlmmj-expose.hs; buildCommand = '' mkdir -p $out/bin #cp $src $out/bin/.mlmmj-exposed - ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-exposed -odir . -hidir . $src - for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed; do - ln -s .mlmmj-exposed $out/bin/$f + ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-expose -odir . -hidir . $src + for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do + ln -s .mlmmj-expose $out/bin/$f done ''; }; -- cgit v1.2.3