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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module KeyRing where
import System.Environment
import Control.Monad
import Data.Maybe
import Data.Char
import Data.List
import Control.Applicative ( (<$>) )
import System.Directory ( getHomeDirectory, doesFileExist )
import Control.Arrow ( first, second )
import DotLock
data HomeDir =
HomeDir { homevar :: String
, appdir :: String
, optfile_alts :: [String]
}
home = HomeDir
{ homevar = "GNUPGHOME"
, appdir = ".gnupg"
, optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
}
data InputFile = HomeSec | HomePub | ArgFile FilePath
data KeyRingRuntime = KeyRingRuntime
{ rtPubring :: FilePath
, rtSecring :: FilePath
, rtRings :: [FilePath]
, rtWallets :: [FilePath]
, rtGrip :: Maybe String
}
data KeyRingData a = KeyRingData
{ filesToLock :: [InputFile]
, homeSpec :: Maybe String
, kaction :: KeyRingRuntime -> IO a
, keyringFiles :: [FilePath]
, walletFiles :: [FilePath]
}
todo = error "unimplemented"
data KikiResult = KikiSuccess | FailedToLock [FilePath]
{-
newtype KeyRing a = KeyRing
{ krAction :: KeyRingData b -> IO a
}
-}
empty = KeyRingData { filesToLock = []
, homeSpec = Nothing
, kaction = \KeyRingRuntime {} -> return ()
, keyringFiles = []
, walletFiles = []
}
{-
runKeyRing :: KeyRing () -> IO a
runKeyRing keyring = krAction keyring empty
-}
runKeyRing :: KeyRingData a -> IO KikiResult
runKeyRing keyring = do
(homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
let tolocks = map resolve (filesToLock keyring)
where resolve (ArgFile f) = f
resolve HomePub = pubring
resolve HomeSec = secring
lks <- forM tolocks $ \f -> do
lk <- dotlock_create f 0
v <- flip (maybe $ return Nothing) lk $ \lk -> do
e <- dotlock_take lk (-1)
if e==0 then return $ Just lk
else dotlock_destroy lk >> return Nothing
return (v,f)
let (lked, map snd -> failed) = partition (isJust . fst) lks
ret = if null failed then KikiSuccess else FailedToLock failed
case ret of
KikiSuccess -> kaction keyring KeyRingRuntime
{ rtPubring = pubring
, rtSecring = secring
, rtRings = secring:pubring:keyringFiles keyring
, rtWallets = walletFiles keyring
, rtGrip = grip0
}
_ -> return undefined
forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
dotlock_destroy lk
return ret
parseOptionFile fname = do
xs <- fmap lines (readFile fname)
let ys = filter notComment xs
notComment ('#':_) = False
notComment cs = not (all isSpace cs)
return ys
getHomeDir protohome = do
homedir <- envhomedir protohome
flip (maybe (error "Could not determine home directory."))
homedir $ \homedir -> do
-- putStrLn $ "homedir = " ++show homedir
let secring = homedir ++ "/" ++ "secring.gpg"
pubring = homedir ++ "/" ++ "pubring.gpg"
-- putStrLn $ "secring = " ++ show secring
workingkey <- getWorkingKey homedir
return (homedir,secring,pubring,workingkey)
where
envhomedir opt = do
gnupghome <- lookupEnv (homevar home) >>=
\d -> return $ d >>= guard . (/="") >> d
homed <- flip fmap getHomeDirectory $
\d -> fmap (const d) $ guard (d/="")
let homegnupg = (++('/':(appdir home))) <$> homed
let val = (opt `mplus` gnupghome `mplus` homegnupg)
return $ val
-- TODO: rename this to getGrip
getWorkingKey homedir = do
let o = Nothing
h = Just homedir
ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
let optfiles = map (second ((h++"/")++))
(maybe optfile_alts' (:[]) o')
optfile_alts' = zip (False:repeat True) (optfile_alts home)
o' = fmap (False,) o
in filterM (doesFileExist . snd) optfiles
args <- flip (maybe $ return []) ofile $
\(forgive,fname) -> parseOptionFile fname
let config = map (topair . words) args
where topair (x:xs) = (x,xs)
return $ lookup "default-key" config >>= listToMaybe
#if MIN_VERSION_base(4,6,0)
#else
lookupEnv var =
handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif
|
