{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
import Control.Applicative
import Control.DeepSeq
import Data.Bool
import Data.Char
import Data.Maybe
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Kiki
import System.Directory
import System.Environment
import System.IO
import System.Posix.User
import CommandLine

usage = unlines
    [ "cokiki <command>"
    , ""
    , "COMMANDS"
    , "  ssh-client"
    , "  ssh-server"
    , "  strongswan"
    ]

ㄧchroot :: Args (FilePath -> FilePath)
ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
 where
    slash :: String -> String -> String
    slash "/"    ('/':xs) = '/':xs
    slash ""     ('/':xs) = '/':xs
    slash ""     xs       = '/':xs
    slash (y:ys) xs       = y:slash ys xs

main = do
    (cmd,args) <- splitAt 1 <$> getArgs
    uid <- getEffectiveUserID
    let whenRoot action
            | uid==0    = action
            | otherwise = hPutStrLn stderr "operation requires root."
    let sel = case cmd of
                ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot <*> Kiki.ㄧhomedir
                ["ssh-server"] -> pure (whenRoot sshServer)
                ["strongswan"] -> pure (whenRoot strongswan)
                _   -> pure $ hPutStr stderr usage
        spec = fancy [("--chroot",1),("--passphrase-fd",1),("--homedir",1)] [] ""
    case runArgs (parseInvocation spec args) sel of
        Left e   -> hPutStrLn stderr $ usageErrorMessage e
        Right io -> io

maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
maybeReadFile path = do
    doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)

sshClient uid root cmn = do
    -- /etc/ssh/ssh_config    <--  'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts'
    sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config")
    let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig
        myWriteFile f bs = do
            hPutStrLn stderr $ "Writing "++f
            -- L8.putStr bs
            L8.writeFile f bs
    sshconfig' <-
        case qs of
            d:ds | elem "/var/cache/kiki/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/ssh_known_hosts" : drop 1 d
                           stmt = take 1 d ++ hs
                       return $ Just (ps ++ stmt : ds)
            []   -> do -- Unconfigured add fresh directive.
                       let stmt = L8.unwords ["GlobalKnownHostsFile"
                                             ,  "/var/cache/kiki/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'

    -- /root/.gnupg/...       <--  contains known hosts from /etc/ssh/ssh_known_hosts
    -- /var/cache/kiki/ssh_known_hosts        <--  contains known hosts from /root/.gnupg/...
    Kiki.replaceSshServerKeys root cmn

sshServer = do
    -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/ssh_host_ecdsa_key' etc.
    return ()

strongswan = do
    -- etc/ipsec.conf    <--  'include /var/cache/kiki/ipsec.conf'
    -- /root/.gnupg/...   <--  contains newly-generated ipsec subkey
    Kiki.refresh id (Kiki.CommonArgsParsed Nothing Nothing)
    -- /var/cache/kiki/ipsec.conf      <--  contains configurations for each remote ipsec host
    -- /var/cache/kiki/ipsec.conf      <--  contains '%default' configuration for this local host
    -- /var/cache/kiki/ipsec.d/certs   <--  contains relevant certs
    -- /var/cache/kiki/ipsec.d/private <--  contains private key


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