diff options
Diffstat (limited to 'KeyRing.hs')
-rw-r--r-- | KeyRing.hs | 82 |
1 files changed, 75 insertions, 7 deletions
@@ -1,15 +1,18 @@ | |||
1 | {-# LANGUAGE CPP #-} | 1 | {-# LANGUAGE CPP #-} |
2 | {-# LANGUAGE EmptyDataDecls #-} | ||
3 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
3 | {-# LANGUAGE ViewPatterns #-} | ||
4 | module KeyRing where | 4 | module KeyRing where |
5 | 5 | ||
6 | import System.Environment | 6 | import System.Environment |
7 | import Control.Monad | 7 | import Control.Monad |
8 | import Control.Applicative | ||
9 | import Data.Maybe | 8 | import Data.Maybe |
10 | import Data.Char | 9 | import Data.Char |
11 | import System.Directory ( getHomeDirectory, doesFileExist ) | 10 | import Data.List |
12 | import Control.Arrow ( first, second ) | 11 | import Control.Applicative ( (<$>) ) |
12 | import System.Directory ( getHomeDirectory, doesFileExist ) | ||
13 | import Control.Arrow ( first, second ) | ||
14 | |||
15 | import DotLock | ||
13 | 16 | ||
14 | data HomeDir = | 17 | data HomeDir = |
15 | HomeDir { homevar :: String | 18 | HomeDir { homevar :: String |
@@ -23,12 +26,77 @@ home = HomeDir | |||
23 | , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] | 26 | , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] |
24 | } | 27 | } |
25 | 28 | ||
26 | data KeyRing | 29 | data InputFile = HomeSec | HomePub | ArgFile FilePath |
30 | |||
31 | data KeyRingRuntime = KeyRingRuntime | ||
32 | { rtPubring :: FilePath | ||
33 | , rtSecring :: FilePath | ||
34 | , rtRings :: [FilePath] | ||
35 | , rtWallets :: [FilePath] | ||
36 | , rtGrip :: Maybe String | ||
37 | } | ||
38 | |||
39 | data KeyRingData a = KeyRingData | ||
40 | { filesToLock :: [InputFile] | ||
41 | , homeSpec :: Maybe String | ||
42 | , kaction :: KeyRingRuntime -> IO a | ||
43 | , keyringFiles :: [FilePath] | ||
44 | , walletFiles :: [FilePath] | ||
45 | } | ||
27 | 46 | ||
28 | todo = error "unimplemented" | 47 | todo = error "unimplemented" |
29 | 48 | ||
30 | loadKeys :: (Maybe FilePath) -> IO KeyRing | 49 | data KikiResult = KikiSuccess | FailedToLock [FilePath] |
31 | loadKeys = todo | 50 | |
51 | {- | ||
52 | newtype KeyRing a = KeyRing | ||
53 | { krAction :: KeyRingData b -> IO a | ||
54 | } | ||
55 | -} | ||
56 | |||
57 | empty = KeyRingData { filesToLock = [] | ||
58 | , homeSpec = Nothing | ||
59 | , kaction = \KeyRingRuntime {} -> return () | ||
60 | , keyringFiles = [] | ||
61 | , walletFiles = [] | ||
62 | } | ||
63 | |||
64 | {- | ||
65 | runKeyRing :: KeyRing () -> IO a | ||
66 | runKeyRing keyring = krAction keyring empty | ||
67 | -} | ||
68 | |||
69 | |||
70 | runKeyRing :: KeyRingData a -> IO KikiResult | ||
71 | runKeyRing keyring = do | ||
72 | (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring) | ||
73 | let tolocks = map resolve (filesToLock keyring) | ||
74 | where resolve (ArgFile f) = f | ||
75 | resolve HomePub = pubring | ||
76 | resolve HomeSec = secring | ||
77 | lks <- forM tolocks $ \f -> do | ||
78 | lk <- dotlock_create f 0 | ||
79 | v <- flip (maybe $ return Nothing) lk $ \lk -> do | ||
80 | e <- dotlock_take lk (-1) | ||
81 | if e==0 then return $ Just lk | ||
82 | else dotlock_destroy lk >> return Nothing | ||
83 | return (v,f) | ||
84 | let (lked, map snd -> failed) = partition (isJust . fst) lks | ||
85 | ret = if null failed then KikiSuccess else FailedToLock failed | ||
86 | |||
87 | case ret of | ||
88 | KikiSuccess -> kaction keyring KeyRingRuntime | ||
89 | { rtPubring = pubring | ||
90 | , rtSecring = secring | ||
91 | , rtRings = secring:pubring:keyringFiles keyring | ||
92 | , rtWallets = walletFiles keyring | ||
93 | , rtGrip = grip0 | ||
94 | } | ||
95 | _ -> return undefined | ||
96 | |||
97 | forM_ lked $ \(Just lk, fname) -> do dotlock_release lk | ||
98 | dotlock_destroy lk | ||
99 | return ret | ||
32 | 100 | ||
33 | parseOptionFile fname = do | 101 | parseOptionFile fname = do |
34 | xs <- fmap lines (readFile fname) | 102 | xs <- fmap lines (readFile fname) |