summaryrefslogtreecommitdiff
path: root/ymir/mlmmj-expose.hs
diff options
context:
space:
mode:
Diffstat (limited to 'ymir/mlmmj-expose.hs')
-rw-r--r--ymir/mlmmj-expose.hs182
1 files changed, 0 insertions, 182 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
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-13 11:34:05 +0000