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 ]);
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 Crypto.Hash
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 Data.Hex
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
getContents >>= writeFile "queue/exposed"
callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", "queue/exposed", "-T", recipient]
[] -> 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 :: BS.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 ];
}
|
