path: root/testkiki/testkiki.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE CPP #-}
#if !MIN_VERSION_base(4,7,0)
import qualified System.Posix.Env
#endif
import System.Environment
--import System.Posix.Env.ByteString (getEnv)
import System.Posix.Files
import Test.Hspec
import System.Process
import Control.Exception
import System.Directory
import System.FilePath
import System.Exit
import System.IO
--import System.Posix.ByteString.FilePath
import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.IORef
import Crypto.Hash.SHA1 (hash)

#if !MIN_VERSION_base(4,7,0)
setEnv k v = System.Posix.Env.setEnv k v True
unsetEnv = System.Posix.Env.unsetEnv
#endif

data TestKikiSettings = TKS
        { gnupghome :: FilePath
        , chroot :: FilePath
        }
    deriving (Show,Eq)

main = do
    args <- getArgs
    cwd <- getCurrentDirectory
    let chomp x = takeWhile (/='\n') x
    date <- maybe (return "")
                  (\x -> chomp <$> readProcess x ["+%Y-%m-%d-%H%M%S"] "") =<< findExecutable "date"

    let tdir = cwd </> "TESTS" </> date

    {- -- Remove old TESTS, clean up directory
     - -- XXX: get this to work right with HSpec
     -
     - when (args == ["clean"]) $ do
     -  removeDirectoryRecursive (cwd </> "TESTS")
     -}

    existsAlready <- or <$> (sequence $ map ($ tdir) [doesDirectoryExist,doesFileExist])

    if existsAlready then do
        hPutStrLn stderr ("Path " ++ show tdir ++ " already exists, remove or change working folder to run clean tests.")
        exitFailure
    else do
        let chrootdir    = cwd </> tdir </> "chroot"
            gnupghomedir = "gnupghome"
        createDirectoryIfMissing True chrootdir
        createDirectoryIfMissing True gnupghomedir
        let config = TKS { chroot = chrootdir , gnupghome = gnupghomedir }
        print config
        putStrLn "==="
        doTests config

