summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--FunctorToMaybe.hs64
-rw-r--r--KeyRing.hs96
-rw-r--r--kiki.hs6
3 files changed, 148 insertions, 18 deletions
diff --git a/FunctorToMaybe.hs b/FunctorToMaybe.hs
new file mode 100644
index 0000000..0fd6b7f
--- /dev/null
+++ b/FunctorToMaybe.hs
@@ -0,0 +1,64 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : FunctorToMaybe
4--
5-- Maintainer : joe@jerkface.net
6-- Stability : experimental
7--
8-- Motivation: When parsing a stream of events, it is often desirable to
9-- let certain control events pass-through to the output stream without
10-- interrupting the parse. For example, the conduit package uses
11-- <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
12-- which adds a special command to a stream and the blaze-builder-conduit
13-- package has <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#g:2 conduits> that treat the nullary constructor with special significance.
14--
15-- But for other intermediary conduits, the nullary @Flush@ constructor may
16-- be noise that they should politely preserve in case it is meaningul downstream.
17-- If <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
18-- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to
19-- seperate the noise from the work-product.
20--
21module FunctorToMaybe where
22
23
24-- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the
25-- there may be multiple null elements.
26--
27-- Instances of 'FunctorToMaybe' should satisfy the following laws:
28--
29-- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g)
30--
31class Functor g => FunctorToMaybe g where
32 functorToMaybe :: g a -> Maybe a
33
34
35instance FunctorToMaybe Maybe where
36 functorToMaybe = id
37instance FunctorToMaybe (Either a) where
38 functorToMaybe (Right x) = Just x
39 functorToMaybe _ = Nothing
40
41
42-- | 'functorToEither' is a null-preserving cast.
43--
44-- If @functorToMaybe g == Nothing@, then a casted value is returned with Left.
45-- If @functorToMaybe g == Just a@, then @Right a@ is returned.
46--
47-- Returning to our <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
48-- example, if we define
49--
50-- > instance Flush where
51-- > functorToMaybe Flush = Nothing
52-- > functorToMaybe (Chunk a) = Just a
53--
54-- Now stream processors can use 'functorToEither' to transform any nullary constructors while
55-- while doing its work to transform the data before forwarding it into
56-- <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#v:builderToByteStringFlush builderToByteStringFlush>.
57--
58functorToEither :: FunctorToMaybe f => f a -> Either (f b) a
59functorToEither ga =
60 maybe (Left $ uncast ga)
61 Right
62 (functorToMaybe ga)
63 where
64 uncast = fmap (error "bad FunctorToMaybe instance")
diff --git a/KeyRing.hs b/KeyRing.hs
index 39bff4c..b223ee7 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -9,6 +9,7 @@ import Data.Maybe
9import Data.Char 9import Data.Char
10import Data.List 10import Data.List
11import Data.OpenPGP 11import Data.OpenPGP
12import Data.Functor
12import Control.Applicative ( (<$>) ) 13import Control.Applicative ( (<$>) )
13import System.Directory ( getHomeDirectory, doesFileExist ) 14import System.Directory ( getHomeDirectory, doesFileExist )
14import Control.Arrow ( first, second ) 15import Control.Arrow ( first, second )
@@ -17,6 +18,7 @@ import Data.ByteString.Lazy ( ByteString )
17import Text.Show.Pretty as PP ( ppShow ) 18import Text.Show.Pretty as PP ( ppShow )
18import qualified Data.Map as Map 19import qualified Data.Map as Map
19 20
21import FunctorToMaybe
20import DotLock 22import DotLock
21 23
22data HomeDir = 24data HomeDir =
@@ -51,13 +53,29 @@ data KeyRingData a = KeyRingData
51 53
52todo = error "unimplemented" 54todo = error "unimplemented"
53 55
54data KikiResult = KikiSuccess | FailedToLock [FilePath] 56data KikiCondition a = KikiSuccess a | FailedToLock [FilePath]
55 57
56{- 58#define TRIVIAL(OP) fmap _ (OP) = OP
57newtype KeyRing a = KeyRing 59instance Functor KikiCondition where
58 { krAction :: KeyRingData b -> IO a 60 fmap f (KikiSuccess a) = KikiSuccess (f a)
61 TRIVIAL( FailedToLock x )
62instance FunctorToMaybe KikiCondition where
63 functorToMaybe (KikiSuccess a) = Just a
64 functorToMaybe _ = Nothing
65
66data KikiReportAction =
67 NewPacket String
68 | MissingPacket String
69 | ExportedSubkey
70 | GeneratedSubkeyFile
71 | NewWalletKey String
72 | YieldSignature
73 | YieldSecretKeyPacket String
74
75data KikiResult a = KikiResult
76 { kikiCondition :: KikiCondition a
77 , kikiReport :: [ (FilePath, KikiReportAction) ]
59 } 78 }
60-}
61 79
62empty = KeyRingData { filesToLock = [] 80empty = KeyRingData { filesToLock = []
63 , homeSpec = Nothing 81 , homeSpec = Nothing
@@ -66,13 +84,7 @@ empty = KeyRingData { filesToLock = []
66 , walletFiles = [] 84 , walletFiles = []
67 } 85 }
68 86
69{- 87runKeyRing :: KeyRingData a -> IO (KikiResult a)
70runKeyRing :: KeyRing () -> IO a
71runKeyRing keyring = krAction keyring empty
72-}
73
74
75runKeyRing :: KeyRingData a -> IO KikiResult
76runKeyRing keyring = do 88runKeyRing keyring = do
77 (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring) 89 (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
78 let tolocks = map resolve (filesToLock keyring) 90 let tolocks = map resolve (filesToLock keyring)
@@ -87,21 +99,23 @@ runKeyRing keyring = do
87 else dotlock_destroy lk >> return Nothing 99 else dotlock_destroy lk >> return Nothing
88 return (v,f) 100 return (v,f)
89 let (lked, map snd -> failed) = partition (isJust . fst) lks 101 let (lked, map snd -> failed) = partition (isJust . fst) lks
90 ret = if null failed then KikiSuccess else FailedToLock failed 102 ret = if null failed then KikiSuccess () else FailedToLock failed
91 103
92 case ret of 104 ret <- case functorToEither ret of
93 KikiSuccess -> kaction keyring KeyRingRuntime 105 Right {} -> do
106 a <- kaction keyring KeyRingRuntime
94 { rtPubring = pubring 107 { rtPubring = pubring
95 , rtSecring = secring 108 , rtSecring = secring
96 , rtRings = secring:pubring:keyringFiles keyring 109 , rtRings = secring:pubring:keyringFiles keyring
97 , rtWallets = walletFiles keyring 110 , rtWallets = walletFiles keyring
98 , rtGrip = grip0 111 , rtGrip = grip0
99 } 112 }
100 _ -> return undefined 113 return (KikiSuccess a)
114 Left err -> return err
101 115
102 forM_ lked $ \(Just lk, fname) -> do dotlock_release lk 116 forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
103 dotlock_destroy lk 117 dotlock_destroy lk
104 return ret 118 return KikiResult { kikiCondition = ret, kikiReport = [] }
105 119
106parseOptionFile fname = do 120parseOptionFile fname = do
107 xs <- fmap lines (readFile fname) 121 xs <- fmap lines (readFile fname)
@@ -358,3 +372,49 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
358 mergeSubSig n sig Nothing = error $ 372 mergeSubSig n sig Nothing = error $
359 "Unable to merge subkey signature: "++(words (show sig) >>= take 1) 373 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
360 374
375data Kiki a = Kiki
376
377goHome :: Maybe FilePath -> Kiki ()
378goHome = todo
379
380syncRing :: InputFile -> Kiki ()
381syncRing = todo
382
383syncSubKey :: String -> FilePath -> String -> Kiki ()
384syncSubKey usage path cmd = todo
385
386syncWallet :: FilePath -> Kiki ()
387syncWallet = todo
388
389usePassphraseFD :: Int -> Kiki ()
390usePassphraseFD = todo
391
392importAll :: Kiki ()
393importAll = todo
394
395importAllAuthentic :: Kiki ()
396importAllAuthentic = todo
397
398signSelfAuthorized :: Kiki ()
399signSelfAuthorized = todo
400
401showIdentity :: Message -> String
402showIdentity = todo
403
404identities :: Kiki [Message]
405identities = todo
406
407currentIdentity :: Kiki Message
408currentIdentity = todo
409
410identityBySpec :: String -> Kiki Message
411identityBySpec = todo
412
413identityBySSHKey :: String -> Kiki Message
414identityBySSHKey = todo
415
416keyBySpec :: String -> Kiki Packet
417keyBySpec = todo
418
419walletInputFormat :: Packet -> String
420walletInputFormat = todo
diff --git a/kiki.hs b/kiki.hs
index 47d9bdb..cabb721 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1592,6 +1592,12 @@ doBTCImport doDecrypt db (ms,subspec,content) = do
1592 $ error "Key specification is ambiguous." 1592 $ error "Key specification is ambiguous."
1593 doImportG doDecrypt db m0 tag "" key 1593 doImportG doDecrypt db m0 tag "" key
1594 1594
1595doImport
1596 :: Ord k =>
1597 (Packet -> IO (Maybe Packet))
1598 -> Map.Map k KeyData
1599 -> ([Char], Maybe [Char], [k], t)
1600 -> IO (Map.Map k KeyData)
1595doImport doDecrypt db (fname,subspec,ms,_) = do 1601doImport doDecrypt db (fname,subspec,ms,_) = do
1596 let fetchkey = readKeyFromFile False "PEM" fname 1602 let fetchkey = readKeyFromFile False "PEM" fname
1597 let error s = do 1603 let error s = do