mlmmj-serve-exposed

1 files changed, 14 insertions, 100 deletions

diff --git a/ymir/mlmmj-expose.nix b/ymir/mlmmj-expose.nix
index 2bdcf619..370219d3 100644
--- a/ymir/mlmmj-expose.nix
+++ b/ymir/mlmmj-expose.nix
@@ -1,110 +1,24 @@
 { config, pkgs, ... }:
 
 let
-  haskellEnv = pkgs.haskellPackages.ghcWithPackages (pkgs: with pkgs; [ filepath directory cryptonite bytestring uuid ]);
+  haskellEnv = pkgs.haskellPackages.ghcWithPackages dependencies;
+  dependencies = pkgs: with pkgs; [ filepath
+                                    directory
+                                    cryptonite
+                                    bytestring
+                                    uuid
+                                    aeson
+                                    aeson-pretty
+                                  ];
   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 Text.Printf
-
-      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" <.> uuidTrans uuid
-                        uuidTrans = uuidTrans' . UUID.toString
-                          where
-                            uuidTrans' []       = []
-                            uuidTrans' ('-':xs) =       uuidTrans' xs
-                            uuidTrans' (x:xs)   =   x : uuidTrans' xs
-                    getContents >>= writeFile fName
-                    hPrintf stdout "Forwarding mail to <%s>, subscribed to %s\n" recipient (takeBaseName listDir)
-                    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)] -> do
-                setCurrentDirectory listDir
-                identities <- getIdentities
-                unless (ident `elem` identities) . die $ "Unknown sender: ‘" ++ ident ++ "’"
-                mapM_ (\sub -> putStrLn $ sub ++ " " ++ takeFileName listDir ++ "+" ++ hash' (ident, sub) ++ "@subs.lists.yggdrasil.li") =<< getSubscribers
-              (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
-    '';
+    name = "mlmmj-expose";
+    src = ./mlmmj-expose.hs;
     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
+      ${haskellEnv}/bin/ghc -o $out/bin/.mlmmj-expose -odir . -hidir . $src
+      for f in mlmmj-exposed mlmmj-expose mlmmj-get-exposed mlmmj-serve-exposed; do
+        ln -s .mlmmj-expose $out/bin/$f
       done
     '';
   };