doTests :: TestKikiSettings -> IO ()
doTests tkConfig = hspec $ do
    {-
    -- Example of shouldThrow
    describe "TODO: error" $
        it "throws an exception" $
            evaluate (error "TODO:testsuite") `shouldThrow` anyException
     -}

    -- **** kiki tests *****
    describe "kiki init" $ do
        it "honors GNUPGHOME environment variable" $ do
            let kiki = kiki'Env cfg
                cfg = appendpaths tkConfig "0"
            (isInfixOf "New packet"  <$> kiki ["init"]) `shouldReturn` True

        it "creates parent directories with --homedir" $ do
            let home = "home" </> "tester"
                cfg = appendpaths tkConfig "1"
                kiki = kiki'Env'And'HomeArg cfg
                        { gnupghome = home </> ".gnupg" }
            output <- kiki ["init"]
            b <- doesDirectoryExist (chroot cfg </> home)
            -- isInfixOf "New packet" output
            b `shouldBe` True

        it "creates new secring honoring GNUPGHOME" $ do
            let cfg = appendpaths tkConfig "2"
            let kiki = kiki'Env'And'HomeArg cfg
            output <- kiki ["init"]
            b <- doesFileExist (chroot cfg </> gnupghome cfg </> "secring.gpg")
            (isInfixOf "New packet" output && b ) `shouldBe` True

        it "creates new secring in /root/.gnupg" $ do
            let cfg = appendpaths tkConfig "3"
            let kiki = kiki'No'Env'No'Home cfg
            unsetEnv "GNUPGHOME"
            createDirectoryIfMissing True (chroot cfg </> "root" </> ".gnupg")
            output <- kiki ["init"]
            let p = (chroot cfg </> "root" </> ".gnupg" </> "secring.gpg")
            b <- doesFileExist p
            let c = isInfixOf "New packet" output
            (b,c) `shouldBe` (True,True)

    describe "kiki export-secret" $ do

        t <- runIO $ getPOSIXTime
        mtime1 <- runIO $ newIORef (posixSecondsToUTCTime t)
        mtime2 <- runIO $ newIORef (posixSecondsToUTCTime t)
        hash1 <- runIO $ newIORef ""
        hash2 <- runIO $ newIORef ""

        it "creates external pem files which do not exist" $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                cfg = cfg' { gnupghome = gnuhome }
                kiki = kiki'Env'NoChroot cfg
                secs = home </> "secs"
                tags = [ "tor", "ssh-client", "ssh-server", "ipsec" ]
                files = map ((++ ".sec") . (secs </>)) tags
                extraArgs = zipWith (\x y -> concat [x,"=",y]) tags files

            tsec0 <- getModificationTime (gnuhome </> "secring.gpg")
            tpub0 <- getModificationTime (gnuhome </> "pubring.gpg")

            writeIORef mtime1 tsec0
            writeIORef mtime2 tpub0

            hsec0 <- hash <$> B.readFile (gnuhome </> "secring.gpg")
            hpub0 <- hash <$> B.readFile (gnuhome </> "pubring.gpg")

            writeIORef hash1 hsec0
            writeIORef hash2 hpub0

            createDirectoryIfMissing True secs
            kiki ("export-secret":extraArgs)
            exists <- mapM doesFileExist files
            exists `shouldBe` replicate (length files) True

        it "does not modify mtime nor SHA1 of GNUPGHOME keyrings" $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
            -- mtimes
            tsec0 <- readIORef mtime1
            tpub0 <- readIORef mtime2
            tsec <- getModificationTime (gnuhome </> "secring.gpg")
            tpub <- getModificationTime (gnuhome </> "pubring.gpg")
            -- SHA1s
            hsec0 <- readIORef hash1
            hpub0 <- readIORef hash2
            hsec <- hash <$> B.readFile (gnuhome </> "secring.gpg")
            hpub <- hash <$> B.readFile (gnuhome </> "pubring.gpg")
            ([ tsec , tpub], hsec == hsec0, hpub == hpub0 ) `shouldBe` ([ tsec0,tpub0],True,True)

        it "fails when public keys in existing PEM files do not match" $ do
            pending
        it "updates public pem files to private ones when told to" $ do
            pending


    describe "kiki export-public" $ do

        t <- runIO $ getPOSIXTime
        mtime1 <- runIO $ newIORef (posixSecondsToUTCTime t)
        mtime2 <- runIO $ newIORef (posixSecondsToUTCTime t)
        hash1 <- runIO $ newIORef ""
        hash2 <- runIO $ newIORef ""

        it "creates external pem files which do not exist" $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                cfg = cfg' { gnupghome = gnuhome }
                kiki = kiki'Env'NoChroot cfg
                pubs = home </> "pubs"
                tags = [ "tor", "ssh-client", "ssh-server", "ipsec" ]
                files = map ((++ ".pub") . (pubs </>)) tags
                extraArgs = zipWith (\x y -> concat [x,"=",y]) tags files

            tsec0 <- getModificationTime (gnuhome </> "secring.gpg")
            tpub0 <- getModificationTime (gnuhome </> "pubring.gpg")
            writeIORef mtime1 tsec0 -- <$> getModificationTime (gnuhome </> "secring.gpg")
            writeIORef mtime2 tpub0 -- <$> getModificationTime (gnuhome </> "pubring.gpg")

            hashSec0 <- hash <$> B.readFile (gnuhome </> "secring.gpg")
            hashPub0 <- hash <$> B.readFile (gnuhome </> "pubring.gpg")

            writeIORef hash1 hashSec0 -- . hash <$> B.readFile (gnuhome </> "secring.gpg")
            writeIORef hash2 hashPub0 -- . hash <$> B.readFile (gnuhome </> "pubring.gpg")

            createDirectoryIfMissing True pubs
            kiki ("export-public":extraArgs)
            exists <- mapM doesFileExist files
            exists `shouldBe` replicate (length files) True

        it "does not modify mtime nor SHA1 of GNUPGHOME keyrings" $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
            -- mtimes
            tsec0 <- readIORef mtime1
            tpub0 <- readIORef mtime2
            tsec <- getModificationTime (gnuhome </> "secring.gpg")
            tpub <- getModificationTime (gnuhome </> "pubring.gpg")
            -- SHA1s
            hsec0 <- readIORef hash1
            hpub0 <- readIORef hash2
            hsec <- hash <$> B.readFile (gnuhome </> "secring.gpg")
            hpub <- hash <$> B.readFile (gnuhome </> "pubring.gpg")
            ([ tsec , tpub], hsec == hsec0, hpub == hpub0 ) `shouldBe` ([ tsec0,tpub0],True,True)

        it "creates public PEM files smaller than exported private PEMs" $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                pubs = home </> "pubs"
                secs = home </> "secs"
                tags = [ "tor", "ssh-client", "ssh-server", "ipsec" ]
                filesPub = map ((++ ".pub") . (pubs </>)) tags
                filesSec = map ((++ ".sec") . (secs </>)) tags
            lengthsPub <- map B.length <$> mapM (B.readFile) filesPub
            lengthsSec <- map B.length <$> mapM (B.readFile) filesSec
            let compares = zipWith (<) lengthsPub lengthsSec
            compares `shouldBe` replicate (length tags) True

        it "does not leak secret data from GNUPGHOME keyrings" $ do
            pending

    -- **** cokiki tests *****
    describe "cokiki ssh-client" $ do
        it "modifies system ssh configuration to respect /var/cache/kiki/ssh_known_hosts" $ do
            pending
        it "sets kiki ssh-server key to /etc/ssh/ssh_host_rsa_key" $ do
            pending
        it "replaces existing ssh-server key with /etc/ssh/ssh_hosts_rsa_key" $ do
            pending
        it "refreshes /var/cache/kiki/*" $ do
            pending

    describe "cokiki ssh-server" $ do
        it "does something" $
            pending

    describe "cokiki strongswan" $ do
        it "does something" $
            pending
    where
        kiki'Env config args = do
            setEnv "GNUPGHOME" (chroot config </> gnupghome config)
            let args' = args ++ ["--chroot=" ++ chroot config]
            r <- readProcess "./dist/build/kiki/kiki" args' ""
            unsetEnv "GNUPGHOME"
            return r

        kiki'Env'NoChroot config args = do
            setEnv "GNUPGHOME" (chroot config </> gnupghome config)
            r <- readProcess "./dist/build/kiki/kiki" args ""
            unsetEnv "GNUPGHOME"
            return r

        kiki'No'Env'No'Home config args = do
            let args' = args ++ ["--chroot=" ++ chroot config]
            readProcess "./dist/build/kiki/kiki" args' ""

        kiki'No'Env config args = do
            let args' = args ++ ["--chroot=" ++ chroot config,"--homedir=" ++ gnupghome config]
            readProcess "./dist/build/kiki/kiki" args' ""

        kiki'Env'And'HomeArg config args = do
            setEnv "GNUPGHOME" (chroot config </> gnupghome config)
            let args' = args ++ ["--chroot=" ++ chroot config,"--homedir=" ++ gnupghome config]
            r <- readProcess "./dist/build/kiki/kiki" args' ""
            unsetEnv "GNUPGHOME"
            return r

        cokiki config args = do
            let args' = args ++ ["--chroot=" ++ chroot config, "--homedir=" ++ gnupghome config]
            readProcess "./dist/build/kiki/kiki" args' ""

        -- UTILS
        isInfixOf sub str = let (_,match) = B.breakSubstring (B.pack sub) (B.pack str)
                                in not (B.null match)

        appendpaths config str = TKS { gnupghome = gnupghome config ++ str
                                     , chroot = chroot config ++ str
                                     }