more experimental foo

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 @@
+---------------------------------------------------------------------------
+-- |
+-- 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 
+-- <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- which adds a special command to a stream and the blaze-builder-conduit 
+-- 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.
+--
+-- But for other intermediary conduits, the nullary @Flush@ constructor may 
+-- be noise that they should politely preserve in case it is meaningul downstream.
+-- If <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- 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 <http://hackage.haskell.org/package/conduit-1.0.13.1/docs/Data-Conduit.html#t:Flush Flush>
+-- 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 
+-- <http://hackage.haskell.org/package/blaze-builder-conduit-1.0.0/docs/Data-Conduit-Blaze.html#v:builderToByteStringFlush builderToByteStringFlush>.
+--
+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