summaryrefslogtreecommitdiff
path: root/testkiki/testkiki.hs
blob: 7821df7a9ad3928c3c9fca196eb67533aca8b676 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
{-# 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