From 1ec22940038b58f6f8866f372967e63bae5496ae Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 21 Jun 2016 21:07:23 +0200
Subject: hashes instead of crypto

---
 ymir/mlmmj-expose.nix | 36 +++++++++++++-----------------------
 1 file 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 @@
 { config, pkgs, ... }:
 
 let
-  haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory SimpleAES bytestring hex ]);
+  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" ''
@@ -19,14 +19,16 @@ let
 
       import Control.Monad
 
-      import Codec.Crypto.SimpleAES
+      -- 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
+      -- import Data.Hex
 
       main :: IO ()
       main = do
@@ -35,15 +37,12 @@ let
           "mlmmj-exposed" -> do
             args <- getArgs
             case args of
-              [listDir, rawExtension] -> do
-                extension <- CLBS.pack <$> unhex rawExtension
+              [listDir, 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 <- getIdentities
-                unless (ident `elem` identities) $ die "Unknown sender"
                 subscribers <- getSubscribers
-                unless (recipient `elem` subscribers) $ die "Unknown recipient"
+                let hashes = [(ident, sub, take len $ hash' (ident, sub)) | ident <- identities, sub <- subscribers]
+                unless (extension `elem` map (\(_, _, s) -> s) hashes) $ die "Unknown extension"
                 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)
@@ -62,13 +61,12 @@ let
             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 <- getIdentities
                 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") . hex . CLBS.unpack;
+                  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)
@@ -80,19 +78,11 @@ let
         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
+      hash' :: Show a => a -> String
+      hash' = show . (hash :: BS.ByteString -> Digest SHA256) . CBS.pack . map toLower . show
 
-      unmassage :: BS.ByteString -> BS.ByteString
-      unmassage = CBS.pack . map massage' . CBS.unpack
-        where
-          massage' '-' = '+'
-          massage' '_' = '/'
-          massage' c = c
+      len :: Int
+      len = 16
     '';
     buildCommand = ''
       mkdir -p $out/bin
-- 
cgit v1.2.3