{-# 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

usage = unlines
    [ "cokiki <command> [--chroot=ROOTDIR]"
    , "                 [--homedir=HOMEDIR]"
    , "                 [--passphrase-fd=FD]"
    , ""
    , "cokiki modifies system configuration to recognize generated files"
    , "in /var/cache/kiki. In addition to each command's documented effects"
    , "(see COMMANDS), the following operation will be performed on your"
    , "GnuPG keyring:"
    , ""
    , "          master-key (generated if not present)"
    , "          tor        (generated if not prsenet)"
    , "          ipsec      (generated if not prsenet)"
    , "          ssh-server (imported or generated if not present)"
    , "          ssh-client (imported or gnnerated if not present)"
    , ""
    , "The /var/cache/kiki/* tree will also be refreshed."
    , ""
    , "COMMANDS"
    , ""
    , "  ssh-client   Modify system ssh configuration to respect"
    , "               /var/cache/kiki/ssh_known_hosts."
    , ""
    , "  ssh-server   Modify system ssh configuration to use the"
    , "               kiki-managed host key at"
    , "               /var/cache/kiki/ssh_host_rsa_key."
    , ""
    , "  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 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 ""
        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
    doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)
myWriteFile f bs = do
    createDirectoryIfMissing True (takeDirectory f)
    hPutStrLn stderr $ "Writing "++f
    -- L8.putStr bs
    L8.writeFile f bs

whenRoot uid root cmn action
    | uid==0         = action
    | root "" == "/" = no
    | root "" == ""  = no
    | otherwise      = action
 where
    no = hPutStrLn stderr "operation requires root."

sshClient uid root cmn = whenRoot uid root cmn $ do
    -- /etc/ssh/config/ssh_config    <--  'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts'
    sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config")
    let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig
    sshconfig' <-
        case qs of
            d:ds | elem "/var/cache/kiki/config/ssh_known_hosts" d
                 -> do hPutStrLn stderr "ssh-client already configured."
                       return Nothing
            d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile directive"
                       let hs = " " : "/var/cache/kiki/config/ssh_known_hosts" : drop 1 d
                           stmt = take 1 d ++ hs
                       return $ Just (ps ++ stmt : ds)
            []   -> do -- Unconfigured add fresh directive.
                       hPutStrLn stderr "adding GlobalKnownHostsFile directive"
                       let stmt = L8.unwords ["GlobalKnownHostsFile"
                                             ,  "/var/cache/kiki/config/ssh_known_hosts"
                                             ,  "/etc/ssh/ssh_known_hosts"
                                             ,  "/etc/ssh/ssh_known_hosts2"
                                             ]
                       return $ Just (sshconfig ++ parseSshConfig stmt)
    sshconfig' `deepseq` return () -- force lazy input
    maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig'

    -- /var/cache/kiki/config/ssh_known_hosts        <--  contains known hosts from /root/.gnupg/...
    Kiki.importAndRefresh root cmn

sshServer uid root cmn = whenRoot uid root cmn $ do
    sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/sshd_config")
    let p:gs = groupBy (\_ d -> not $ sshIsDirective "HostKey" d) $ ["#"]:sshconfig
        got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ssh_host_rsa_key" d) gs
    case got of
        _:_ -> do hPutStrLn stderr "ssh-server already configured."
        [] -> do let sshconfig' = drop 1 $ sshconfig ++ [stmt]
                     stmt = ["HostKey", " ", "/var/cache/kiki/config/ssh_host_rsa_key"]
                 hPutStrLn stderr "adding HostKey directive"
                 myWriteFile (root "/etc/ssh/sshd_config") $ unparseSshConfig sshconfig'
    -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/config/ssh_host_ecdsa_key' etc.
    Kiki.importAndRefresh root cmn

strongswan uid root cmn = whenRoot uid root cmn $ do
    -- Parsing as if ssh config, that's not right, but good enough for now.
    ipsecconf <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ipsec.conf")
    let p:gs = groupBy (\_ d -> not $ sshIsDirective "include" d) $ ["#"]:ipsecconf
        got = filter (\(d:ds) -> elem "/var/cache/kiki/config/ipsec.conf" d) gs
    case got of
        _:_ -> do hPutStrLn stderr "ipsec already configured."
        [] -> do let ipsecconf' = drop 1 $ ipsecconf ++ [stmt]
                     stmt = ["include", " ", "/var/cache/kiki/config/ipsec.conf"]
                 hPutStrLn stderr "adding include directive"
                 myWriteFile (root "/etc/ipsec.conf") $ unparseSshConfig ipsecconf'
    -- 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 = L.concat $ take 1 $ drop n words
                     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
    tokenize l = L8.groupBy tokrel l' ++ [comment]
      where (l', comment) = L8.break (=='#') l
    tokrel x y = isSpace x == isSpace y

unparseSshConfig ls = L8.unlines $ map L.concat $ ls

sshSplitAtDirective d sshconfig = break (sshIsDirective d) sshconfig

sshIsDirective d ls =
    case dropWhile isSpaceTok ls of
        g:_ | g == d -> True
        _            -> False
 where
    isSpaceTok "" = True
    isSpaceTok b  = isSpace $ L8.head b


#if !MIN_VERSION_base(4,7,0)
bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True  = t
#endif