mlmmj-serve-exposed

2 files changed, 194 insertions, 100 deletions

diff --git a/ymir/mlmmj-expose.hs b/ymir/mlmmj-expose.hs
new file mode 100644
index 00000000..faf4e3b6
--- /dev/null
+++ b/ymir/mlmmj-expose.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE ViewPatterns, RecordWildCards #-}
+
+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)
+
+import Data.Aeson
+import Data.Aeson.Encode.Pretty
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+newtype FoxReplace = FoxReplace (Set FoxReplaceGroup)
+  deriving (Ord, Eq)
+
+data FoxReplaceGroup = FoxReplaceGroup
+                       { groupName :: String
+                       , groupUrls :: Set String
+                       , groupSubs :: Set FoxReplaceSub
+                       , groupHtmlMode  :: FoxReplaceHTML
+                       }
+  deriving (Ord, Eq)
+
+data FoxReplaceHTML = NoHTML | OutputOnlyHTML | BothHTML
+  deriving (Ord, Eq, Enum)
+
+data FoxReplaceSub = FoxReplaceSub
+                     { rInput, rOutput :: String
+                     , rInputType :: SubInput
+                     , rCaseSensitive :: Bool
+                     }
+  deriving (Ord, Eq)
+
+data SubInput = TextInput | WordInput | RegexpInput
+  deriving (Ord, Eq, Enum)
+
+
+instance ToJSON FoxReplace where
+  toJSON (FoxReplace groupSet) = object
+                                 [ "version" .= "0.15"
+                                 , "groups" .= groupSet
+                                 ]
+
+instance ToJSON FoxReplaceGroup where
+  toJSON FoxReplaceGroup{..} = object
+                               [ "name" .= groupName
+                               , "html" .= groupHtmlMode
+                               , "enabled" .= True
+                               , "urls" .= groupUrls
+                               , "substitutions" .= groupSubs
+                               ]
+
+instance ToJSON FoxReplaceHTML where
+  toJSON NoHTML         = String "none"
+  toJSON OutputOnlyHTML = String "output"
+  toJSON BothHTML       = String "inputoutput"
+
+instance ToJSON FoxReplaceSub where
+  toJSON FoxReplaceSub{..} = object
+                             [ "input" .= rInput
+                             , "output" .= rOutput
+                             , "inputType" .= rInputType
+                             , "caseSensitive" .= rCaseSensitive
+                             ]
+
+instance ToJSON SubInput where
+  toJSON TextInput   = String "text"
+  toJSON WordInput   = String "wholewords"
+  toJSON RegexpInput = String "regexp"
+
+
+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)
+    "mlmmj-serve-exposed" -> do
+      args <- getArgs
+      case args of
+        [(dropTrailingPathSeparator -> listDir)] -> do
+          subscribers <- getSubscribers
+          identities <- getIdentities
+
+          let
+            listName = takeBaseName listDir
+            replaceGroup ident = FoxReplaceGroup { groupName = ident ++ "." ++ listName
+                                                 , groupHtmlMode = False
+                                                 , groupUrls = Set.empty
+                                                 , groupSubs = Set.fromList $ map (replaceSub ident) subscribers
+                                                 }
+            replaceSub ident sub = FoxReplaceSub { rInput = hash' (ident, sub)
+                                                 , rOutput = sub
+                                                 , rInputType = WordInput
+                                                 , rCaseSensitive = True
+                                                 }
+
+          CLBS.putStrLn . encodePretty . FoxReplace . Set.fromList $ map replaceGroup identities
+        _ -> hPutStrLn stderr "Called without expected arguments (<listDirectory>)" >> 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
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
     '';
   };