1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{ config, pkgs, ... }:
let
haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory SimpleAES bytestring base64-bytestring ]);
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 Data.Char
import Control.Monad
import Codec.Crypto.SimpleAES
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as CLBS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Base64 as Base64
main :: IO ()
main = do
progName <- takeFileName <$> getProgName
case progName of
"mlmmj-exposed" -> do
args <- getArgs
case args of
[listDir, (LBS.fromStrict . Base64.decodeLenient . unmassage . CBS.pack -> extension)] -> do
setCurrentDirectory listDir
key <- (BS.readFile "exposed.key") `catchIOError` (\e -> if isDoesNotExistError e then randomKey >>= (\k -> BS.writeFile "exposed.key" k >> return k) else ioError e)
let ((map toLower -> ident), (map toLower -> recipient)) = read . CLBS.unpack $ decryptMsg CBC key extension
identities <- (lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
subscribers <- getSubscribers
unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’"
getContents >>= writeFile "queue/exposed"
callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", "queue/exposed", "-T", recipient]
_ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2)
"mlmmj-expose" -> do
args <- getArgs
case args of
[listDir, (map toLower -> ident)] -> do
setCurrentDirectory listDir
identities <- (read <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
case ident `elem` identities of
True -> putStrLn "Identity is already known"
False -> writeFile "exposed.ids" . unlines $ ident : identities
_ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
"mlmmj-get-exposed" -> do
args <- getArgs
case args of
(dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do
setCurrentDirectory listDir
key <- (BS.readFile "exposed.key") `catchIOError` (\e -> if isDoesNotExistError e then randomKey >>= (\k -> BS.writeFile "exposed.key" k >> return k) else ioError e)
identities <- (lines <$> readFile "exposed.ids") `catchIOError` (\e -> if isDoesNotExistError e then return [] else ioError e)
unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
subscribers <- getSubscribers
forM_ recipients (\recipient -> do {
unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’";
encryptMsg CBC key (CLBS.pack . show $ (ident, recipient)) >>= putStrLn . (\ext -> takeFileName listDir ++ "+" ++ ext ++ "@subs.lists.yggdrasil.li") . CBS.unpack . massage . Base64.encode . LBS.toStrict;
})
_ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2)
_ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2)
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))
massage :: BS.ByteString -> BS.ByteString
massage = CBS.pack . map massage' . CBS.unpack
where
massage' '+' = '-'
massage' '/' = '_'
massage' c = c
unmassage :: BS.ByteString -> BS.ByteString
unmassage = CBS.pack . map massage' . CBS.unpack
where
massage' '-' = '+'
massage' '_' = '/'
massage' c = c
'';
buildCommand = ''
mkdir -p $out/bin
#cp $src $out/bin/.mlmmj-exposed
${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-exposed $src
for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed; do
ln -s .mlmmj-exposed $out/bin/$f
done
'';
};
in rec {
nixpkgs.config.packageOverrides = pkgs: rec {
inherit mlmmj-exposed;
};
environment.systemPackages = [ mlmmj-exposed ];
}
|
