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
|
{ config, pkgs, ... }:
let
haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory cryptonite bytestring uuid ]);
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 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" <.> UUID.toString uuid
getContents >>= writeFile fName
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 (<listDirectory> <recipientExtension>)") >> 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 (<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
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 (<listDirectory> <senderIdentity> [<recipient> [...]])") >> 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
'';
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
done
'';
};
in rec {
nixpkgs.config.packageOverrides = pkgs: rec {
inherit mlmmj-exposed;
};
environment.systemPackages = [ mlmmj-exposed ];
}
|
