From 11eff640b5757048e4323433324afb96553640f0 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 12 Apr 2014 20:48:59 -0400 Subject: more experimental foo --- FunctorToMaybe.hs | 64 +++++++++++++++++++++++++++++++++++++ KeyRing.hs | 96 ++++++++++++++++++++++++++++++++++++++++++++----------- kiki.hs | 6 ++++ 3 files changed, 148 insertions(+), 18 deletions(-) create mode 100644 FunctorToMaybe.hs diff --git a/FunctorToMaybe.hs b/FunctorToMaybe.hs new file mode 100644 index 0000000..0fd6b7f --- /dev/null +++ b/FunctorToMaybe.hs @@ -0,0 +1,64 @@ +--------------------------------------------------------------------------- +-- | +-- Module : FunctorToMaybe +-- +-- Maintainer : joe@jerkface.net +-- Stability : experimental +-- +-- Motivation: When parsing a stream of events, it is often desirable to +-- let certain control events pass-through to the output stream without +-- interrupting the parse. For example, the conduit package uses +-- +-- which adds a special command to a stream and the blaze-builder-conduit +-- package has that treat the nullary constructor with special significance. +-- +-- But for other intermediary conduits, the nullary @Flush@ constructor may +-- be noise that they should politely preserve in case it is meaningul downstream. +-- If +-- implemented the 'FunctorToMaybe' type class, then 'functorToEither' could be used to +-- seperate the noise from the work-product. +-- +module FunctorToMaybe where + + +-- | The 'FunctorToMaybe' class genaralizes 'Maybe' in that the +-- there may be multiple null elements. +-- +-- Instances of 'FunctorToMaybe' should satisfy the following laws: +-- +-- > functorToMaybe (fmap f g) == fmap f (functorToMaybe g) +-- +class Functor g => FunctorToMaybe g where + functorToMaybe :: g a -> Maybe a + + +instance FunctorToMaybe Maybe where + functorToMaybe = id +instance FunctorToMaybe (Either a) where + functorToMaybe (Right x) = Just x + functorToMaybe _ = Nothing + + +-- | 'functorToEither' is a null-preserving cast. +-- +-- If @functorToMaybe g == Nothing@, then a casted value is returned with Left. +-- If @functorToMaybe g == Just a@, then @Right a@ is returned. +-- +-- Returning to our +-- example, if we define +-- +-- > instance Flush where +-- > functorToMaybe Flush = Nothing +-- > functorToMaybe (Chunk a) = Just a +-- +-- Now stream processors can use 'functorToEither' to transform any nullary constructors while +-- while doing its work to transform the data before forwarding it into +-- . +-- +functorToEither :: FunctorToMaybe f => f a -> Either (f b) a +functorToEither ga = + maybe (Left $ uncast ga) + Right + (functorToMaybe ga) + where + 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 import Data.Char import Data.List import Data.OpenPGP +import Data.Functor import Control.Applicative ( (<$>) ) import System.Directory ( getHomeDirectory, doesFileExist ) import Control.Arrow ( first, second ) @@ -17,6 +18,7 @@ import Data.ByteString.Lazy ( ByteString ) import Text.Show.Pretty as PP ( ppShow ) import qualified Data.Map as Map +import FunctorToMaybe import DotLock data HomeDir = @@ -51,13 +53,29 @@ data KeyRingData a = KeyRingData todo = error "unimplemented" -data KikiResult = KikiSuccess | FailedToLock [FilePath] - -{- -newtype KeyRing a = KeyRing - { krAction :: KeyRingData b -> IO a +data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] + +#define TRIVIAL(OP) fmap _ (OP) = OP +instance Functor KikiCondition where + fmap f (KikiSuccess a) = KikiSuccess (f a) + TRIVIAL( FailedToLock x ) +instance FunctorToMaybe KikiCondition where + functorToMaybe (KikiSuccess a) = Just a + functorToMaybe _ = Nothing + +data KikiReportAction = + NewPacket String + | MissingPacket String + | ExportedSubkey + | GeneratedSubkeyFile + | NewWalletKey String + | YieldSignature + | YieldSecretKeyPacket String + +data KikiResult a = KikiResult + { kikiCondition :: KikiCondition a + , kikiReport :: [ (FilePath, KikiReportAction) ] } --} empty = KeyRingData { filesToLock = [] , homeSpec = Nothing @@ -66,13 +84,7 @@ empty = KeyRingData { filesToLock = [] , walletFiles = [] } -{- -runKeyRing :: KeyRing () -> IO a -runKeyRing keyring = krAction keyring empty --} - - -runKeyRing :: KeyRingData a -> IO KikiResult +runKeyRing :: KeyRingData a -> IO (KikiResult a) runKeyRing keyring = do (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring) let tolocks = map resolve (filesToLock keyring) @@ -87,21 +99,23 @@ runKeyRing keyring = do 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 + ret = if null failed then KikiSuccess () else FailedToLock failed - case ret of - KikiSuccess -> kaction keyring KeyRingRuntime + ret <- case functorToEither ret of + Right {} -> do + a <- kaction keyring KeyRingRuntime { rtPubring = pubring , rtSecring = secring , rtRings = secring:pubring:keyringFiles keyring , rtWallets = walletFiles keyring , rtGrip = grip0 } - _ -> return undefined + return (KikiSuccess a) + Left err -> return err forM_ lked $ \(Just lk, fname) -> do dotlock_release lk dotlock_destroy lk - return ret + return KikiResult { kikiCondition = ret, kikiReport = [] } parseOptionFile fname = do xs <- fmap lines (readFile fname) @@ -358,3 +372,49 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) mergeSubSig n sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 1) +data Kiki a = Kiki + +goHome :: Maybe FilePath -> Kiki () +goHome = todo + +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/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 $ error "Key specification is ambiguous." doImportG doDecrypt db m0 tag "" key +doImport + :: Ord k => + (Packet -> IO (Maybe Packet)) + -> Map.Map k KeyData + -> ([Char], Maybe [Char], [k], t) + -> IO (Map.Map k KeyData) doImport doDecrypt db (fname,subspec,ms,_) = do let fetchkey = readKeyFromFile False "PEM" fname let error s = do -- cgit v1.2.3