diff options
Diffstat (limited to 'KeyRing.hs')
-rw-r--r-- | KeyRing.hs | 72 |
1 files changed, 72 insertions, 0 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 #-} | ||
4 | module KeyRing where | ||
5 | |||
6 | import System.Environment | ||
7 | import Control.Monad | ||
8 | import Control.Applicative | ||
9 | import Data.Maybe | ||
10 | import Data.Char | ||
11 | import System.Directory ( getHomeDirectory, doesFileExist ) | ||
12 | import Control.Arrow ( first, second ) | ||
13 | |||
14 | data KeyRing | ||
15 | |||
16 | todo = error "unimplemented" | ||
17 | |||
18 | loadKeys :: (Maybe FilePath) -> IO KeyRing | ||
19 | loadKeys = todo | ||
20 | |||
21 | parseOptionFile 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 | |||
28 | getHomeDir 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 | |||
64 | homevar = "GNUPGHOME" | ||
65 | appdir = ".gnupg" | ||
66 | optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] | ||
67 | |||
68 | #if MIN_VERSION_base(4,6,0) | ||
69 | #else | ||
70 | lookupEnv var = | ||
71 | handleIO_ (return Nothing) $ fmap Just (getEnv var) | ||
72 | #endif | ||