diff options
-rw-r--r-- | ymir/mlmmj-expose.nix | 36 |
1 files changed, 13 insertions, 23 deletions
diff --git a/ymir/mlmmj-expose.nix b/ymir/mlmmj-expose.nix index 2357584e..aca8aeb1 100644 --- a/ymir/mlmmj-expose.nix +++ b/ymir/mlmmj-expose.nix | |||
@@ -1,7 +1,7 @@ | |||
1 | { config, pkgs, ... }: | 1 | { config, pkgs, ... }: |
2 | 2 | ||
3 | let | 3 | let |
4 | haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory SimpleAES bytestring hex ]); | 4 | haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory cryptonite bytestring ]); |
5 | mlmmj-exposed = pkgs.stdenv.mkDerivation { | 5 | mlmmj-exposed = pkgs.stdenv.mkDerivation { |
6 | name = "mlmmj-exposed"; | 6 | name = "mlmmj-exposed"; |
7 | src = pkgs.writeText "mlmmj-exposed.hs" '' | 7 | src = pkgs.writeText "mlmmj-exposed.hs" '' |
@@ -19,14 +19,16 @@ let | |||
19 | 19 | ||
20 | import Control.Monad | 20 | import Control.Monad |
21 | 21 | ||
22 | import Codec.Crypto.SimpleAES | 22 | -- import Codec.Crypto.SimpleAES |
23 | |||
24 | import Crypto.Hash | ||
23 | 25 | ||
24 | import qualified Data.ByteString.Lazy as LBS | 26 | import qualified Data.ByteString.Lazy as LBS |
25 | import qualified Data.ByteString.Lazy.Char8 as CLBS | 27 | import qualified Data.ByteString.Lazy.Char8 as CLBS |
26 | import qualified Data.ByteString as BS | 28 | import qualified Data.ByteString as BS |
27 | import qualified Data.ByteString.Char8 as CBS | 29 | import qualified Data.ByteString.Char8 as CBS |
28 | 30 | ||
29 | import Data.Hex | 31 | -- import Data.Hex |
30 | 32 | ||
31 | main :: IO () | 33 | main :: IO () |
32 | main = do | 34 | main = do |
@@ -35,15 +37,12 @@ let | |||
35 | "mlmmj-exposed" -> do | 37 | "mlmmj-exposed" -> do |
36 | args <- getArgs | 38 | args <- getArgs |
37 | case args of | 39 | case args of |
38 | [listDir, rawExtension] -> do | 40 | [listDir, extension] -> do |
39 | extension <- CLBS.pack <$> unhex rawExtension | ||
40 | setCurrentDirectory listDir | 41 | setCurrentDirectory listDir |
41 | key <- (BS.readFile "exposed.key") `catchIOError` (\e -> if isDoesNotExistError e then randomKey >>= (\k -> BS.writeFile "exposed.key" k >> return k) else ioError e) | ||
42 | let ((map toLower -> ident), (map toLower -> recipient)) = read . CLBS.unpack $ decryptMsg CBC key extension | ||
43 | identities <- getIdentities | 42 | identities <- getIdentities |
44 | unless (ident `elem` identities) $ die "Unknown sender" | ||
45 | subscribers <- getSubscribers | 43 | subscribers <- getSubscribers |
46 | unless (recipient `elem` subscribers) $ die "Unknown recipient" | 44 | let hashes = [(ident, sub, take len $ hash' (ident, sub)) | ident <- identities, sub <- subscribers] |
45 | unless (extension `elem` map (\(_, _, s) -> s) hashes) $ die "Unknown extension" | ||
47 | getContents >>= writeFile "queue/exposed" | 46 | getContents >>= writeFile "queue/exposed" |
48 | callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", "queue/exposed", "-T", recipient] | 47 | callProcess "${pkgs.mlmmj}/bin/mlmmj-send" ["-L", listDir, "-l", "6", "-m", "queue/exposed", "-T", recipient] |
49 | _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2) | 48 | _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <recipientExtension>)") >> exitWith (ExitFailure 2) |
@@ -62,13 +61,12 @@ let | |||
62 | case args of | 61 | case args of |
63 | (dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do | 62 | (dropTrailingPathSeparator -> listDir) : (map toLower -> ident) : (map (map toLower) -> recipients) -> do |
64 | setCurrentDirectory listDir | 63 | setCurrentDirectory listDir |
65 | key <- (BS.readFile "exposed.key") `catchIOError` (\e -> if isDoesNotExistError e then randomKey >>= (\k -> BS.writeFile "exposed.key" k >> return k) else ioError e) | ||
66 | identities <- getIdentities | 64 | identities <- getIdentities |
67 | unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’" | 65 | unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’" |
68 | subscribers <- getSubscribers | 66 | subscribers <- getSubscribers |
69 | forM_ recipients (\recipient -> do { | 67 | forM_ recipients (\recipient -> do { |
70 | unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’"; | 68 | unless (recipient `elem` subscribers) . die $ "Unknown recipient: ‘" ++ recipient ++ "’"; |
71 | encryptMsg CBC key (CLBS.pack . show $ (ident, recipient)) >>= putStrLn . (\ext -> takeFileName listDir ++ "+" ++ ext ++ "@subs.lists.yggdrasil.li") . hex . CLBS.unpack; | 69 | putStrLn $ takeFileName listDir ++ "+" ++ hash' (ident, recipient) ++ "@subs.lists.yggdrasil.li"; |
72 | }) | 70 | }) |
73 | _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2) | 71 | _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity> [<recipient> [...]])") >> exitWith (ExitFailure 2) |
74 | _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2) | 72 | _ -> hPutStrLn stderr ("Called under unsupported name ‘" ++ progName ++ "’") >> exitWith (ExitFailure 2) |
@@ -80,19 +78,11 @@ let | |||
80 | where | 78 | where |
81 | readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir)) | 79 | readDir dir = concat <$> (mapM (fmap lines . readFile) . map (dir </>) . filter (not . (`elem` [".", ".."]))=<< (getDirectoryContents dir)) |
82 | 80 | ||
83 | massage :: BS.ByteString -> BS.ByteString | 81 | hash' :: Show a => a -> String |
84 | massage = CBS.pack . map massage' . CBS.unpack | 82 | hash' = show . (hash :: BS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show |
85 | where | ||
86 | massage' '+' = '-' | ||
87 | massage' '/' = '_' | ||
88 | massage' c = c | ||
89 | 83 | ||
90 | unmassage :: BS.ByteString -> BS.ByteString | 84 | len :: Int |
91 | unmassage = CBS.pack . map massage' . CBS.unpack | 85 | len = 16 |
92 | where | ||
93 | massage' '-' = '+' | ||
94 | massage' '_' = '/' | ||
95 | massage' c = c | ||
96 | ''; | 86 | ''; |
97 | buildCommand = '' | 87 | buildCommand = '' |
98 | mkdir -p $out/bin | 88 | mkdir -p $out/bin |