{-# LANGUAGE CPP #-}
module Kiki where

import Control.Monad
import Control.Applicative
import Data.List
import Data.Maybe
import Data.Ord
import System.Directory
import System.FilePath.Posix
import System.IO
import Data.OpenPGP
import Data.OpenPGP.Util
import qualified Data.Map.Strict as Map
import qualified Codec.Binary.Base64 as Base64
import Data.ASN1.BinaryEncoding
import Data.ASN1.Encoding
import Data.ASN1.Types
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as Char8

import CommandLine
import qualified SSHKey as SSH
import KeyRing

-- |
-- Regenerate /var/cache/kiki
refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
refresh root homepass = do
    let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) }
    KikiResult r report <- runKeyRing $ minimalOp homepass'
    let mroot = case root "" of
                    "/" -> Nothing
                    ""  -> Nothing
                    pth -> Just pth
    case r of
        KikiSuccess rt -> refreshCache rt mroot
        _ -> return () -- XXX: silent fail?

data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }

streaminfo :: StreamInfo
streaminfo = StreamInfo
    { fill = KF_None
    , spill = KF_None
    , typ = KeyRingFile
    , initializer = NoCreate
    , access = AutoAccess
    , transforms = []
    }

minimalOp :: CommonArgsParsed -> KeyRingOperation
minimalOp cap = op
 where
    streaminfo = StreamInfo { fill = KF_None
                            , typ = KeyRingFile
                            , spill = KF_All
                            , initializer = NoCreate
                            , access = AutoAccess
                            , transforms = []
                            }
    op = KeyRingOperation
        { opFiles = Map.fromList $
            [ ( HomeSec, streaminfo { access = Sec })
            , ( HomePub, streaminfo { access = Pub })
            ]
        , opPassphrases = do pfile <- maybeToList (cap_passfd cap)
                             return $ PassphraseSpec Nothing Nothing pfile
        , opTransforms = []
        , opHome = cap_homespec cap
        }


refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
refreshCache rt rootdir = do

    let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth

        write f bs = do
            createDirectoryIfMissing True $ takeDirectory f
            writeFile f bs

    let oname' = do wk <- rtWorkingKey rt
                    -- XXX unnecessary signature check
                    onionNameForContact (keykey wk) (rtKeyDB rt)
        bUnprivileged = False -- TODO
    if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
    let oname = fromMaybe "" oname'
    -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
    -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
    -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"

    -- Finally, export public keys if they do not exist.
    flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
    either warn (write $ mkpath "root/.ssh/id_rsa.pub")
            $ show_ssh' "ssh-client" grip (rtKeyDB rt)
    either warn (write $ mkpath "ssh_host_rsa_key.pub")
        $ show_ssh' "ssh-server" grip (rtKeyDB rt)
    either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
        $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket

    let cs = filter notme (Map.elems $ rtKeyDB rt)
        kk = keykey (fromJust $ rtWorkingKey rt)
        notme kd = keykey (keyPacket kd) /= kk

        installConctact kd = do
            -- The getHostnames command requires a valid cross-signed tor key
            -- for each onion name returned in (_,(ns,_)).
            let (_,(ns,_)) = getHostnames kd
                contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
            flip (maybe $ return ()) contactname $ \contactname -> do

            let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
                their_master = packet $ keyMappedPacket kd
                -- We find all cross-certified ipsec keys for the given cross-certified onion name.
                ipsecs = sortOn (Down . timestamp)
                         $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
            forM_ (take 1 ipsecs) $ \k -> do
            either warn (write $ mkpath cpath) $ pemFromPacket k

    mapM_ installConctact cs


#if !MIN_VERSION_base(4,8,0)
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
    map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
#endif

pemFromPacket k = do
    let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
        der = encodeASN1 DER (toASN1 rsa [])
        qq  = Base64.encode (L.unpack der)
    return $
        writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)

show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket

show_pem' keyspec wkgrip db keyfmt = do
    let s = parseSpec wkgrip keyspec
    flip (maybe . Left $ keyspec ++ ": not found")
         (selectPublicKey s db)
         keyfmt

warn str = hPutStrLn stderr str

show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db

show_ssh' keyspec wkgrip db = do
    let s = parseSpec wkgrip keyspec
    flip (maybe . Left $ keyspec ++ ": not found")
         (selectPublicKey s db)
         $ return . sshblobFromPacket

-- |
-- interpolate %var patterns in a string.
interp vars raw = es >>= interp1
 where
    gs = groupBy (\_ c -> c/='%') raw
    es = dropWhile null $ gobbleEscapes ("":gs)
            where gobbleEscapes :: [String] -> [String]
                  gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
                  gobbleEscapes (g:gs)       = g : gobbleEscapes gs
                  gobbleEscapes []           = []
    interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest
                            where (key,rest) = break (==')') str
    interp1 plain = plain

sshblobFromPacket k = blob
 where
    Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
    bs = SSH.keyblob (n,e)
    blob = Char8.unpack bs

ㄧhomedir = Kiki.CommonArgsParsed
                <$> optional (arg "--homedir")
                <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")

replaceSshServerKeys root cmn = do
    let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) }
        replaceSSH op = op { opFiles = files }
            where
                files = Map.adjust delssh HomeSec
                        $ Map.adjust delssh HomePub
                        $ Map.insert (ArgFile $ root "/etc/ssh/ssh_host_rsa_key") strm $ opFiles op
                strm = streaminfo { typ = PEMFile, spill = KF_Match "ssh-server", access = Sec }
                delssh strm = strm { transforms = DeleteSubkeyByUsage "ssh-server" : transforms strm
                                   , fill = KF_All }
    KikiResult r report <- runKeyRing $ minimalOp homepass'
    case r of
        KikiSuccess rt -> Kiki.refreshCache rt $ case root "" of
                                                    "/" -> Nothing
                                                    ""  -> Nothing
                                                    pth -> Just pth
        err            -> hPutStrLn stderr $ errorString err

ㄧchroot :: Args (FilePath -> FilePath)
ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id

slash :: String -> String -> String
slash "/"    ('/':xs) = '/':xs
slash ""     ('/':xs) = '/':xs
slash ""     xs       = '/':xs
slash (y:ys) xs       = y:slash ys xs