summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ymir/mlmmj-expose.hs182
-rw-r--r--ymir/mlmmj-expose.nix25
-rw-r--r--ymir/mlmmj-expose/FoxReplace.hs67
-rw-r--r--ymir/mlmmj-expose/mlmmj-expose.hs143
4 files changed, 225 insertions, 192 deletions
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 @@
1{-# LANGUAGE ViewPatterns, RecordWildCards, OverloadedStrings #-}
2
3import System.IO
4import System.IO.Error
5import System.FilePath
6import System.Environment
7import System.Exit
8import System.Directory
9import System.Process
10import Text.Printf
11
12import Data.Char
13
14import Control.Monad
15
16import Crypto.Hash
17
18import qualified Data.ByteString.Lazy as LBS
19import qualified Data.ByteString.Char8 as CBS
20
21import qualified Data.UUID as UUID (toString)
22import qualified Data.UUID.V4 as UUID (nextRandom)
23
24import Data.Aeson
25import Data.Aeson.Encode.Pretty
26
27import Data.Set (Set)
28import qualified Data.Set as Set
29
30newtype FoxReplace = FoxReplace (Set FoxReplaceGroup)
31 deriving (Ord, Eq, Show)
32
33data FoxReplaceGroup = FoxReplaceGroup
34 { groupName :: String
35 , groupUrls :: Set String
36 , groupSubs :: Set FoxReplaceSub
37 , groupHtmlMode :: FoxReplaceHTML
38 }
39 deriving (Ord, Eq, Show)
40
41data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
42 deriving (Ord, Eq, Enum, Show)
43
44data FoxReplaceSub = FoxReplaceSub
45 { rInput, rOutput :: String
46 , rInputType :: SubInput
47 , rCaseSensitive :: Bool
48 }
49 deriving (Ord, Eq, Show)
50
51data SubInput = TextInput | WordInput | RegexpInput
52 deriving (Ord, Eq, Enum, Show)
53
54
55instance ToJSON FoxReplace where
56 toJSON (FoxReplace groupSet) = object
57 [ "version" .= ("0.15" :: String)
58 , "groups" .= groupSet
59 ]
60
61instance ToJSON FoxReplaceGroup where
62 toJSON FoxReplaceGroup{..} = object
63 [ "name" .= groupName
64 , "html" .= groupHtmlMode
65 , "enabled" .= True
66 , "urls" .= groupUrls
67 , "substitutions" .= groupSubs
68 ]
69
70instance ToJSON FoxReplaceHTML where
71 toJSON NoHTML = String "none"
72 toJSON OutputOnlyHTML = String "output"
73 toJSON BothHTML = String "inputoutput"
74
75instance ToJSON FoxReplaceSub where
76 toJSON FoxReplaceSub{..} = object
77 [ "input" .= rInput
78 , "output" .= rOutput
79 , "inputType" .= rInputType
80 , "caseSensitive" .= rCaseSensitive
81 ]
82
83instance ToJSON SubInput where
84 toJSON TextInput = String "text"
85 toJSON WordInput = String "wholewords"
86 toJSON RegexpInput = String "regexp"
87
88
89main :: IO ()
90main = do
91 progName <- takeFileName <$> getProgName
92 case progName of
93 "mlmmj-exposed" -> do
94 args <- getArgs
95 case args of
96 [listDir, (map toLower -> extension)] -> do
97 setCurrentDirectory listDir
98 identities <- getIdentities
99 subscribers <- getSubscribers
100 let hashes = filter ((==) extension . snd) [((ident, sub), hash' (ident, sub)) | ident <- identities, sub <- subscribers]
101 case hashes of
102 [((_, recipient), _)] -> do
103 uuid <- UUID.nextRandom
104 let fName = "queue" </> "exposed" <.> uuidTrans uuid
105 uuidTrans = uuidTrans' . UUID.toString
106 where
107 uuidTrans' [] = []
108 uuidTrans' ('-':xs) = uuidTrans' xs
109 uuidTrans' (x:xs) = x : uuidTrans' xs
110 getContents >>= writeFile fName
111 hPrintf stdout "Forwarding mail to <%s>, subscribed to %s\n" recipient (takeBaseName listDir)
112 callProcess "@mlmmj@/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", fName, "-T", recipient]
113 removeFile fName
114 [] -> die "Unknown extension"
115 _ -> die "Ambiguous extension"
116 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2)
117 "mlmmj-expose" -> do
118 args <- getArgs
119 case args of
120 [listDir, (map toLower -> ident)] -> do
121 setCurrentDirectory listDir
122 identities <- getIdentities
123 case ident `elem` identities of
124 True -> putStrLn "Identity is already known"
125 False -> writeFile "exposed.ids" . unlines $ ident : identities
126 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
127 "mlmmj-get-exposed" -> do
128 args <- getArgs
129 case args of
130 [(dropTrailingPathSeparator -> listDir), (map toLower -> ident)] -> do
131 setCurrentDirectory listDir
132 identities <- getIdentities
133 unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
134 mapM_ (\sub -> putStrLn $ sub ++ " " ++ takeFileName listDir ++ "+" ++ hash' (ident, sub) ++ "@subs.lists.yggdrasil.li") =<< getSubscribers
135 (dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do
136 setCurrentDirectory listDir
137 identities <- getIdentities
138 unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
139 subscribers <- getSubscribers
140 forM_ recipients $ \recipient -> do
141 unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’";
142 putStrLn $ takeFileName listDir ++ "+" ++ hash' (ident, recipient) ++ "@subs.lists.yggdrasil.li";
143 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
144 "mlmmj-serve-exposed" -> do
145 args <- getArgs
146 case args of
147 [(dropTrailingPathSeparator -> listDir)] -> do
148 setCurrentDirectory listDir
149 subscribers <- getSubscribers
150 identities <- getIdentities
151
152 let
153 listName = takeBaseName listDir
154 replaceGroup ident = FoxReplaceGroup { groupName = ident ++ "." ++ listName
155 , groupHtmlMode = NoHTML
156 , groupUrls = Set.empty
157 , groupSubs = Set.fromList $ map (replaceSub ident) subscribers
158 }
159 replaceSub ident sub = FoxReplaceSub { rInput = listName ++ "\\+" ++ hash' (ident, sub) ++ "(@subs\\.lists\\.yggdrasil\\.li)?"
160 , rOutput = sub
161 , rInputType = RegexpInput
162 , rCaseSensitive = True
163 }
164
165 LBS.putStr . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
166 putChar '\n'
167 _ -> hPutStrLn stderr "Called without expected arguments (<listDirectory>)" >> exitWith (ExitFailure 2)
168 _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)
169
170getIdentities :: IO [String]
171getIdentities = (filter (not . null) . lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
172
173getSubscribers :: IO [String]
174getSubscribers = map (map toLower) . concat <$> mapM (flip catchIOError (\e -> if isDoesNotExistError e then return [] else ioError e) . readDir) ["subscribers.d", "digesters.d"]
175 where
176 readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir))
177
178hash' :: Show a => a -> String
179hash' = take len . map toLower . show . (hash :: CBS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show
180
181len :: Int
182len = 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
12 12
13in rec { 13in rec {
14 nixpkgs.overlays = [(self: super: { 14 nixpkgs.overlays = [(self: super: {
15 mlmmj-exposed = super.stdenv.mkDerivation { 15 mlmmj-exposed = super.stdenv.mkDerivation rec {
16 name = "mlmmj-expose"; 16 name = "mlmmj-expose";
17 src = super.substituteAll { 17
18 src = ./mlmmj-expose.hs; 18 src = ./mlmmj-expose;
19 inherit (pkgs) mlmmj; 19
20 }; 20 phases = [ "unpackPhase" "buildPhase" "installPhase" ];
21 buildCommand = let 21
22 haskellEnv = self.haskellPackages.ghcWithPackages dependencies; 22 env = self.haskellPackages.ghcWithPackages dependencies;
23 in '' 23
24 buildPhase = ''
25 ${env}/bin/ghc -o mlmmj-expose -odir . -hidir . mlmmj-expose.hs
26 '';
27
28 installPhase = ''
24 mkdir -p $out/bin 29 mkdir -p $out/bin
25 #cp $src $out/bin/.mlmmj-exposed 30 cp mlmmj-expose $out/bin/.mlmmj-expose
26 ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-expose -odir . -hidir . $src 31
27 for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do 32 for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do
28 ln -s .mlmmj-expose $out/bin/$f 33 ln -s .mlmmj-expose $out/bin/$f
29 done 34 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 @@
1{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
2
3module FoxReplace where
4
5import Data.Aeson
6
7import Data.Set (Set)
8import qualified Data.Set as Set
9
10
11newtype FoxReplace = FoxReplace (Set FoxReplaceGroup)
12 deriving (Ord, Eq, Show)
13
14data FoxReplaceGroup = FoxReplaceGroup
15 { groupName :: String
16 , groupUrls :: Set String
17 , groupSubs :: Set FoxReplaceSub
18 , groupHtmlMode :: FoxReplaceHTML
19 }
20 deriving (Ord, Eq, Show)
21
22data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
23 deriving (Ord, Eq, Enum, Show)
24
25data FoxReplaceSub = FoxReplaceSub
26 { rInput, rOutput :: String
27 , rInputType :: SubInput
28 , rCaseSensitive :: Bool
29 }
30 deriving (Ord, Eq, Show)
31
32data SubInput = TextInput | WordInput | RegexpInput
33 deriving (Ord, Eq, Enum, Show)
34
35
36instance ToJSON FoxReplace where
37 toJSON (FoxReplace groupSet) = object
38 [ "version" .= ("0.15" :: String)
39 , "groups" .= groupSet
40 ]
41
42instance ToJSON FoxReplaceGroup where
43 toJSON FoxReplaceGroup{..} = object
44 [ "name" .= groupName
45 , "html" .= groupHtmlMode
46 , "enabled" .= True
47 , "urls" .= groupUrls
48 , "substitutions" .= groupSubs
49 ]
50
51instance ToJSON FoxReplaceHTML where
52 toJSON NoHTML = String "none"
53 toJSON OutputOnlyHTML = String "output"
54 toJSON BothHTML = String "inputoutput"
55
56instance ToJSON FoxReplaceSub where
57 toJSON FoxReplaceSub{..} = object
58 [ "input" .= rInput
59 , "output" .= rOutput
60 , "inputType" .= rInputType
61 , "caseSensitive" .= rCaseSensitive
62 ]
63
64instance ToJSON SubInput where
65 toJSON TextInput = String "text"
66 toJSON WordInput = String "wholewords"
67 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 @@
1{-# LANGUAGE ViewPatterns, RecordWildCards, DataKinds #-}
2
3import System.IO
4import System.IO.Error
5import System.FilePath
6import System.Environment
7import System.Exit
8import System.Directory
9import System.Process
10import Text.Printf
11
12import Data.Char
13
14import Control.Monad
15import Control.Monad.State
16
17import Crypto.Hash
18
19import qualified Data.ByteString.Lazy as LBS
20import qualified Data.ByteString.Char8 as CBS
21
22import qualified Data.UUID as UUID (toString)
23import qualified Data.UUID.V4 as UUID (nextRandom)
24
25import Data.Aeson
26import Data.Aeson.Encode.Pretty
27
28import Data.Set (Set)
29import qualified Data.Set as Set
30
31
32import FoxReplace
33
34
35data SubscriberIdent = SubscriberIdent
36 { siList, siIdent, siEmail :: String
37 } deriving (Ord, Eq, Show)
38
39hashIdent :: SubscriberIdent -> String
40hashIdent SubscriberIdent{..} = map toLower . show $ digest
41 where
42 digest :: Digest (SHAKE128 128)
43 digest = hashFinalize . flip execState hashInit $ do
44 let hashUpdate' = modify . flip hashUpdate . CBS.pack
45 hashUpdate' siList
46 hashUpdate' siIdent
47 hashUpdate' siEmail
48
49identEmail :: Bool {- ^ RegEx? -}
50 -> SubscriberIdent
51 -> String
52identEmail False si@SubscriberIdent{..} = siList ++ "+" ++ hashIdent si ++ "@subs.lists.yggdrasil.li"
53identEmail True si@SubscriberIdent{..} = siList ++ "\\+" ++ hashIdent si ++ "(@subs\\.lists\\.yggdrasil\\.li)?"
54
55
56main :: IO ()
57main = do
58 progName <- takeFileName <$> getProgName
59 case progName of
60 "mlmmj-exposed" -> do
61 args <- getArgs
62 case args of
63 [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)), (map toLower -> extension)] -> do
64 setCurrentDirectory listDir
65 identities <- getIdentities
66 subscribers <- getSubscribers
67 let hashes = filter ((==) extension . snd) [((siIdent, siEmail), hashIdent SubscriberIdent{..}) | siIdent <- identities, siEmail <- subscribers ]
68 case hashes of
69 [((_, recipient), _)] -> do
70 uuid <- UUID.nextRandom
71 let fName = "queue" </> "exposed" <.> uuidTrans uuid
72 uuidTrans = uuidTrans' . UUID.toString
73 where
74 uuidTrans' [] = []
75 uuidTrans' ('-':xs) = uuidTrans' xs
76 uuidTrans' (x:xs) = x : uuidTrans' xs
77 getContents >>= writeFile fName
78 hPrintf stdout "Forwarding mail to <%s>, subscribed to %s\n" recipient (takeBaseName listDir)
79 callProcess "@mlmmj@/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", fName, "-T", recipient]
80 removeFile fName
81 [] -> die "Unknown extension"
82 _ -> die "Ambiguous extension"
83 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2)
84 "mlmmj-expose" -> do
85 args <- getArgs
86 case args of
87 [listDir, (map toLower -> ident)] -> do
88 setCurrentDirectory listDir
89 identities <- getIdentities
90 case ident `elem` identities of
91 True -> putStrLn "Identity is already known"
92 False -> writeFile "exposed.ids" . unlines $ ident : identities
93 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
94 "mlmmj-get-exposed" -> do
95 args <- getArgs
96 case args of
97 [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)), (map toLower -> siIdent)] -> do
98 setCurrentDirectory listDir
99 identities <- getIdentities
100 unless (siIdent `elem` identities) . die $ "Unknown sender: ‘" ++ siIdent ++ "’"
101 mapM_ (\siEmail -> putStrLn $ siEmail ++ " " ++ identEmail False SubscriberIdent{..}) =<< getSubscribers
102 (dropTrailingPathSeparator -> listDir@(takeBaseName -> siList)) : (map toLower -> siIdent) : (map (map toLower) -> recipients) -> do
103 setCurrentDirectory listDir
104 identities <- getIdentities
105 unless (siIdent `elem` identities) . die $ "Unknown sender: ‘" ++ siIdent ++ "’"
106 subscribers <- getSubscribers
107 forM_ recipients $ \siEmail -> do
108 unless (siEmail `elem` subscribers) . die $ "Unknown recipient: ‘" ++ siEmail ++ "’"
109 putStrLn $ identEmail False SubscriberIdent{..}
110 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
111 "mlmmj-serve-exposed" -> do
112 args <- getArgs
113 case args of
114 [(dropTrailingPathSeparator -> listDir@(takeBaseName -> siList))] -> do
115 setCurrentDirectory listDir
116 subscribers <- getSubscribers
117 identities <- getIdentities
118
119 let
120 replaceGroup siIdent = FoxReplaceGroup { groupName = siIdent ++ "." ++ siList
121 , groupHtmlMode = NoHTML
122 , groupUrls = Set.empty
123 , groupSubs = Set.fromList $ map (replaceSub siIdent) subscribers
124 }
125 replaceSub siIdent siEmail = FoxReplaceSub { rInput = identEmail True SubscriberIdent{..}
126 , rOutput = siEmail
127 , rInputType = RegexpInput
128 , rCaseSensitive = False
129 }
130
131 LBS.putStr . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
132 putChar '\n'
133 _ -> hPutStrLn stderr "Called without expected arguments (<listDirectory>)" >> exitWith (ExitFailure 2)
134 _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)
135
136
137getIdentities :: IO [String]
138getIdentities = (filter (not . null) . lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
139
140getSubscribers :: IO [String]
141getSubscribers = map (map toLower) . concat <$> mapM (flip catchIOError (\e -> if isDoesNotExistError e then return [] else ioError e) . readDir) ["subscribers.d", "digesters.d"]
142 where
143 readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-11 04:54:26 +0000