summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-04-14 02:28:55 -0400
committerjoe <joe@jerkface.net>2014-04-14 02:28:55 -0400
commitfe075ae203a8f8809c7dcf3d7e600679ec5b804b (patch)
tree4e1e637cb570d66cf501bcdcbb1a0cc7bdbdc6d8
parent11eff640b5757048e4323433324afb96553640f0 (diff)
experimental monad instance
-rw-r--r--KeyRing.hs140
1 files changed, 133 insertions, 7 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index b223ee7..6d1ff3b 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1,6 +1,7 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TupleSections #-} 2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ExistentialQuantification #-}
4module KeyRing where 5module KeyRing where
5 6
6import System.Environment 7import System.Environment
@@ -33,7 +34,12 @@ home = HomeDir
33 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] 34 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
34 } 35 }
35 36
36data InputFile = HomeSec | HomePub | ArgFile FilePath 37data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int
38
39data FileType = KeyRingFile | PEMFile | WalletFile
40
41data RefType = ConstRef | MutableRef
42
37 43
38data KeyRingRuntime = KeyRingRuntime 44data KeyRingRuntime = KeyRingRuntime
39 { rtPubring :: FilePath 45 { rtPubring :: FilePath
@@ -43,14 +49,17 @@ data KeyRingRuntime = KeyRingRuntime
43 , rtGrip :: Maybe String 49 , rtGrip :: Maybe String
44 } 50 }
45 51
52data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)
53
46data KeyRingData a = KeyRingData 54data KeyRingData a = KeyRingData
47 { filesToLock :: [InputFile] 55 { kFiles :: Map.Map InputFile (RefType,FileType)
48 , homeSpec :: Maybe String 56 , homeSpec :: Maybe String
49 , kaction :: KeyRingRuntime -> IO a 57 , kAction :: KeyRingAction a
50 , keyringFiles :: [FilePath]
51 , walletFiles :: [FilePath]
52 } 58 }
53 59
60kret :: a -> KeyRingData a
61kret x = KeyRingData Map.empty Nothing (KeyRingAction x)
62
54todo = error "unimplemented" 63todo = error "unimplemented"
55 64
56data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] 65data KikiCondition a = KikiSuccess a | FailedToLock [FilePath]
@@ -77,6 +86,7 @@ data KikiResult a = KikiResult
77 , kikiReport :: [ (FilePath, KikiReportAction) ] 86 , kikiReport :: [ (FilePath, KikiReportAction) ]
78 } 87 }
79 88
89{-
80empty = KeyRingData { filesToLock = [] 90empty = KeyRingData { filesToLock = []
81 , homeSpec = Nothing 91 , homeSpec = Nothing
82 , kaction = \KeyRingRuntime {} -> return () 92 , kaction = \KeyRingRuntime {} -> return ()
@@ -116,6 +126,7 @@ runKeyRing keyring = do
116 forM_ lked $ \(Just lk, fname) -> do dotlock_release lk 126 forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
117 dotlock_destroy lk 127 dotlock_destroy lk
118 return KikiResult { kikiCondition = ret, kikiReport = [] } 128 return KikiResult { kikiCondition = ret, kikiReport = [] }
129-}
119 130
120parseOptionFile fname = do 131parseOptionFile fname = do
121 xs <- fmap lines (readFile fname) 132 xs <- fmap lines (readFile fname)
@@ -372,10 +383,125 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
372 mergeSubSig n sig Nothing = error $ 383 mergeSubSig n sig Nothing = error $
373 "Unable to merge subkey signature: "++(words (show sig) >>= take 1) 384 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
374 385
375data Kiki a = Kiki 386data Kiki a = SinglePass (KeyRingData a)
387 | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))
388
389instance Functor Kiki where
390 fmap f (SinglePass d) = SinglePass $ case kAction d of
391 KeyRingAction v -> d { kAction = KeyRingAction (f v) }
392 RunTimeAction g -> d { kAction = RunTimeAction (f . g) }
393 fmap f (MultiPass p k)= MultiPass p (fmap (f .) k)
394
395eval :: KeyRingRuntime -> Kiki a -> a
396eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v
397eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt
398eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p)
399
400fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
401fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
402 = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
403fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
404 = SinglePass $ d { kAction = RunTimeAction f' }
405 where f' rt = g rt (f rt)
406fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
407 where g' rt h = g rt . h
408
409kjoin :: Kiki (Kiki a) -> Kiki a
410kjoin k = fmapWithRT eval k
411
412passCount :: Kiki a -> Int
413passCount (MultiPass _ k) = 1 + passCount k
414passCount (SinglePass {}) = 1
415
416instance Monad Kiki where
417 return x = SinglePass (kret x)
418 k >>= f = kjoin (fmap f k)
419
420{-
421kjoin :: Kiki (Kiki a) -> Kiki a
422kjoin (SinglePass d) =
423 case kAction d of
424 KeyRingAction v -> v
425 RunTimeAction g -> SinglePass (d { kAction = RunTimeAction g' })
426 where g' rt = eval rt (g rt)
427
428kjoin (MultiPass p k)= MultiPass p (fmapWithRT f k)
429 where
430 {-
431 k' = case k of
432 SinglePass (d { kAction
433 k :: Kiki (b -> Kiki a)
434 k' :: Kiki (b -> a)
435 -}
436 {-
437 f :: (b->Kiki a) -> Kiki (b -> a)
438 f g = SinglePass (p { kAction = RunTimeAction g' })
439 where g' rt = \b -> eval rt (g b)
440 -}
441 f :: KeyRingRuntime -> (b->Kiki a) -> (b -> a)
442 f rt g b = eval rt (g b)
443-}
444
445
446ktrav :: Kiki (x -> y) -> x -> Kiki y
447ktrav (SinglePass kk) x = SinglePass $ case kAction kk of KeyRingAction f -> kk { kAction = KeyRingAction (f x) }
448
449{-
450instance Monad Kiki where
451 return x = SinglePass (kret x)
452
453 kiki >>= f
454 = join (fmap f kiki)
455 where
456 join (SinglePass kd) =
457 case kAction kd of
458 KeyRingAction kiki -> kiki
459 RunTimeAction g ->
460 let go rt = case g rt of
461 SinglePass q -> todo
462 in SinglePass (kd { kAction = RunTimeAction go })
463 join (MultiPass x y) = MultiPass x (join y)
464-}
465
466
467{-
468data Kiki a = SinglePass (KeyRingData a)
469 | MultiPass (KeyRingData (Kiki a))
470lastPass :: Kiki a -> KeyRingRuntime -> KeyRingData a
471lastPass (SinglePass d) rt = d
472lastPass (MultiPass k) rt = case kAction k of
473 KeyRingAction v -> lastPass v rt
474 RunTimeAction f -> lastPass (f rt) rt
475
476instance Monad Kiki where
477 return x = SinglePass (kret x)
478 SinglePass (kd@(KeyRingData { kAction = KeyRingAction x })) >>= f
479 = f x
480 SinglePass (kd@(KeyRingData { kAction = RunTimeAction g })) >>= f
481 = SinglePass (kd { kAction = RunTimeAction g' })
482 where
483 g' rt = case f (g rt) of
484 SinglePass d ->
485 case kAction d of
486 KeyRingAction y -> y
487 RunTimeAction h -> h rt
488 {-
489 MultiPass d ->
490 case kAction d of
491 KeyRingAction k' -> k' >>= f
492 -}
493
494runKiki :: KeyRingRuntime -> Kiki a -> a
495runKiki = todo
496-}
497
498-- Kiki a -> a -> Kiki b
499
500atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a
501atRuntime = todo
376 502
377goHome :: Maybe FilePath -> Kiki () 503goHome :: Maybe FilePath -> Kiki ()
378goHome = todo 504goHome p = SinglePass $ (kret ()) { homeSpec = p }
379 505
380syncRing :: InputFile -> Kiki () 506syncRing :: InputFile -> Kiki ()
381syncRing = todo 507syncRing = todo