mlmmj-expose

3 files changed, 92 insertions, 3 deletions

diff --git a/ymir.nix b/ymir.nix
index faf139f4..115953e6 100644
--- a/ymir.nix
+++ b/ymir.nix
@@ -16,7 +16,8 @@ let
 in rec {
   imports =
     [
-      ./ymir-hw.nix
+      ./ymir/hw.nix
+      ./ymir/mlmmj-expose.nix
       ./custom/zsh.nix
       ./users.nix
       ./custom/tinc/def.nix
@@ -419,8 +420,9 @@ in rec {
       alias_maps = hash:/etc/postfix/aliases texthash:/srv/mail/spm
     '';
     extraMasterConf = ''
-      uucp  unix - n n - - pipe flags=Fqhu user=uucp  argv=/var/setuid-wrappers/uux -z -a$sender - $nexthop!rmail ($recipient)
-      mlmmj unix - n n - - pipe flags=ORhu user=mlmmj argv=${pkgs.mlmmj}/bin/mlmmj-receive -F -L /var/spool/lists/''${user}
+      uucp       unix - n n - - pipe flags=Fqhu user=uucp  argv=/var/setuid-wrappers/uux -z -a$sender - $nexthop!rmail ($recipient)
+      mlmmj      unix - n n - - pipe flags=ORhu user=mlmmj argv=${pkgs.mlmmj}/bin/mlmmj-receive -F -L /var/spool/lists/''${user}
+      mlmmj-subs unix - n n - - pipe flags=ORhu user=mlmmj argv=${pkgs.mlmmj-exposed}/bin/mlmmj-exposed /var/spool/lists/''${user} ''${extension}
     '';
     networks = ["127.0.0.0/8" "[::ffff:127.0.0.0]/104" "[::1]/128" "10.141.0.0/16"];
   };
diff --git a/ymir-hw.nix b/ymir/hw.nix
index 3ddf1035..3ddf1035 100644
--- a/ymir-hw.nix
+++ b/ymir/hw.nix
diff --git a/ymir/mlmmj-expose.nix b/ymir/mlmmj-expose.nix
new file mode 100644
index 00000000..4fa317a0
--- /dev/null
+++ b/ymir/mlmmj-expose.nix
@@ -0,0 +1,87 @@
+{ 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.writeScript "mlmmj-exposed" ''
+      #! ${haskellEnv}/bin/runghc
+
+      {-# 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.Base64 as Base64
+
+      main :: IO ()
+      main = do
+        progName <- takeFileName <$> getProgName
+        case progName of
+          "mlmmj-exposed" -> do
+            args <- getArgs
+            case args of
+              [listDir, (Base64.decodeLenient -> 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)) :: (String, String)) = read . CLBS.unpack $ decryptMsg CBC key recipientExt
+                identities <- (read <$> 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) . dio $ "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 "exosed.ids" . show $ ident : identities
+              _ -> hPutStrLn stderr ("Called without expected arguments (<listDirectory> <senderIdentity>)") >> exitWith (ExitFailure 2)
+           "mlmmj-get-exposed" -> do
+            args <- getArgs
+            case args of
+              [listDir, (map toLower -> ident), (map toLower -> recipient)] -> 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 <- (read <$> 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) . dio $ "Unknown recipient: ‘" ++ recipient ++ "’"
+                encryptMsg CBC key (CLBS.pack . show $ (ident, recipient)) >>= CLBS.putStrLn
+              _ -> 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) =<< (getDirectoryContents dir)
+    '';
+    buildCommand = ''
+      mkdir -p $out/bin
+      cp $src $out/bin/.mlmmj-exposed
+      ln -s $out/bin/mlmmj-exposed .mlmmj-exposed
+    '';
+  };
+in rec {
+  environment.systemPackages = [ mlmmj-exposed ];
+}