summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs72
-rw-r--r--kiki.hs48
2 files changed, 74 insertions, 46 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
new file mode 100644
index 0000000..4058585
--- /dev/null
+++ b/KeyRing.hs
@@ -0,0 +1,72 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE TupleSections #-}
4module KeyRing where
5
6import System.Environment
7import Control.Monad
8import Control.Applicative
9import Data.Maybe
10import Data.Char
11import System.Directory ( getHomeDirectory, doesFileExist )
12import Control.Arrow ( first, second )
13
14data KeyRing
15
16todo = error "unimplemented"
17
18loadKeys :: (Maybe FilePath) -> IO KeyRing
19loadKeys = todo
20
21parseOptionFile fname = do
22 xs <- fmap lines (readFile fname)
23 let ys = filter notComment xs
24 notComment ('#':_) = False
25 notComment cs = not (all isSpace cs)
26 return ys
27
28getHomeDir protohome = do
29 homedir <- envhomedir protohome
30 flip (maybe (error "Could not determine home directory."))
31 homedir $ \homedir -> do
32 -- putStrLn $ "homedir = " ++show homedir
33 let secring = homedir ++ "/" ++ "secring.gpg"
34 pubring = homedir ++ "/" ++ "pubring.gpg"
35 -- putStrLn $ "secring = " ++ show secring
36 workingkey <- getWorkingKey homedir
37 return (homedir,secring,pubring,workingkey)
38 where
39 envhomedir opt = do
40 gnupghome <- lookupEnv homevar >>=
41 \d -> return $ d >>= guard . (/="") >> d
42 home <- flip fmap getHomeDirectory $
43 \d -> fmap (const d) $ guard (d/="")
44 let homegnupg = (++('/':appdir)) <$> home
45 let val = (opt `mplus` gnupghome `mplus` homegnupg)
46 return $ val
47
48 -- TODO: rename this to getGrip
49 getWorkingKey homedir = do
50 let o = Nothing
51 h = Just homedir
52 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
53 let optfiles = map (second ((h++"/")++))
54 (maybe optfile_alts' (:[]) o')
55 optfile_alts' = zip (False:repeat True) optfile_alts
56 o' = fmap (False,) o
57 in filterM (doesFileExist . snd) optfiles
58 args <- flip (maybe $ return []) ofile $
59 \(forgive,fname) -> parseOptionFile fname
60 let config = map (topair . words) args
61 where topair (x:xs) = (x,xs)
62 return $ lookup "default-key" config >>= listToMaybe
63
64homevar = "GNUPGHOME"
65appdir = ".gnupg"
66optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
67
68#if MIN_VERSION_base(4,6,0)
69#else
70lookupEnv var =
71 handleIO_ (return Nothing) $ fmap Just (getEnv var)
72#endif
diff --git a/kiki.hs b/kiki.hs
index f265add..d903b0f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -81,6 +81,8 @@ import LengthPrefixedBE
81import Data.Binary.Put (putWord32be,runPut,putByteString) 81import Data.Binary.Put (putWord32be,runPut,putByteString)
82import Data.Binary.Get (runGet) 82import Data.Binary.Get (runGet)
83 83
84import KeyRing
85
84-- instance Default S.ByteString where def = S.empty 86-- instance Default S.ByteString where def = S.empty
85 87
86-- DER-encoded elliptic curve ids 88-- DER-encoded elliptic curve ids
@@ -739,13 +741,6 @@ unlockFiles lks = forM_ lks $ \(lk,f) -> do
739 -- warn $ "unlocking "++show f 741 -- warn $ "unlocking "++show f
740 dotlock_release lk 742 dotlock_release lk
741 743
742parseOptionFile fname = do
743 xs <- fmap lines (readFile fname)
744 let ys = filter notComment xs
745 notComment ('#':_) = False
746 notComment cs = not (all isSpace cs)
747 return ys
748
749{- 744{-
750options_from_file :: 745options_from_file ::
751 (forall a. [String] -> Term a -> IO (Either EvalExit a)) 746 (forall a. [String] -> Term a -> IO (Either EvalExit a))
@@ -2564,45 +2559,6 @@ main = do
2564 2559
2565 return() 2560 return()
2566 where 2561 where
2567 envhomedir opt = do
2568 gnupghome <- lookupEnv homevar >>=
2569 \d -> return $ d >>= guard . (/="") >> d
2570 home <- flip fmap getHomeDirectory $
2571 \d -> fmap (const d) $ guard (d/="")
2572 let homegnupg = (++('/':appdir)) <$> home
2573 let val = (opt `mplus` gnupghome `mplus` homegnupg)
2574 return $ val
2575
2576 homevar = "GNUPGHOME"
2577 appdir = ".gnupg"
2578 optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
2579
2580 getHomeDir protohome = do
2581 homedir <- envhomedir protohome
2582 flip (maybe (error "Could not determine home directory."))
2583 homedir $ \homedir -> do
2584 -- putStrLn $ "homedir = " ++show homedir
2585 let secring = homedir ++ "/" ++ "secring.gpg"
2586 pubring = homedir ++ "/" ++ "pubring.gpg"
2587 -- putStrLn $ "secring = " ++ show secring
2588 workingkey <- getWorkingKey homedir
2589 return (homedir,secring,pubring,workingkey)
2590
2591 -- TODO: rename this to getGrip
2592 getWorkingKey homedir = do
2593 let o = Nothing
2594 h = Just homedir
2595 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
2596 let optfiles = map (second ((h++"/")++))
2597 (maybe optfile_alts' (:[]) o')
2598 optfile_alts' = zip (False:repeat True) optfile_alts
2599 o' = fmap (False,) o
2600 in filterM (doesFileExist . snd) optfiles
2601 args <- flip (maybe $ return []) ofile $
2602 \(forgive,fname) -> parseOptionFile fname
2603 let config = map (topair . words) args
2604 where topair (x:xs) = (x,xs)
2605 return $ lookup "default-key" config >>= listToMaybe
2606 2562
2607 {- 2563 {-
2608 getPGPEnviron cmd = do 2564 getPGPEnviron cmd = do