summaryrefslogtreecommitdiff
path: root/ymir
diff options
context:
space:
mode:
Diffstat (limited to 'ymir')
-rw-r--r--ymir/mlmmj-expose.hs180
-rw-r--r--ymir/mlmmj-expose.nix114
2 files changed, 194 insertions, 100 deletions
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 @@
1{-# LANGUAGE ViewPatterns, RecordWildCards #-}
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)
32
33data FoxReplaceGroup = FoxReplaceGroup
34 { groupName :: String
35 , groupUrls :: Set String
36 , groupSubs :: Set FoxReplaceSub
37 , groupHtmlMode :: FoxReplaceHTML
38 }
39 deriving (Ord, Eq)
40
41data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
42 deriving (Ord, Eq, Enum)
43
44data FoxReplaceSub = FoxReplaceSub
45 { rInput, rOutput :: String
46 , rInputType :: SubInput
47 , rCaseSensitive :: Bool
48 }
49 deriving (Ord, Eq)
50
51data SubInput = TextInput | WordInput | RegexpInput
52 deriving (Ord, Eq, Enum)
53
54
55instance ToJSON FoxReplace where
56 toJSON (FoxReplace groupSet) = object
57 [ "version" .= "0.15"
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 "${pkgs.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 subscribers <- getSubscribers
149 identities <- getIdentities
150
151 let
152 listName = takeBaseName listDir
153 replaceGroup ident = FoxReplaceGroup { groupName = ident ++ "." ++ listName
154 , groupHtmlMode = False
155 , groupUrls = Set.empty
156 , groupSubs = Set.fromList $ map (replaceSub ident) subscribers
157 }
158 replaceSub ident sub = FoxReplaceSub { rInput = hash' (ident, sub)
159 , rOutput = sub
160 , rInputType = WordInput
161 , rCaseSensitive = True
162 }
163
164 CLBS.putStrLn . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
165 _ -> hPutStrLn stderr "Called without expected arguments (<listDirectory>)" >> exitWith (ExitFailure 2)
166 _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)
167
168getIdentities :: IO [String]
169getIdentities = (filter (not . null) . lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
170
171getSubscribers :: IO [String]
172getSubscribers = map (map toLower) . concat <$> mapM (flip catchIOError (\e -> if isDoesNotExistError e then return [] else ioError e) . readDir) ["subscribers.d", "digesters.d"]
173 where
174 readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir))
175
176hash' :: Show a => a -> String
177hash' = take len . map toLower . show . (hash :: CBS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show
178
179len :: Int
180len = 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 @@
1{ config, pkgs, ... }: 1{ config, pkgs, ... }:
2 2
3let 3let
4 haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory cryptonite bytestring uuid ]); 4 haskellEnv = pkgs.haskellPackages.ghcWithPackages dependencies;
5 dependencies = pkgs: with pkgs; [ filepath
6 directory
7 cryptonite
8 bytestring
9 uuid
10 aeson
11 aeson-pretty
12 ];
5 mlmmj-exposed = pkgs.stdenv.mkDerivation { 13 mlmmj-exposed = pkgs.stdenv.mkDerivation {
6 name = "mlmmj-exposed"; 14 name = "mlmmj-expose";
7 src = pkgs.writeText "mlmmj-exposed.hs" '' 15 src = ./mlmmj-expose.hs;
8 {-# LANGUAGE ViewPatterns #-}
9
10 import System.IO
11 import System.IO.Error
12 import System.FilePath
13 import System.Environment
14 import System.Exit
15 import System.Directory
16 import System.Process
17 import Text.Printf
18
19 import Data.Char
20
21 import Control.Monad
22
23 import Crypto.Hash
24
25 import qualified Data.ByteString.Lazy as LBS
26 import qualified Data.ByteString.Char8 as CBS
27
28 import qualified Data.UUID as UUID (toString)
29 import qualified Data.UUID.V4 as UUID (nextRandom)
30
31 main :: IO ()
32 main = do
33 progName <- takeFileName <$> getProgName
34 case progName of
35 "mlmmj-exposed" -> do
36 args <- getArgs
37 case args of
38 [listDir, (map toLower -> extension)] -> do
39 setCurrentDirectory listDir
40 identities <- getIdentities
41 subscribers <- getSubscribers
42 let hashes = filter ((==) extension . snd) [((ident, sub), hash' (ident, sub)) | ident <- identities, sub <- subscribers]
43 case hashes of
44 [((_, recipient), _)] -> do
45 uuid <- UUID.nextRandom
46 let fName = "queue" </> "exposed" <.> uuidTrans uuid
47 uuidTrans = uuidTrans' . UUID.toString
48 where
49 uuidTrans' [] = []
50 uuidTrans' ('-':xs) = uuidTrans' xs
51 uuidTrans' (x:xs) = x : uuidTrans' xs
52 getContents >>= writeFile fName
53 hPrintf stdout "Forwarding mail to <%s>, subscribed to %s\n" recipient (takeBaseName listDir)
54 callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", fName, "-T", recipient]
55 removeFile fName
56 [] -> die "Unknown extension"
57 _ -> die "Ambiguous extension"
58 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2)
59 "mlmmj-expose" -> do
60 args <- getArgs
61 case args of
62 [listDir, (map toLower -> ident)] -> do
63 setCurrentDirectory listDir
64 identities <- getIdentities
65 case ident `elem` identities of
66 True -> putStrLn "Identity is already known"
67 False -> writeFile "exposed.ids" . unlines $ ident : identities
68 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
69 "mlmmj-get-exposed" -> do
70 args <- getArgs
71 case args of
72 [(dropTrailingPathSeparator -> listDir), (map toLower -> ident)] -> do
73 setCurrentDirectory listDir
74 identities <- getIdentities
75 unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
76 mapM_ (\sub -> putStrLn $ sub ++ " " ++ takeFileName listDir ++ "+" ++ hash' (ident, sub) ++ "@subs.lists.yggdrasil.li") =<< getSubscribers
77 (dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do
78 setCurrentDirectory listDir
79 identities <- getIdentities
80 unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
81 subscribers <- getSubscribers
82 forM_ recipients (\recipient -> do {
83 unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’";
84 putStrLn $ takeFileName listDir ++ "+" ++ hash' (ident, recipient) ++ "@subs.lists.yggdrasil.li";
85 })
86 _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
87 _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)
88 getIdentities :: IO [String]
89 getIdentities = (filter (not . null) . lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
90
91 getSubscribers :: IO [String]
92 getSubscribers = map (map toLower) . concat <$> mapM (flip catchIOError (\e -> if isDoesNotExistError e then return [] else ioError e) . readDir) ["subscribers.d", "digesters.d"]
93 where
94 readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir))
95
96 hash' :: Show a => a -> String
97 hash' = take len . map toLower . show . (hash :: CBS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show
98
99 len :: Int
100 len = 32
101 '';
102 buildCommand = '' 16 buildCommand = ''
103 mkdir -p $out/bin 17 mkdir -p $out/bin
104 #cp $src $out/bin/.mlmmj-exposed 18 #cp $src $out/bin/.mlmmj-exposed
105 ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-exposed -odir . -hidir . $src 19 ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-expose -odir . -hidir . $src
106 for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed; do 20 for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do
107 ln -s .mlmmj-exposed $out/bin/$f 21 ln -s .mlmmj-expose $out/bin/$f
108 done 22 done
109 ''; 23 '';
110 }; 24 };
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-14 02:30:46 +0000