From fe075ae203a8f8809c7dcf3d7e600679ec5b804b Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 14 Apr 2014 02:28:55 -0400 Subject: experimental monad instance --- KeyRing.hs | 140 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 133 insertions(+), 7 deletions(-) (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs index b223ee7..6d1ff3b 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} module KeyRing where import System.Environment @@ -33,7 +34,12 @@ home = HomeDir , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } -data InputFile = HomeSec | HomePub | ArgFile FilePath +data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int + +data FileType = KeyRingFile | PEMFile | WalletFile + +data RefType = ConstRef | MutableRef + data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath @@ -43,14 +49,17 @@ data KeyRingRuntime = KeyRingRuntime , rtGrip :: Maybe String } +data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a) + data KeyRingData a = KeyRingData - { filesToLock :: [InputFile] + { kFiles :: Map.Map InputFile (RefType,FileType) , homeSpec :: Maybe String - , kaction :: KeyRingRuntime -> IO a - , keyringFiles :: [FilePath] - , walletFiles :: [FilePath] + , kAction :: KeyRingAction a } +kret :: a -> KeyRingData a +kret x = KeyRingData Map.empty Nothing (KeyRingAction x) + todo = error "unimplemented" data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] @@ -77,6 +86,7 @@ data KikiResult a = KikiResult , kikiReport :: [ (FilePath, KikiReportAction) ] } +{- empty = KeyRingData { filesToLock = [] , homeSpec = Nothing , kaction = \KeyRingRuntime {} -> return () @@ -116,6 +126,7 @@ runKeyRing keyring = do forM_ lked $ \(Just lk, fname) -> do dotlock_release lk dotlock_destroy lk return KikiResult { kikiCondition = ret, kikiReport = [] } +-} parseOptionFile fname = do xs <- fmap lines (readFile fname) @@ -372,10 +383,125 @@ 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 +data Kiki a = SinglePass (KeyRingData a) + | forall b. MultiPass (KeyRingData 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 (KeyRingData { kAction = KeyRingAction v})) = v +eval rt (SinglePass (KeyRingData { 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@(KeyRingData { kAction = KeyRingAction v})) + = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) } +fmapWithRT g (SinglePass d@(KeyRingData { 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) + +{- +kjoin :: Kiki (Kiki a) -> Kiki a +kjoin (SinglePass d) = + case kAction d of + KeyRingAction v -> v + RunTimeAction g -> SinglePass (d { kAction = RunTimeAction g' }) + where g' rt = eval rt (g rt) + +kjoin (MultiPass p k)= MultiPass p (fmapWithRT f k) + where + {- + k' = case k of + SinglePass (d { kAction + k :: Kiki (b -> Kiki a) + k' :: Kiki (b -> a) + -} + {- + f :: (b->Kiki a) -> Kiki (b -> a) + f g = SinglePass (p { kAction = RunTimeAction g' }) + where g' rt = \b -> eval rt (g b) + -} + f :: KeyRingRuntime -> (b->Kiki a) -> (b -> a) + f rt g b = eval rt (g b) +-} + + +ktrav :: Kiki (x -> y) -> x -> Kiki y +ktrav (SinglePass kk) x = SinglePass $ case kAction kk of KeyRingAction f -> kk { kAction = KeyRingAction (f x) } + +{- +instance Monad Kiki where + return x = SinglePass (kret x) + + kiki >>= f + = join (fmap f kiki) + where + join (SinglePass kd) = + case kAction kd of + KeyRingAction kiki -> kiki + RunTimeAction g -> + let go rt = case g rt of + SinglePass q -> todo + in SinglePass (kd { kAction = RunTimeAction go }) + join (MultiPass x y) = MultiPass x (join y) +-} + + +{- +data Kiki a = SinglePass (KeyRingData a) + | MultiPass (KeyRingData (Kiki a)) +lastPass :: Kiki a -> KeyRingRuntime -> KeyRingData a +lastPass (SinglePass d) rt = d +lastPass (MultiPass k) rt = case kAction k of + KeyRingAction v -> lastPass v rt + RunTimeAction f -> lastPass (f rt) rt + +instance Monad Kiki where + return x = SinglePass (kret x) + SinglePass (kd@(KeyRingData { kAction = KeyRingAction x })) >>= f + = f x + SinglePass (kd@(KeyRingData { kAction = RunTimeAction g })) >>= f + = SinglePass (kd { kAction = RunTimeAction g' }) + where + g' rt = case f (g rt) of + SinglePass d -> + case kAction d of + KeyRingAction y -> y + RunTimeAction h -> h rt + {- + MultiPass d -> + case kAction d of + KeyRingAction k' -> k' >>= f + -} + +runKiki :: KeyRingRuntime -> Kiki a -> a +runKiki = todo +-} + +-- Kiki a -> a -> Kiki b + +atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a +atRuntime = todo goHome :: Maybe FilePath -> Kiki () -goHome = todo +goHome p = SinglePass $ (kret ()) { homeSpec = p } syncRing :: InputFile -> Kiki () syncRing = todo -- cgit v1.2.3