From b0e298c9203bb0b901dddc398ce00c96ff12071d Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 21 Apr 2014 20:36:12 -0400 Subject: removed experimental code --- ExperimentalCruft.hs | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++ KeyRing.hs | 202 ++------------------------------------------------- 2 files changed, 204 insertions(+), 197 deletions(-) create mode 100644 ExperimentalCruft.hs diff --git a/ExperimentalCruft.hs b/ExperimentalCruft.hs new file mode 100644 index 0000000..0c60731 --- /dev/null +++ b/ExperimentalCruft.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE ExistentialQuantification #-} +module ExperimentalCruft where + +import KeyRing + +data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a) + +data Kiki a = + SinglePass { passInfo :: KeyRingOperation + , rtAction :: KeyRingAction a } + | forall b. + MultiPass { passInfo :: KeyRingOperation + , passAction :: KeyRingAction b + , nextPass :: Kiki (b -> a) + } + + + +evalAction :: KeyRingRuntime -> KeyRingAction a -> a +evalAction rt (KeyRingAction v) = v +evalAction rt (RunTimeAction g) = g rt + +instance Monad KeyRingAction where + return x = KeyRingAction x + m >>= g = case m of + KeyRingAction v -> g v + RunTimeAction f -> RunTimeAction $ \rt -> evalAction rt (g $ f rt) + +instance Functor KeyRingAction where + fmap g (KeyRingAction v) = KeyRingAction $ g v + fmap g (RunTimeAction f) = RunTimeAction $ \rt -> g (f rt) + +{- +argOut :: (KeyRingAction (a -> b)) -> a -> KeyRingAction b +argOut = todo +argIn :: (a -> KeyRingAction b) -> KeyRingAction (a->b) +-} + +{- +fmapWithRT :: (a -> KeyRingAction b) -> Kiki a -> Kiki b +fmapWithRT g k@(SinglePass {}) = k { rtAction = action } + where + action = rtAction k >>= g +fmapWithRT g (MultiPass p atn next) = MultiPass p atn next' + where + next' = fmapWithRT g' next {- next :: Kiki (x -> a) -} + -- g' :: ( (x->a) -> KeyRingAction b) + g' h = RunTimeAction $ + \rt x -> case g (h x) of + KeyRingAction v -> v + RunTimeAction f -> f rt +-} + +fmapWithRT :: KeyRingAction (a -> b) -> Kiki a -> Kiki b +fmapWithRT g (SinglePass pass atn) = SinglePass pass atn' + where + atn' = g >>= flip fmap atn +fmapWithRT g (MultiPass p atn next) = MultiPass p atn next' + where + next' = fmapWithRT g' next + g' = fmap (\gf h -> gf . h) g + +instance Functor Kiki where + fmap f k = fmapWithRT (return f) k + +{- +instance Monad Kiki where + return x = SinglePass todo (return x) + k >>= f = kjoin $ fmap f k + +kikiAction :: Kiki a -> KeyRingAction a +kikiAction (SinglePass _ atn) = atn +kikiAction (MultiPass _ atn next) = do + x <- atn + g <- kikiAction next + return $ g x + +kjoin :: Kiki (Kiki a) -> Kiki a +kjoin k = fmapWithRT eval' k + where + eval' :: KeyRingAction (Kiki a -> a) + eval' = RunTimeAction (\rt -> evalAction rt . kikiAction ) + + {- + kjoin :: Kiki (Kiki a) -> Kiki a + kjoin k = kjoin' (fmap kikiAction k) + where + ev rt (KeyRingAction v) = v + ev rt (RunTimeAction g) = g rt + + kjoin' :: Kiki (KeyRingAction a) -> Kiki a + kjoin' (SinglePass pass atn) = SinglePass pass $ join atn + kjoin' (MultiPass pass atn next) = MultiPass pass atn next' + where + next' = todo + -} + + +{- +instance Functor Kiki where + fmap f (SinglePass pass atn) + = SinglePass pass (fmap f atn) + fmap f (MultiPass pass atn next) + = MultiPass pass atn (next >>= g) + where + g = todo +-} + +{- +data Kiki a = SinglePass (KeyRingOperation a) + | forall b. MultiPass (KeyRingOperation b) (Kiki (b -> a)) + +instance Functor Kiki where + fmap f (SinglePass d) = SinglePass $ case kAction d of + KeyRingAction v -> d { kAction = KeyRingAction (f v) } + RunTimeAction g -> d { kAction = RunTimeAction (f . g) } + fmap f (MultiPass p k)= MultiPass p (fmap (f .) k) + +eval :: KeyRingRuntime -> Kiki a -> a +eval rt (SinglePass (KeyRingOperation { kAction = KeyRingAction v})) = v +eval rt (SinglePass (KeyRingOperation { kAction = RunTimeAction f})) = f rt +eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p) + +fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v})) + = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } +fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f})) + = SinglePass $ d { kAction = RunTimeAction f' } + where f' rt = g rt (f rt) +fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) + where g' rt h = g rt . h + +kjoin :: Kiki (Kiki a) -> Kiki a +kjoin k = fmapWithRT eval k + +passCount :: Kiki a -> Int +passCount (MultiPass _ k) = 1 + passCount k +passCount (SinglePass {}) = 1 + +instance Monad Kiki where + return x = SinglePass (kret x) + k >>= f = kjoin (fmap f k) +-} + + +-- Kiki a -> a -> Kiki b + +atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a +atRuntime = todo + +goHome :: Maybe FilePath -> Kiki () +goHome p = todo -- SinglePass $ (kret ()) { homeSpec = p } + +syncRing :: InputFile -> Kiki () +syncRing = todo + +syncSubKey :: String -> FilePath -> String -> Kiki () +syncSubKey usage path cmd = todo + +syncWallet :: FilePath -> Kiki () +syncWallet = todo + +usePassphraseFD :: Int -> Kiki () +usePassphraseFD = todo + +{- +importAll :: Kiki () +importAll = todo +-} + +importAllAuthentic :: Kiki () +importAllAuthentic = todo + +signSelfAuthorized :: Kiki () +signSelfAuthorized = todo + +showIdentity :: Message -> String +showIdentity = todo + +identities :: Kiki [Message] +identities = todo + +currentIdentity :: Kiki Message +currentIdentity = todo + +identityBySpec :: String -> Kiki Message +identityBySpec = todo + +identityBySSHKey :: String -> Kiki Message +identityBySSHKey = todo + +keyBySpec :: String -> Kiki Packet +keyBySpec = todo + +walletInputFormat :: Packet -> String +walletInputFormat = todo + +-} + diff --git a/KeyRing.hs b/KeyRing.hs index 16e7751..c3a80d9 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} @@ -16,6 +15,7 @@ module KeyRing , guardAuthentic , Hosts.Hosts , importPublic + , importSecret , PacketUpdate(..) , isCryptoCoinKey , isKey @@ -36,7 +36,6 @@ module KeyRing , pkcs8 , RSAPublicKey(..) , rsaKeyFromPacket - , RSAPublicKey , KeyRingRuntime(..) , runKeyRing , secretToPublic @@ -112,7 +111,7 @@ import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) -- DER-encoded elliptic curve ids -nistp256_id = 0x2a8648ce3d030107 +-- nistp256_id = 0x2a8648ce3d030107 secp256k1_id = 0x2b8104000a -- "\x2a\x86\x48\xce\x3d\x03\x01\x07" {- OID Curve description Curve name @@ -199,8 +198,6 @@ data KeyRingRuntime = KeyRingRuntime , rtKeyDB :: KeyDB } -data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a) - -- | TODO: Packet Update should have deletiong action -- and any other kind of roster entry level -- action. @@ -391,7 +388,7 @@ data KikiResult a = KikiResult keyPacket (KeyData k _ _ _) = packet k -subkeyPacket (SubKey k _ ) = packet k +-- subkeyPacket (SubKey k _ ) = packet k subkeyMappedPacket (SubKey k _ ) = k @@ -675,6 +672,7 @@ selectKey0 wantPublic (spec,mtag) db = do zs = snd $ seek_key subspec ys1 listToMaybe zs +{- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db @@ -688,6 +686,7 @@ selectAll wantPublic (spec,mtag) db = do z <- take 1 zs (y,Just z):search (drop 1 zs) in search (drop 1 ys) +-} seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) @@ -2381,194 +2380,3 @@ fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) -} -data Kiki a = - SinglePass { passInfo :: KeyRingOperation - , rtAction :: KeyRingAction a } - | forall b. - MultiPass { passInfo :: KeyRingOperation - , passAction :: KeyRingAction b - , nextPass :: Kiki (b -> a) - } - - - -evalAction :: KeyRingRuntime -> KeyRingAction a -> a -evalAction rt (KeyRingAction v) = v -evalAction rt (RunTimeAction g) = g rt - -instance Monad KeyRingAction where - return x = KeyRingAction x - m >>= g = case m of - KeyRingAction v -> g v - RunTimeAction f -> RunTimeAction $ \rt -> evalAction rt (g $ f rt) - -instance Functor KeyRingAction where - fmap g (KeyRingAction v) = KeyRingAction $ g v - fmap g (RunTimeAction f) = RunTimeAction $ \rt -> g (f rt) - -{- -argOut :: (KeyRingAction (a -> b)) -> a -> KeyRingAction b -argOut = todo -argIn :: (a -> KeyRingAction b) -> KeyRingAction (a->b) --} - -{- -fmapWithRT :: (a -> KeyRingAction b) -> Kiki a -> Kiki b -fmapWithRT g k@(SinglePass {}) = k { rtAction = action } - where - action = rtAction k >>= g -fmapWithRT g (MultiPass p atn next) = MultiPass p atn next' - where - next' = fmapWithRT g' next {- next :: Kiki (x -> a) -} - -- g' :: ( (x->a) -> KeyRingAction b) - g' h = RunTimeAction $ - \rt x -> case g (h x) of - KeyRingAction v -> v - RunTimeAction f -> f rt --} - -fmapWithRT :: KeyRingAction (a -> b) -> Kiki a -> Kiki b -fmapWithRT g (SinglePass pass atn) = SinglePass pass atn' - where - atn' = g >>= flip fmap atn -fmapWithRT g (MultiPass p atn next) = MultiPass p atn next' - where - next' = fmapWithRT g' next - g' = fmap (\gf h -> gf . h) g - -instance Functor Kiki where - fmap f k = fmapWithRT (return f) k - -{- -instance Monad Kiki where - return x = SinglePass todo (return x) - k >>= f = kjoin $ fmap f k - -kikiAction :: Kiki a -> KeyRingAction a -kikiAction (SinglePass _ atn) = atn -kikiAction (MultiPass _ atn next) = do - x <- atn - g <- kikiAction next - return $ g x - -kjoin :: Kiki (Kiki a) -> Kiki a -kjoin k = fmapWithRT eval' k - where - eval' :: KeyRingAction (Kiki a -> a) - eval' = RunTimeAction (\rt -> evalAction rt . kikiAction ) - - {- - kjoin :: Kiki (Kiki a) -> Kiki a - kjoin k = kjoin' (fmap kikiAction k) - where - ev rt (KeyRingAction v) = v - ev rt (RunTimeAction g) = g rt - - kjoin' :: Kiki (KeyRingAction a) -> Kiki a - kjoin' (SinglePass pass atn) = SinglePass pass $ join atn - kjoin' (MultiPass pass atn next) = MultiPass pass atn next' - where - next' = todo - -} - - -{- -instance Functor Kiki where - fmap f (SinglePass pass atn) - = SinglePass pass (fmap f atn) - fmap f (MultiPass pass atn next) - = MultiPass pass atn (next >>= g) - where - g = todo --} - -{- -data Kiki a = SinglePass (KeyRingOperation a) - | forall b. MultiPass (KeyRingOperation b) (Kiki (b -> a)) - -instance Functor Kiki where - fmap f (SinglePass d) = SinglePass $ case kAction d of - KeyRingAction v -> d { kAction = KeyRingAction (f v) } - RunTimeAction g -> d { kAction = RunTimeAction (f . g) } - fmap f (MultiPass p k)= MultiPass p (fmap (f .) k) - -eval :: KeyRingRuntime -> Kiki a -> a -eval rt (SinglePass (KeyRingOperation { kAction = KeyRingAction v})) = v -eval rt (SinglePass (KeyRingOperation { kAction = RunTimeAction f})) = f rt -eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p) - -fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b -fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = KeyRingAction v})) - = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } -fmapWithRT g (SinglePass d@(KeyRingOperation { kAction = RunTimeAction f})) - = SinglePass $ d { kAction = RunTimeAction f' } - where f' rt = g rt (f rt) -fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk) - where g' rt h = g rt . h - -kjoin :: Kiki (Kiki a) -> Kiki a -kjoin k = fmapWithRT eval k - -passCount :: Kiki a -> Int -passCount (MultiPass _ k) = 1 + passCount k -passCount (SinglePass {}) = 1 - -instance Monad Kiki where - return x = SinglePass (kret x) - k >>= f = kjoin (fmap f k) --} - - --- Kiki a -> a -> Kiki b - -atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a -atRuntime = todo - -goHome :: Maybe FilePath -> Kiki () -goHome p = todo -- SinglePass $ (kret ()) { homeSpec = p } - -syncRing :: InputFile -> Kiki () -syncRing = todo - -syncSubKey :: String -> FilePath -> String -> Kiki () -syncSubKey usage path cmd = todo - -syncWallet :: FilePath -> Kiki () -syncWallet = todo - -usePassphraseFD :: Int -> Kiki () -usePassphraseFD = todo - -{- -importAll :: Kiki () -importAll = todo --} - -importAllAuthentic :: Kiki () -importAllAuthentic = todo - -signSelfAuthorized :: Kiki () -signSelfAuthorized = todo - -showIdentity :: Message -> String -showIdentity = todo - -identities :: Kiki [Message] -identities = todo - -currentIdentity :: Kiki Message -currentIdentity = todo - -identityBySpec :: String -> Kiki Message -identityBySpec = todo - -identityBySSHKey :: String -> Kiki Message -identityBySSHKey = todo - -keyBySpec :: String -> Kiki Packet -keyBySpec = todo - -walletInputFormat :: Packet -> String -walletInputFormat = todo - --} -- cgit v1.2.3