path: root/testkiki/testkiki.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
#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 Data.List
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)
import System.IO.Unsafe (unsafePerformIO)
import ProcessUtils
import Data.Bool

#if !MIN_VERSION_base(4,7,0)
setEnv k v = System.Posix.Env.setEnv k v True
unsetEnv = System.Posix.Env.unsetEnv
bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True  = t
#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

{-# NOINLINE didFirstEportSecret #-}
didFirstEportSecret = unsafePerformIO $ newIORef False

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

    -- **** 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
            when (b && c) $ writeIORef didInit3 True
            (b,c) `shouldBe` (True,True)

    describe "kiki export-secret --pems" $ 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
          bDidInit3 <-readIORef didInit3
          if not bDidInit3 then skipThisTest else 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
            when (and exists) $ writeIORef didFirstEportSecret True
            exists `shouldBe` replicate (length files) True

        it "does not modify mtime nor SHA1 of GNUPGHOME keyrings" $ do
          bDidFirstExportSecret <- readIORef didFirstEportSecret
          if not bDidFirstExportSecret then skipThisTest else 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 "warns on stderr when filenames end with .pub" $ do
            pendingWith "TODO: Not implemented."
        it "fails when public keys in existing PEM files do not match" $ do
            pendingWith "TODO: Not implemented."
        it "updates public pem files to private ones when told to do so" $ do
            pendingWith "TODO: Not implemented."


    describe "kiki export-public --pems" $ do
        didExportPublic <- runIO $ newIORef False
        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
          bDidInit3 <-readIORef didInit3
          if not bDidInit3 then skipThisTest else 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
            when (and exists) $ writeIORef didExportPublic True
            exists `shouldBe` replicate (length files) True

        it "does not modify mtime nor SHA1 of GNUPGHOME keyrings" $ do
          bDidInit3 <-readIORef didInit3
          if not bDidInit3 then skipThisTest else 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 "always makes strictly smaller files than export-secret" $ do
          bDidFirstExportSecret <-readIORef didFirstEportSecret
          if not bDidFirstExportSecret then skipThisTest else 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

    -- **** cokiki tests *****
    describe "cokiki ssh-client" $ do
        it "modifies system ssh configuration to respect /var/cache/kiki/ssh_known_hosts." $
          onlyIf didInit3 $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                cfg = cfg' { gnupghome = gnuhome }
                etcFile = chroot cfg </> "etc" </> "ssh" </> "ssh_config"
                etcFileBS = B.pack etcFile
            -- dump stderr here
            withErrFile (takeDirectory (chroot cfg)) $ \myStdErr -> do
                -- initialize config file with actual systems
                bNotHere <- not <$> doesFileExist etcFile
                when bNotHere $ do
                    createDirectoryIfMissing True (takeDirectory etcFile)
                    copyFile "/etc/ssh/ssh_config" etcFile
                -- copy ssh_config to ssh_config.old, preserving timestamps
                (mtime0,etcFile0) <- saveFileInfo etcFile
                let hasSubStr file x =
                      doesFileExist file >>= 
                          (bool (return False) $ B.isPrefixOf x . snd . B.breakSubstring x <$> B.readFile file)
                -- does it already mention /var/cache/kiki/ssh_known_hosts? expect not 
                subStr0 <- etcFileBS `hasSubStr` "/var/cache/kiki/ssh_known_hosts"
                cokiki cfg ["ssh-client"] myStdErr
                -- get counts of lines subtracted, and lines added, expect (1,1)
                (lost,gained) <- linesSubtractedAndAdded etcFile
                -- did Sha1 change? expect it did
                bChanged <- compareSha1 etcFile
                -- does it mention /var/cache/kiki/ssh_known_hosts now? expect it does
                subStr <- etcFileBS `hasSubStr` "/var/cache/kiki/ssh_known_hosts"
                -- new mtime
                mtime <- getModificationTime etcFile
                (lost,gained,bChanged,(subStr0,subStr),compare mtime mtime0) `shouldBe` (1,1,True,(False,True),GT)

    describe "cokiki ssh-server" $ do
        it "modifies system ssh config to use /var/cache/kiki/ssh_host_rsa_key." $
          onlyIf didInit3 $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                cfg = cfg' { gnupghome = gnuhome }
            -- dump stderr here
            withErrFile (takeDirectory (chroot cfg)) $ \myStdErr -> do
                cokiki cfg ["ssh-server"] myStdErr
                pending

    describe "cokiki strongswan" $ do
        it "modifies /etc/ipsec.conf to include settings from /var/cache/kiki/ipsec.conf." $ do
          onlyIf didInit3 $ do
            let cfg' = appendpaths tkConfig "3"
                home = chroot cfg' </> "root"
                gnuhome = home </> ".gnupg"
                cfg = cfg' { gnupghome = gnuhome }
            -- dump stderr here
            withErrFile (takeDirectory (chroot cfg)) $ \myStdErr -> do
                cokiki cfg ["strongswan"] myStdErr
                pending

    where
        onlyIf ref action = do
            b <- readIORef ref
            when b action

        skipThisTest = pendingWith "SKIPPING due to prior failure."

        freshStdErrHandle tmpdir = openTempFile tmpdir "err.tmp"

        withErrFile :: FilePath -> (Handle -> IO ()) -> IO ()
        withErrFile dir action = do
            len <- (+1) . length <$> getCurrentDirectory
            -- dump stderr here
            bracket (freshStdErrHandle dir)
                    (\(_,h) -> hClose h) $ \(errfile,myStdErr) ->
              flip catch (\(e::SomeException) -> (do
                                b <- hIsOpen myStdErr
                                x <- if b then try $ do
                                                x' <- hGetContents myStdErr
                                                hClose myStdErr
                                                return x'
                                          else try $ readFile errfile :: IO (Either SomeException String)
                                let e' = show e
                                let showR (Right x) = show x
                                    showR _ = ""
                                if ("Pending" `isPrefixOf` e'
                                   || "HUnit" `isPrefixOf` e') then throw e
                                                               else return (showR x,show e) 
                            ) `shouldReturn` (drop len errfile,"EXCEPTION")) $ action myStdErr

        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 eH = do
            let args' = args ++ ["--chroot=" ++ chroot config, "--homedir=" ++ gnupghome config]
            readProcessWithErrorH "./dist/build/kiki/kiki" args' "" eH

        -- 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
                                     }



saveFileInfo :: FilePath -> IO (UTCTime,FilePath)
saveFileInfo file = do
    mtime <- getModificationTime file
    let folder = takeDirectory file
        fileDotOld = file ++ ".old"
    readProcess "cp" ["-aR",file,fileDotOld] ""
    return (mtime,fileDotOld)

compareSha1 :: FilePath -> IO Bool
compareSha1 file = do
    let folder = takeDirectory file
        fileDotOld = file ++ ".old"
    hash1 <- hash <$> B.readFile fileDotOld
    hash2 <- hash <$> B.readFile file
    return (hash1 == hash2)

getMTimes :: FilePath -> IO (UTCTime, UTCTime)
getMTimes file = (,) <$> getModificationTime oldfile <*> getModificationTime file
    where oldfile = file ++ ".old"

getLineCounts :: FilePath -> IO (Int, Int)
getLineCounts file = (,) <$> l oldfile <*> l file
    where oldfile = file ++ ".old"
          l x = length . B.lines <$> B.readFile x

linesSubtractedAndAdded :: FilePath -> IO (Int,Int)
linesSubtractedAndAdded file = counts <$> readPipe [("diff",["-u",oldfile,file]),("sed",["-n","4,$ p"])] ""
    where oldfile = file ++ ".old"
          counts x = ( length $ filter ("-" `isPrefixOf`) (lines x)
                     , length $ filter ("+" `isPrefixOf`) (lines x) )

saveOutputOfRun :: FilePath -> IO String -> IO ((FilePath -> IO a) -> (IO a))
saveOutputOfRun fileToFill action = do
    action >>= writeFile (fileToFill ++ ".old")
    return $ \getSomething -> do
                bRanAgain <- doesFileExist fileToFill
                when (not bRanAgain) $ action >>= writeFile fileToFill
                getSomething fileToFill