1 files changed, 79 insertions, 8 deletions

diff --git a/cokiki.hs b/cokiki.hs
index fc69037..daebf0f 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -1,17 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
 import Control.Applicative
 import Control.DeepSeq
 import Data.Bool
 import Data.Char
 import Data.List
 import Data.Maybe
+import Data.Monoid
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Char8 as S8
 import qualified Kiki
 import System.Directory
 import System.FilePath.Posix (takeDirectory)
 import System.Environment
+import System.Exit
 import System.IO
 import System.Posix.User
 import CommandLine
@@ -45,20 +49,30 @@ usage = unlines
     , ""
     , "  strongswan   Modify /etc/ipsec.conf to include settings from"
     , "               /var/cache/kiki/ipsec.conf."
+    , ""
+    , "  tor          Modify /etc/tor/torrc to configure a tor hidden"
+    , "               service for email (smtp), ssh, and http ports."
     ]
 
 main = do
     (cmd,args) <- splitAt 1 <$> getArgs
     uid <- getEffectiveUserID
-    let sel = case cmd of
-                ["ssh-client"] -> sshClient  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
-                ["ssh-server"] -> sshServer  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
-                ["strongswan"] -> strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
-                _   -> pure $ hPutStr stderr usage
+    let msel = case cmd of
+                ["ssh-client"] -> Just $ sshClient  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
+                ["ssh-server"] -> Just $ sshServer  uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
+                ["strongswan"] -> Just $ strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
+                ["tor"]        -> Just $ configureTor uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
+                _ -> Nothing
         spec = uncurry fancy Kiki.kikiOptions ""
-    case runArgs (parseInvocation spec args) sel of
-        Left e   -> hPutStrLn stderr $ usageErrorMessage e
-        Right io -> io
+        errorQuit msg = do
+            hPutStr stderr msg
+            System.Exit.exitFailure
+    fromMaybe (errorQuit usage) $ do
+        sel <- msel
+        Just $ do
+        case runArgs (parseInvocation spec args) sel of
+            Left e   -> errorQuit $ usageErrorMessage e
+            Right io -> io
 
 maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
 maybeReadFile path = do
@@ -131,6 +145,62 @@ strongswan uid root cmn = whenRoot uid root cmn $ do
     -- etc/ipsec.conf    <--  'include /var/cache/kiki/ipsec.conf'
     Kiki.importAndRefresh root cmn
 
+configureTor uid root cmn = whenRoot uid root cmn $ do
+    -- Parsing as if ssh config, that's not right, but good enough for now.
+    torrc <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/tor/torrc")
+    let p:gs     = groupBy (\_ d -> not $ sshIsDirective "HiddenServiceDir" d) $ ["#"]:torrc
+        (fs, hs) = break (\(d:ds) -> elem "/var/cache/kiki/config/tor/" d) gs
+    case hs of
+        (d:ds):ks
+            | (pre:ports) <- groupBy (\_ d -> not $ sshIsDirective "HiddenServicePort" d) $ ["#"]:ds
+            , (got,need) <- partition (hasPort ports) ["80","22","25"]
+                -> case need of
+                    [] -> hPutStrLn stderr "tor is already configured."
+                    ns | (addr:_) <- mapMaybe (fmap fst . splitAddr . word 2) ds
+                         -> do hPutStrLn stderr "binding tor ports for configured address"
+                               bindports addr ns
+                       | otherwise
+                         -> do hPutStrLn stderr "binding tor ports for 127.0.0.1"
+                               bindports "127.0.0.1" ns
+                   where
+                    bindports :: L.ByteString -> [L.ByteString] -> IO ()
+                    bindports addr ns = do
+                        let binds = map mkport ns
+                            mkport n = ["HiddenServicePort"," ",n," ",addr <> ":" <> n]
+                            torrc' = concat $ drop 1 p : fs ++ (d:binds ++ ds):ks
+                        torrc' `deepseq` return () -- force lazy input
+                        myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc'
+
+                    hasPort :: [[[L.ByteString]]] -> L.ByteString -> Bool
+                    hasPort ports p = not $ null $ flip filter ports
+                                          $ (==p) . word 1 . concat . take 1
+
+                    word :: Int -> [L.ByteString] -> L.ByteString
+                    word n toks = words !! n
+                     where
+                        words = filter (not . L8.any isSpace . L8.take 1)
+                                       toks
+
+                    splitAddr lb
+                            | S8.null saddr = Nothing
+                            | otherwise     = Just ( L.fromChunks [S8.init saddr]
+                                                   , L.fromChunks [sport])
+                        where
+                            (saddr,sport) = S8.breakEnd (==':') sb
+                            sb = S8.concat $ L.toChunks $ L.take 60 lb
+
+        [] -> do hPutStrLn stderr $ "configuring new hidden service"
+                 let torrc' = torrc
+                                ++ [ []
+                                   , ["HiddenServiceDir"," ","/var/cache/kiki/config/tor/"]
+                                   , ["HiddenServicePort"," ","80"," ","127.0.0.1:80"]
+                                   , ["HiddenServicePort"," ","22"," ","127.0.0.1:22"]
+                                   , ["HiddenServicePort"," ","25"," ","127.0.0.1:25"] ]
+                 myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc'
+    Kiki.importAndRefresh root cmn
+    return ()
+
+
 parseSshConfig :: L.ByteString -> [[L.ByteString]]
 parseSshConfig bs = map tokenize $ L8.lines bs
  where
@@ -150,6 +220,7 @@ sshIsDirective d ls =
     isSpaceTok "" = True
     isSpaceTok b  = isSpace $ L8.head b
 
+
 #if !MIN_VERSION_base(4,7,0)
 bool :: a -> a -> Bool -> a
 bool f _ False = f