summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--kiki.cabal85
-rw-r--r--kiki.hs262
-rw-r--r--lib/Base58.hs (renamed from Base58.hs)0
-rw-r--r--lib/CommandLine.hs559
-rw-r--r--lib/Compat.hs (renamed from Compat.hs)0
-rw-r--r--lib/ControlMaybe.hs (renamed from ControlMaybe.hs)0
-rw-r--r--lib/CryptoCoins.hs (renamed from CryptoCoins.hs)0
-rw-r--r--lib/DotLock.hs (renamed from DotLock.hs)0
-rw-r--r--lib/FunctorToMaybe.hs (renamed from FunctorToMaybe.hs)0
-rw-r--r--lib/Hosts.hs (renamed from Hosts.hs)0
-rw-r--r--lib/KeyRing.hs (renamed from KeyRing.hs)162
-rw-r--r--lib/Numeric/Interval.hs754
-rw-r--r--lib/Numeric/Interval/Bounded.hs9
-rw-r--r--lib/PEM.hs (renamed from PEM.hs)0
-rw-r--r--lib/ProcessUtils.hs (renamed from ProcessUtils.hs)0
-rw-r--r--lib/ScanningParser.hs (renamed from ScanningParser.hs)0
-rw-r--r--lib/SuperOrd.hs23
-rw-r--r--lib/TimeUtil.hs (renamed from TimeUtil.hs)0
-rw-r--r--lib/dotlock.c (renamed from dotlock.c)0
-rw-r--r--lib/dotlock.h (renamed from dotlock.h)0
20 files changed, 1673 insertions, 181 deletions
diff --git a/kiki.cabal b/kiki.cabal
index 176d09c..a96eee9 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -1,7 +1,7 @@
1 1
2Name: kiki 2Name: kiki
3Version: 0.0.3 3Version: 0.0.3
4cabal-version: >= 1.6 4cabal-version: >= 1.8
5Synopsis: A bridge between (cryptographic) keys 5Synopsis: A bridge between (cryptographic) keys
6Description: gpg operations... TODO 6Description: gpg operations... TODO
7License: Undecided 7License: Undecided
@@ -23,15 +23,20 @@ Executable kiki
23 Main-is: kiki.hs 23 Main-is: kiki.hs
24 -- base >=4.6 due to use of readEither in KikiD.Message 24 -- base >=4.6 due to use of readEither in KikiD.Message
25 Build-Depends: base >=4.6.0.0, 25 Build-Depends: base >=4.6.0.0,
26 directory -any, 26 asn1-encoding,
27 openpgp-util -any, 27 asn1-types,
28 asn1-types -any, asn1-encoding -any, 28 binary,
29 dataenc -any, text -any, pretty -any, pretty-show -any, 29 bytestring,
30 bytestring -any, binary -any, 30 containers,
31 unix, time, 31 dataenc,
32 containers -any, process -any, filepath -any, 32 directory,
33 network -any, old-locale -any, zlib -any, 33 filepath,
34 tar 34 tar,
35 text,
36 time,
37 unix,
38 openpgp-util,
39 kiki
35 if !flag(cryptonite) 40 if !flag(cryptonite)
36 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any, 41 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any,
37 crypto-pubkey-types -any 42 crypto-pubkey-types -any
@@ -41,12 +46,64 @@ Executable kiki
41 Build-Depends: x509 <1.6 46 Build-Depends: x509 <1.6
42 else 47 else
43 Build-Depends: cryptonite, x509 >=1.6, memory, hourglass 48 Build-Depends: cryptonite, x509 >=1.6, memory, hourglass
44 ghc-options: -O2 -fwarn-unused-binds -fwarn-unused-imports
45 c-sources: dotlock.c
46 49
47Executable hosts 50Executable hosts
48 Main-is: hosts.hs 51 Main-is: hosts.hs
49 c-sources: dotlock.c 52 Build-Depends: base >=4.6.0.0,
53 bytestring,
54 network,
55 kiki
56
57Executable cokiki
58 Main-is: cokiki.hs
59 Build-Depends: base >=4.6.0.0,
60 bytestring,
61 unix,
62 kiki
50 63
51library 64library
52 exposed-modules: KeyRing 65 hs-source-dirs: lib
66 exposed-modules: KeyRing,
67 Kiki,
68 ScanningParser,
69 PEM,
70 DotLock,
71 Base58,
72 CryptoCoins,
73 ProcessUtils,
74 Hosts,
75 CommandLine,
76 Numeric.Interval,
77 Numeric.Interval.Bounded,
78 SuperOrd
79 other-modules: TimeUtil,
80 Compat,
81 FunctorToMaybe
82
83 Build-Depends: base >=4.6.0.0,
84 asn1-encoding,
85 asn1-types,
86 binary,
87 bytestring,
88 containers,
89 dataenc,
90 directory,
91 filepath,
92 network,
93 pretty-show,
94 process,
95 text,
96 time,
97 unix,
98 zlib,
99 openpgp-util
100 if !flag(cryptonite)
101 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any,
102 crypto-pubkey-types -any
103 if flag(hourglass)
104 Build-Depends: hourglass -any, x509 >=1.5 && <1.6
105 else
106 Build-Depends: x509 <1.6
107 else
108 Build-Depends: cryptonite, x509 >=1.6, memory, hourglass
109 c-sources: lib/dotlock.c
diff --git a/kiki.hs b/kiki.hs
index 4aa5885..e06fa79 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -53,7 +53,7 @@ import Control.Arrow (first,second)
53import Data.Monoid ( (<>) ) 53import Data.Monoid ( (<>) )
54import Data.Binary.Put 54import Data.Binary.Put
55 55
56import Data.OpenPGP.Util (verify,fingerprint) 56import Data.OpenPGP.Util (verify,fingerprint,generateKey, GenerateKeyParams(..))
57import ScanningParser 57import ScanningParser
58import PEM 58import PEM
59import DotLock 59import DotLock
@@ -697,18 +697,8 @@ kiki_usage bExport bImport bSecret cmd = putStr $
697 [" --help" 697 [" --help"
698 ," Gives usage information" 698 ," Gives usage information"
699 ,"" 699 ,""
700 ," --homedir DIR" 700 ] ++ documentHomeDir ++ [""]
701 ," Where to find the files secring.gpg and pubring.gpg. The" 701 ++ documentPassphraseFDFlag bExport bImport bSecret
702 ," default location is taken from the environment variable"
703 ," GNUPGHOME. If this environment variable is not set and no"
704 ," directory is specified using this option then a hardcoded"
705 ," default of ~/.gnupg is assumed. "
706 ,""
707 ," WARNING: Confusingly, this is *not* your home directory as"
708 ," given by the HOME environment variable. The option is named"
709 ," or rather misnamed in a fashion similar to the gpg option with"
710 ," exactly the same functionality."
711 ,""] ++ documentPassphraseFDFlag bExport bImport bSecret
712 showwk :: [String] 702 showwk :: [String]
713 showwk = 703 showwk =
714 [" --show-wk" 704 [" --show-wk"
@@ -769,6 +759,21 @@ kiki_usage bExport bImport bSecret cmd = putStr $
769 ," 5E24CD442AA6965D2012E62A905C24185D5379C2" 759 ," 5E24CD442AA6965D2012E62A905C24185D5379C2"
770 ] 760 ]
771 761
762documentHomeDir :: [String]
763documentHomeDir =
764 [" --homedir DIR"
765 ," Where to find the files secring.gpg and pubring.gpg. The"
766 ," default location is taken from the environment variable"
767 ," GNUPGHOME. If this environment variable is not set and no"
768 ," directory is specified using this option then a hardcoded"
769 ," default of ~/.gnupg is assumed. "
770 ,""
771 ," WARNING: Confusingly, this is *not* your home directory as"
772 ," given by the HOME environment variable. The option is named"
773 ," or rather misnamed in a fashion similar to the gpg option with"
774 ," exactly the same functionality."
775 ]
776
772documentPassphraseFDFlag bExport bImport bSecret = 777documentPassphraseFDFlag bExport bImport bSecret =
773 if bSecret then 778 if bSecret then
774 [" --passphrase-fd FD" 779 [" --passphrase-fd FD"
@@ -1043,7 +1048,7 @@ buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp
1043 , fill = rtyp 1048 , fill = rtyp
1044 , spill = KF_All 1049 , spill = KF_All
1045 , access = AutoAccess 1050 , access = AutoAccess
1046 , initializer = Nothing 1051 , initializer =NoCreate
1047 , transforms = [] } 1052 , transforms = [] }
1048 1053
1049 1054
@@ -1100,7 +1105,7 @@ sync bExport bImport bSecret cmdarg args_raw = do
1100 then DNSPresentation 1105 then DNSPresentation
1101 else PEMFile 1106 else PEMFile
1102 , access = if bSecret then Sec else Pub 1107 , access = if bSecret then Sec else Pub
1103 , initializer = cmd' 1108 , initializer = maybe NoCreate External cmd'
1104 , transforms = [] 1109 , transforms = []
1105 } ) 1110 } )
1106 else if isNothing cmd' 1111 else if isNothing cmd'
@@ -1228,7 +1233,7 @@ kiki "show" args = do
1228 streaminfo = StreamInfo { fill = KF_None 1233 streaminfo = StreamInfo { fill = KF_None
1229 , typ = KeyRingFile 1234 , typ = KeyRingFile
1230 , spill = KF_All 1235 , spill = KF_All
1231 , initializer = Nothing 1236 , initializer = NoCreate
1232 , access = AutoAccess 1237 , access = AutoAccess
1233 , transforms = [] 1238 , transforms = []
1234 } 1239 }
@@ -1312,7 +1317,7 @@ kiki "merge" args = do
1312 , typ = KeyRingFile 1317 , typ = KeyRingFile
1313 , spill = KF_None 1318 , spill = KF_None
1314 , fill = KF_None 1319 , fill = KF_None
1315 , initializer = Nothing 1320 , initializer = NoCreate
1316 , transforms = [] 1321 , transforms = []
1317 } 1322 }
1318 updateFlow fil spil mtch flow = spill' $ fill' $ flow 1323 updateFlow fil spil mtch flow = spill' $ fill' $ flow
@@ -1397,7 +1402,7 @@ kiki "merge" args = do
1397 Left ("autosign",Just "false")-> doAutosign False flow op 1402 Left ("autosign",Just "false")-> doAutosign False flow op
1398 Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass 1403 Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass
1399 Left ("create",Just cmd) -> 1404 Left ("create",Just cmd) ->
1400 ( flow { initializer = if null cmd then Nothing else Just cmd } 1405 ( flow { initializer = if null cmd then NoCreate else External cmd }
1401 , op ) 1406 , op )
1402 Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile } , op ) 1407 Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile } , op )
1403 Left ("type",Just "pem" ) -> ( flow { typ = PEMFile } , op ) 1408 Left ("type",Just "pem" ) -> ( flow { typ = PEMFile } , op )
@@ -1425,13 +1430,28 @@ kiki "merge" args = do
1425 Nothing -> error "Valid flow words are: spill,fill,sync,subkeys or match=KEYSPEC" 1430 Nothing -> error "Valid flow words are: spill,fill,sync,subkeys or match=KEYSPEC"
1426 Left (option,_) -> error $ "Unrecognized option: " ++ option 1431 Left (option,_) -> error $ "Unrecognized option: " ++ option
1427 1432
1428kiki "init-key" args | "--help" `elem` args = do 1433kiki "init" args | "--help" `elem` args = do
1429 putStr . unlines $ 1434 putStr . unlines $
1430 [ "kiki init-key [ --passphrase-fd=FD" 1435 [ "kiki init [ --passphrase-fd=FD"
1431 , " | --home[=HOMEDIR]" 1436 , " | --home[=HOMEDIR]"
1432 , " | --chroot=ROOTDIR ] ..."] 1437 , " | --chroot=ROOTDIR ] ..."
1433 return () 1438 , ""
1434kiki "init-key" args = do 1439 , "Initialize a GnuPG keyring for use with kiki. After completion, you"
1440 , "willl have a GnuPG master key with following specialized subkeys:"
1441 , ""
1442 , " tor - freshly generated tor hidden service key"
1443 , " ipsec - freshly generated VPN key"
1444 , " ssh-server - possibly read from /etc/ssh/*"
1445 , " ssh-client - possibly read from /root/.ssh/id_rsa"
1446 , ""
1447 , "OPTIONS"
1448 , ""
1449 , " --chroot=ROOTDIR"
1450 , " Use ROOTDIR for input of ssh keys and export files to"
1451 , " ROOTDIR/var/cache/kiki instead of the current system path."
1452 , ""
1453 ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag True True True
1454kiki "init" args = do
1435 me <- getEffectiveUserID 1455 me <- getEffectiveUserID
1436 {- 1456 {-
1437 if me/=0 then error "This command requires root." else do 1457 if me/=0 then error "This command requires root." else do
@@ -1460,8 +1480,11 @@ kiki "init-key" args = do
1460 (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec 1480 (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec
1461 osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root" 1481 osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root"
1462 -- putStrLn $ "home = " ++ show (home,secring,pubring,mbwk) 1482 -- putStrLn $ "home = " ++ show (home,secring,pubring,mbwk)
1483
1484 -- Generate secring.gpg if it does not exist...
1463 gotsec <- doesFileExist secring 1485 gotsec <- doesFileExist secring
1464 when (not gotsec) $ do 1486 when (not gotsec) $ do
1487 {- ssh-keygen to create master key...
1465 let mkpath = home ++ "/master-key" 1488 let mkpath = home ++ "/master-key"
1466 mkdirFor mkpath 1489 mkdirFor mkpath
1467 e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096) 1490 e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096)
@@ -1472,59 +1495,78 @@ kiki "init-key" args = do
1472 writeInputFileL (InputFileContext secring pubring) 1495 writeInputFileL (InputFileContext secring pubring)
1473 HomeSec 1496 HomeSec
1474 ( encode $ Message [mk { is_subkey = False }] ) 1497 ( encode $ Message [mk { is_subkey = False }] )
1498 -}
1499 master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
1500 writeInputFileL (InputFileContext secring pubring)
1501 HomeSec
1502 $ encode $ Message [master { is_subkey = False}]
1503
1475 gotpub <- doesFileExist pubring 1504 gotpub <- doesFileExist pubring
1476 when (not gotpub) $ do 1505 when (not gotpub) $ do
1477 writeInputFileL (InputFileContext secring pubring) 1506 writeInputFileL (InputFileContext secring pubring)
1478 HomePub 1507 HomePub
1479 ( encode $ Message [] ) 1508 ( encode $ Message [] )
1480 1509
1481 -- TODO: These should be read from a configuration file. 1510 -- Old paths..
1482 -- (use SimpleConfig) 1511 --
1483 let torpath = fromMaybe "" rootdir ++ "/var/lib/tor/samizdat/private_key" 1512 -- Private
1484 sshcpath0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </>"id_rsa" 1513 -- pem tor /var/lib/tor/samizdat/private_key
1485 sshspath0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key" 1514 -- pem ssh-client %(home)/.ssh/id_rsa
1486 ipsecpath0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/private/%(onion).pem" 1515 -- pem ssh-server /etc/ssh/ssh_host_rsa_key
1487 sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" 1516 -- pem ipsec /etc/ipsec.d/private/%(onion).pem
1488 sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
1489 ipsecpathpub0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
1490 contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
1491 1517
1518 -- Public
1519 -- ssh-client %(home)/.ssh/id_rsa.pub
1520 -- ssh-server /etc/ssh/ssh_host_rsa_key.pub
1521 -- ipsec /etc/ipsec.d/certs/%(onion).pem
1492 1522
1493 -- First, we ensure that the tor key exists and is imported 1523 -- First, we ensure that the tor key exists and is imported
1494 -- so that we know where to put the strongswan key. 1524 -- so that we know where to put the strongswan key.
1495 let passfd = fmap (FileDesc . read) $ lookup "passphrase-fd" args 1525 let passfd = fmap (FileDesc . read) $ lookup "passphrase-fd" args
1526 strm = StreamInfo { typ = KeyRingFile
1527 , fill = KF_None
1528 , spill = KF_All
1529 , access = AutoAccess
1530 , initializer = NoCreate
1531 , transforms = [] }
1496 buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp 1532 buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp
1497 , fill = rtyp 1533 , fill = rtyp
1498 , spill = KF_All 1534 , spill = KF_All
1499 , access = AutoAccess 1535 , access = AutoAccess
1500 , initializer = Nothing 1536 , initializer = NoCreate
1501 , transforms = [] } 1537 , transforms = [] }
1502 peminfo bits usage = 1538 peminfo bits usage =
1503 StreamInfo { typ = PEMFile 1539 StreamInfo { typ = PEMFile
1504 , fill = KF_Match usage 1540 , fill = KF_None -- KF_Match usage
1505 , spill = KF_Match usage 1541 , spill = KF_Match usage
1506 , access = Sec 1542 , access = Sec
1507 , initializer = sshkeygen bits 1543 , initializer = Internal (GenRSA $ bits `div` 8)
1508 , transforms = [] 1544 , transforms = []
1509 } 1545 }
1546 sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
1547 sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
1510 op = KeyRingOperation 1548 op = KeyRingOperation
1511 { opFiles = Map.fromList $ 1549 { opFiles = Map.fromList $
1512 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) 1550 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
1513 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } ) 1551 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
1514 , ( ArgFile torpath, peminfo 1024 "tor" ) ] 1552 , ( Generate 0 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "tor" })
1553 , ( Generate 1 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "ipsec" })
1554 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
1555 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
1556 ]
1515 , opPassphrases = do pfd <- maybeToList passfd 1557 , opPassphrases = do pfd <- maybeToList passfd
1516 return $ PassphraseSpec Nothing Nothing pfd 1558 return $ PassphraseSpec Nothing Nothing pfd
1517 , opHome = homespec 1559 , opHome = homespec
1518 , opTransforms = [] 1560 , opTransforms = []
1519 } 1561 }
1520 doNothing = return () 1562 -- doNothing = return ()
1521 nop = KeyRingOperation 1563 nop = KeyRingOperation
1522 { opFiles = Map.empty 1564 { opFiles = Map.empty
1523 , opPassphrases = do pfd <- maybeToList passfd 1565 , opPassphrases = do pfd <- maybeToList passfd
1524 return $ PassphraseSpec Nothing Nothing pfd 1566 return $ PassphraseSpec Nothing Nothing pfd
1525 , opHome=homespec, opTransforms = [] 1567 , opHome=homespec, opTransforms = []
1526 } 1568 }
1527 if bUnprivileged then doNothing else mkdirFor torpath 1569 -- if bUnprivileged then doNothing else mkdirFor torpath
1528 KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op) 1570 KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
1529 forM_ report $ \(fname,act) -> do 1571 forM_ report $ \(fname,act) -> do
1530 putStrLn $ fname ++ ": " ++ reportString act 1572 putStrLn $ fname ++ ": " ++ reportString act
@@ -1533,87 +1575,7 @@ kiki "init-key" args = do
1533 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" 1575 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
1534 _ -> unconditionally $ return rt 1576 _ -> unconditionally $ return rt
1535 1577
1536 -- Now import, export, or generate the remaining secret keys. 1578 when (not bUnprivileged) $ refreshCache rt rootdir
1537 let oname' = do wk <- rtWorkingKey rt
1538 onionNameForContact (keykey wk) (rtKeyDB rt)
1539 if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
1540 let oname = fromMaybe "" oname'
1541 let [ sshcpath, sshcpathpub ] = {- map (interp (Map.fromList [("onion",oname)]))-} [ sshcpath0, sshcpathpub0 ]
1542 [ sshspath , ipsecpath ] = map (interp (Map.fromList [("onion",oname)])) [ sshspath0, ipsecpath0 ]
1543 [ sshspathpub, ipsecpathpub ]
1544 = map (interp (Map.fromList [("onion",oname)]))
1545 [ sshspathpub0, ipsecpathpub0 ]
1546 let opPriv = op
1547 { opFiles = Map.fromList $
1548 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
1549 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
1550 , ( ArgFile ipsecpath, peminfo 1024 "strongswan" )
1551 , ( ArgFile sshcpath, peminfo 2048 "ssh-client" )
1552 , ( ArgFile sshspath, peminfo 2048 "ssh-server" ) ]
1553 , opPassphrases = [ PassphraseMemoizer (rtPassphrases rt) ]
1554 }
1555 opUnPriv = op
1556 { opFiles = Map.fromList $
1557 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
1558 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
1559 , ( ArgFile sshcpath, peminfo 2048 "ssh-client" )
1560 ]
1561 , opPassphrases = [ PassphraseMemoizer (rtPassphrases rt) ]
1562 }
1563 mapM_ mkdirFor $ [sshcpath,sshcpathpub] ++ if not bUnprivileged then [sshspath,ipsecpath,sshspathpub,ipsecpathpub] else []
1564 KikiResult rt report <- runKeyRing (if bUnprivileged then opUnPriv else opPriv)
1565 forM_ report $ \(fname,act) -> do
1566 putStrLn $ fname ++ ": " ++ reportString act
1567 rt <- case rt of
1568 BadPassphrase ->
1569 error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
1570 _ -> unconditionally $ return rt
1571
1572 -- Finally, export public keys if they do not exist.
1573 let writeFileWARNING fname bs = do
1574 --TODO
1575 hPutStrLn stderr $ fname ++ ": DID NOT CHECK TRUST (TODO)"
1576 writeFile fname bs
1577 flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
1578 gotc <- doesFileExist (sshcpathpub)
1579 when (not gotc) $ do
1580 either warn (writeFile sshcpathpub)
1581 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
1582 if (not bUnprivileged)
1583 then do
1584 goth <- doesFileExist (sshspathpub)
1585 when (not goth) $ do
1586 either warn (writeFile $ sshspathpub)
1587 $ show_ssh' "ssh-host" grip (rtKeyDB rt)
1588 goti <- doesFileExist (ipsecpathpub)
1589 when (not goti) $ do
1590 either warn (writeFile $ ipsecpathpub)
1591 $ show_pem' "strongswan" grip (rtKeyDB rt) pemFromPacket
1592 else return ()
1593
1594
1595 let cs = filter notme (Map.elems $ rtKeyDB rt)
1596 kk = keykey (fromJust $ rtWorkingKey rt)
1597 notme kd = keykey (keyPacket kd) /= kk
1598
1599 installConctact kd = do
1600 -- The getHostnames command requires a valid cross-signed tor key
1601 -- for each onion name returned in (_,(ns,_)).
1602 let (_,(ns,_)) = getHostnames kd
1603 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
1604 flip (maybe $ return ()) contactname $ \contactname -> do
1605
1606 let cpath = interp (Map.singleton "onion" contactname) contactipsec0
1607 their_master = packet $ keyMappedPacket kd
1608 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
1609 ipsecs = sortOn (Down . timestamp)
1610 $ getCrossSignedSubkeys their_master (keySubKeys kd) "strongswan"
1611 forM_ (take 1 ipsecs) $ \k -> do
1612 goti <- doesFileExist (cpath)
1613 when (not goti) $ do
1614 either warn (writeFile cpath) $ pemFromPacket k
1615
1616 mapM_ installConctact cs
1617 1579
1618kiki "delete" args | "--help" `elem` args = do 1580kiki "delete" args | "--help" `elem` args = do
1619 putStr . unlines $ 1581 putStr . unlines $
@@ -1690,10 +1652,59 @@ kiki "tar" args = do
1690 ["-A":_] -> putStrLn "unimplemented." -- import tar file? 1652 ["-A":_] -> putStrLn "unimplemented." -- import tar file?
1691 _ -> kiki "tar" ["--help"] 1653 _ -> kiki "tar" ["--help"]
1692 1654
1655refreshCache rt rootdir = do
1656
1657 let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth
1658
1659 write f bs = do
1660 createDirectoryIfMissing True $ takeDirectory f
1661 writeFile f bs
1662
1663 let oname' = do wk <- rtWorkingKey rt
1664 -- XXX unnecessary signature check
1665 onionNameForContact (keykey wk) (rtKeyDB rt)
1666 bUnprivileged = False -- TODO
1667 if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
1668 let oname = fromMaybe "" oname'
1669 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
1670 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
1671 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
1672
1673 -- Finally, export public keys if they do not exist.
1674 flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
1675 either warn (write $ mkpath "root/.ssh/id_rsa.pub")
1676 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
1677 either warn (write $ mkpath "ssh_host_rsa_key.pub")
1678 $ show_ssh' "ssh-server" grip (rtKeyDB rt)
1679 either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
1680 $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
1681
1682 let cs = filter notme (Map.elems $ rtKeyDB rt)
1683 kk = keykey (fromJust $ rtWorkingKey rt)
1684 notme kd = keykey (keyPacket kd) /= kk
1685
1686 installConctact kd = do
1687 -- The getHostnames command requires a valid cross-signed tor key
1688 -- for each onion name returned in (_,(ns,_)).
1689 let (_,(ns,_)) = getHostnames kd
1690 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
1691 flip (maybe $ return ()) contactname $ \contactname -> do
1692
1693 let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
1694 their_master = packet $ keyMappedPacket kd
1695 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
1696 ipsecs = sortOn (Down . timestamp)
1697 $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
1698 forM_ (take 1 ipsecs) $ \k -> do
1699 either warn (write $ mkpath cpath) $ pemFromPacket k
1700
1701 mapM_ installConctact cs
1702
1703
1693tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root" 1704tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1694 where 1705 where
1695 ipsecs = do 1706 ipsecs = do
1696 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "strongswan") (rtKeyDB rt) 1707 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
1697 let kd = (rtKeyDB rt Map.! kk) 1708 let kd = (rtKeyDB rt Map.! kk)
1698 k = packet $ keyMappedPacket kd 1709 k = packet $ keyMappedPacket kd
1699 (addr,(onames,ns)) = getHostnames kd 1710 (addr,(onames,ns)) = getHostnames kd
@@ -1729,7 +1740,7 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1729 return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k 1740 return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k
1730 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd 1741 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd
1731 ipseckey = do 1742 ipseckey = do
1732 k <- lookupSecret "strongswan" kd 1743 k <- lookupSecret "ipsec" kd
1733 oname <- fst . snd $ getHostnames kd 1744 oname <- fst . snd $ getHostnames kd
1734 return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k 1745 return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k
1735 torkey ++ sshcli ++ sshsvr ++ ipseckey 1746 torkey ++ sshcli ++ sshsvr ++ ipseckey
@@ -1800,7 +1811,7 @@ minimalOp cap = op
1800 streaminfo = StreamInfo { fill = KF_None 1811 streaminfo = StreamInfo { fill = KF_None
1801 , typ = KeyRingFile 1812 , typ = KeyRingFile
1802 , spill = KF_All 1813 , spill = KF_All
1803 , initializer = Nothing 1814 , initializer = NoCreate
1804 , access = AutoAccess 1815 , access = AutoAccess
1805 , transforms = [] 1816 , transforms = []
1806 } 1817 }
@@ -1849,7 +1860,8 @@ commands =
1849 , ( "export-secret", "export (both public and secret) information into your keyring" ) 1860 , ( "export-secret", "export (both public and secret) information into your keyring" )
1850 , ( "export-public", "import (public) information into your keyring" ) 1861 , ( "export-public", "import (public) information into your keyring" )
1851 , ( "merge", "low level import/export operation" ) 1862 , ( "merge", "low level import/export operation" )
1852 , ( "init-key", "initialize the samizdat key ring") 1863 -- , ( "init-key", "initialize the samizdat key ring")
1864 , ( "init", "Initialize kiki")
1853 , ( "delete", "Delete a subkey and its associated signatures" ) 1865 , ( "delete", "Delete a subkey and its associated signatures" )
1854 , ( "tar", "import or export system key files in tar format" ) 1866 , ( "tar", "import or export system key files in tar format" )
1855 ] 1867 ]
diff --git a/Base58.hs b/lib/Base58.hs
index 3c1a113..3c1a113 100644
--- a/Base58.hs
+++ b/lib/Base58.hs
diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs
new file mode 100644
index 0000000..dfc16f9
--- /dev/null
+++ b/lib/CommandLine.hs
@@ -0,0 +1,559 @@
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE CPP #-}
3-- {-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE PatternGuards #-}
8module CommandLine
9 ( Args
10 , UsageError(..)
11 , usageErrorMessage
12 , parseInvocation
13 , runArgs
14 , arg
15 , param
16 , params
17 , label
18 ) where
19
20import Control.Applicative
21import Control.Arrow
22import Control.Monad
23import Data.Bits
24import Data.Either
25import Data.Function
26import Data.List
27import Data.Maybe
28import Data.Ord
29import Data.Map.Strict (Map)
30import qualified Data.Map.Strict as Map
31import Data.IntMap.Strict (IntMap)
32import qualified Data.IntMap.Strict as IntMap
33import Debug.Trace
34import Numeric.Interval (Interval(..), singleton, (...), inf, sup, hull)
35import qualified Numeric.Interval as I
36import Numeric.Interval.Bounded
37import SuperOrd
38
39-- trace :: String -> a -> a
40-- trace _ x = x
41
42-- type CompF a = [String] -> [String] -> a
43
44type MergeData = [(Int,Ordering)]
45
46-- | Expr a
47--
48data Expr a where
49 -- | Prim
50 --
51 -- Takes a function from the option arguments and unamed arguments repsectively to
52 -- a value of type a, usually IO (), and gives you an expression tree. As one
53 -- traverses down the tree only the 'interesting' option arguments are passed
54 -- to this function, but all of the unnamed arguments are passed regardless of
55 -- where we are in the tree.
56 --
57 Prim :: ([[String]] -> [String] -> a) -> Interval (SuperOrd Int) -> Expr a
58 -- | Star
59 -- Applicative '<*>'
60 Star :: MergeData -> Expr (b -> a) -> (Expr b) -> Expr a
61 -- | Or
62 -- Alternative '<|>'
63 Or :: MergeData -> Expr a -> Expr a -> Expr a
64 -- | Empty
65 -- Alternative empty
66 Empty :: Expr a
67
68deriving instance Functor Expr
69
70-- | Args
71--
72-- Applicative Functor for interpretting command line arguments.
73data Args a = Args
74 { expr :: Expr a
75 -- ^ Expression tree
76 , accepts :: [String]
77 -- ^ sorted list of acceptable short and long option names (non positional arguments)
78 -- The names include hyphens.
79 }
80 deriving Functor
81
82instance Applicative Args where
83 pure x = Args { expr = Prim (\_ _ -> x) (singleton $ exactly 0), accepts = [] }
84 f <*> b = Args
85 { expr = Star d (expr f) (expr b)
86 , accepts = m
87 }
88 where d = mergeData compare (accepts f) (accepts b)
89 m = mergeLists d const (accepts f) (accepts b)
90
91instance Alternative Args where
92 empty = Args Empty []
93 f <|> g = Args
94 { expr = Or d (expr f) (expr g)
95 , accepts = m
96 }
97 where d = mergeData compare (accepts f) (accepts g)
98 m = mergeLists d const (accepts f) (accepts g)
99
100
101{- dead code?
102unpackBits :: Integer -> [Bool]
103unpackBits 0 = [False]
104unpackBits 1 = [True]
105unpackBits n = ( r /= 0 ) : unpackBits q
106 where
107 (q,r) = divMod n 2
108
109-- requires finite list
110packBits :: [Bool] -> Integer
111packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1
112 -}
113
114
115-- | mergeData
116--
117-- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)]
118--
119-- Given a comparison function and two sorted lists, 'mergeData' will return
120-- a RLE compressed (run-length encoded) list of the comparison results
121-- encountered while merging the lists.
122--
123-- This data is enough information to perform the merge without doing the
124-- comparisons or to reverse a merged list back to two sorted lists.
125--
126-- When one list is exausted, the length of the remaining list is returned as
127-- a run-length for LT or GT depending on whether the left list or the right
128-- list has elements.
129mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)]
130mergeData comp (x:xs) (y:ys)
131 | comp x y == LT = case mergeData comp xs (y:ys) of
132 (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys
133 ys -> (1,LT):ys
134 | comp x y == EQ = case mergeData comp xs ys of
135 (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys
136 ys -> (1,EQ):ys
137 | comp x y == GT = case mergeData comp (x:xs) ys of
138 (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys
139 ys -> (1,GT):ys
140mergeData comp [] [] = []
141mergeData comp [] ys = (length ys, GT) : []
142mergeData comp xs [] = (length xs, LT) : []
143
144mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a]
145mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys
146 where
147 (ls,xs') = splitAt n xs
148mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys'
149 where
150 (les,xs') = splitAt n xs
151 (res,ys') = splitAt n ys
152 es = zipWith f les res
153mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys'
154 where
155 (gs,ys') = splitAt n ys
156mergeLists [] f [] ys = ys
157mergeLists [] f xs [] = xs
158mergeLists [] f xs ys = error "xs ++ ys"
159
160{-
161computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer
162computeMask k w t [] = 0
163computeMask k w t ((n,v):os)
164 = if w==v then r .|. shiftL (bit n - 1) k
165 else r
166 where r = computeMask (k+n') w t os
167 n' | v==t = n
168 | otherwise = 0
169
170-- WRONG, one-blocks are not spaced the same in input and output, need shifts
171mergeIntegers :: [(Int,Ordering)] -> (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
172mergeIntegers os f x y = (leftmask .&. x) .|. (rightmask .&. y) .|. (f (leqmask .&. x) (reqmask .&. y))
173 where
174 leftmask = computeMask 0 LT EQ os
175 leqmask = computeMask 0 EQ LT os
176 reqmask = computeMask 0 EQ GT os
177 rightmask = computeMask 0 GT EQ os
178-}
179{- kinda dead code
180mergeIntegers ((n,LT):os) f !x !y = v `seq` m `seq` m .|. v
181 where
182 m = x .&. (bit n - 1)
183 r = mergeIntegers os f (shiftR x n) y
184 v = r `seq` shiftL r n
185mergeIntegers ((n,EQ):os) f !x !y = mm `seq` v `seq` mm .|. v
186 where
187 mm = f mx my
188 mx = x .&. (bit n - 1)
189 my = y .&. (bit n - 1)
190 r = mergeIntegers os f (shiftR x n) (shiftR y n)
191 v = r `seq` shiftL r n
192mergeIntegers ((n,GT):os) f !x !y = v `seq` m `seq` m .|. v
193 where
194 m = y .&. (bit n - 1)
195 r = mergeIntegers os f x (shiftR y n)
196 v = r `seq` shiftL r n
197mergeIntegers [] f !0 !y = y
198mergeIntegers [] f !x !0 = x
199mergeIntegers [] f !x !y = error "x .|. y"
200-}
201
202splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a])
203splitLists ((n,LT):os) xs = (ls ++ lls, rrs)
204 where
205 (ls,xs') = splitAt n xs
206 (lls,rrs) = splitLists os xs'
207splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs)
208 where
209 (es,xs') = splitAt n xs
210 (lls,rrs) = splitLists os xs'
211splitLists ((n,GT):os) xs = (lls, rs ++ rrs)
212 where
213 (rs,xs') = splitAt n xs
214 (lls,rrs) = splitLists os xs'
215splitLists [] xs = (xs,xs)
216
217{-
218mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a]
219 -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
220 , (b -> b -> b) -> [b] -> [b] -> [b]
221 , [b] -> ([b], [b]))
222mergeBy comp xs ys = trace (unlines ["xs="++show xs,"ys="++show ys,"mergeData="++show d]) (mergeIntegers d, mergeLists d, splitLists d)
223 where
224 d = mergeData comp xs ys
225-}
226
227
228param :: Int -> Args String
229param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) []
230
231arg :: String -> Args String
232arg optname = Args (Prim (\opts _ -> head $ concat $ take 1 opts)
233 (singleton $ exactly 0))
234 [optname]
235
236params :: Args [String]
237params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) []
238
239
240label :: String -> Args a -> Args a
241label _ = id
242
243data ArgsStyle = ArgsStyle
244 { parseInvocation :: String -> [String] -> ([(String,[String])], [String])
245 }
246
247-- | Phase 1. This function accepts a list of command line arguments in its
248-- second argument that will be parsed to obtain a pair of lists: named
249-- argument-value pairs and unnamed arguments values.
250--
251-- The first argument indicates which short options will be treated as on/off
252-- flags and given a dummy value of \"\". Hyphen-prefixed options not in this
253-- list are given their imeediately following string as a value.
254--
255-- The \"--\" convention is implemented to indicate all remaining arguments are
256-- unnamed argument values.
257--
258-- The results of this function are intended to be used as input to 'runArgs'.
259vanilla :: ArgsStyle
260vanilla = ArgsStyle { parseInvocation = parse }
261 where
262 parse flags cli = (opts, concat nons ++ nondashed ++ drop 1 trailing)
263 where
264 (as, trailing) = span (/= "--") cli
265 (nons,bs) = span ((==[True]) . map (not . isPrefixOf "-") . take 1) $ groupBy (const $ not . isPrefixOf "-") as
266 (ds, nondashed) = second concat $ unzip $ map splitParams bs
267 opts = map ((first concat) . splitAt 1) (ds :: [[String]])
268
269 splitParams (('-':[x]):xs) | x `elem` flags = (['-':[x]],xs)
270 splitParams xs = splitAt 2 xs
271
272-- | Information about how the user failed to satisfy a specified usage.
273data UsageError
274 = TooManyParameters Int
275 -- ^ The given number of excessive unnamed arguments occured.
276 | InsufficientParameters Int
277 -- ^ Not enough unnamed arguments. The number indicates how many are
278 -- total are expected.
279 | TooManyOf String [String]
280 -- ^ An option was supplied too many times. The list is a set of values
281 -- associated with the repeated instances.
282 | Missing [String]
283 -- ^ A list of required options that the user failed to specify.
284 | ChooseOne [[String]]
285 -- ^ The user failed to choose one of the given set of option combinations.
286 | Misunderstood [String]
287 -- ^ A list of unrecognized options.
288 | Incompatible [[String]]
289 -- ^ A list of supplied options that may not be used together.
290
291 | NamedFailure String UsageError
292 -- ^ Extra context provided via the 'label' primitive.
293
294 deriving (Eq,Show)
295
296-- | Obtain a description of a usage error that can be reported to the user.
297usageErrorMessage :: UsageError -> String
298usageErrorMessage (NamedFailure _ e) = usageErrorMessage e
299usageErrorMessage (TooManyParameters _) = "too many arguments"
300usageErrorMessage (InsufficientParameters c) = "insufficient arguments (need "++show c++")"
301usageErrorMessage (TooManyOf n xs) = n ++" can be specified only once"
302usageErrorMessage (Missing ns) = "missing: "++intercalate ", " ns
303usageErrorMessage (ChooseOne nss) = "choose one of: "++intercalate ", " (map (intercalate " ") nss)
304usageErrorMessage (Misunderstood ns) = "unrecognized: "++intercalate ", " ns
305usageErrorMessage (Incompatible nss) = intercalate " and " (map (intercalate " ") nss) ++ " cannot be used together"
306
307{-
308rankError :: UsageError -> Int
309rankError (NamedFailure _ e) = rankError e
310rankError (TooManyParameters _) = 0
311rankError (InsufficientParameters _) = 1
312rankError (TooManyOf _ xs) = 1
313rankError (Missing _) = 2
314rankError (ChooseOne _) = 2
315rankError (Misunderstood xs) = 2 + length xs
316rankError (Incompatible ys) = 2 + length ys
317
318tagError :: UsageError -> Int
319tagError (NamedFailure _ _) = 0
320tagError (TooManyParameters _) = 1
321tagError (InsufficientParameters _) = 2
322tagError (TooManyOf _ _) = 3
323tagError (Missing _) = 4
324tagError (ChooseOne _) = 5
325tagError (Misunderstood _) = 6
326tagError (Incompatible _) = 7
327
328missingWhat :: UsageError -> [[String]]
329missingWhat (Missing xs) = [xs]
330missingWhat (ChooseOne ys) = ys
331missingWhat (NamedFailure _ e) = missingWhat e
332missingWhat _ = []
333
334misunderstoodWhat :: UsageError -> [String]
335misunderstoodWhat (Misunderstood xs) = xs
336misunderstoodWhat (Incompatible yss) = concatMap (take 1) yss
337misunderstoodWhat (NamedFailure _ e) = misunderstoodWhat e
338misunderstoodWhat _ = []
339-}
340
341{- dead code
342tryCompute :: [(String,String)] -> [String] -> Computation a -> Either UsageError a
343tryCompute os us c@(Computation { compLabel = lbl })
344 | null lbl = tryCompute' os us c
345 | otherwise = either (Left . NamedFailure lbl) Right $ tryCompute' os us c
346 where
347 tryCompute' os us c
348 | not (null unused_os) = Left $ Misunderstood $ map fst unused_os
349 | not (null missing) = Left $ Missing missing
350 | not (null repss) = Left $ TooManyOf (fst $ head $ head repss) (map snd $ head repss)
351 | ulen < clen = Left $ InsufficientParameters clen
352 | ulen > clen = Left $ TooManyParameters (ulen - clen)
353 | otherwise = Right $ compute c os us
354 where
355 (found, missing) = partition (\k -> k `elem` map fst os) $ consumedOptions c
356 (used_os, unused_os) = partition (\(k,v) -> k `elem` consumedOptions c) os
357 ulen = length us
358 repss = filter (not . null . tail) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) used_os
359 clen = case consumedParameters c of
360 -1 -> ulen
361 num -> num
362-}
363
364#if defined(VERSION_base)
365#if !MIN_VERSION_base(4,8,0)
366sortOn :: Ord b => (a -> b) -> [a] -> [a]
367sortOn f =
368 map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
369#endif
370#endif
371
372removeIntersection (x:xs) (y:ys)
373 | x == y = removeIntersection xs ys
374 | x < y = first (x :) $ removeIntersection xs (y:ys)
375 | x > y = second (y :) $ removeIntersection (x:xs) ys
376removeIntersection [] ys = ([],ys)
377removeIntersection xs [] = (xs,[])
378
379
380-- ordinary sorted list merge.
381mergeL :: Ord a => [a] -> [a] -> [a]
382mergeL as bs = mergeLists (mergeData compare as bs) const as bs
383
384-- | runArgs
385--
386-- (os,us) - named arguments(options, name-value pairs), and unnamed arguments
387-- c - expression tree (applicative functor)
388--
389-- returns either a UsageError or a computed result (perhaps IO ())
390--
391-- Evaluate the given set of named and unnamed values and return
392-- the computed result or else indicate bad usage.
393--
394-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
395-- to obtain suitable input for this function.
396runArgs :: ([(String,[String])], [String]) -> Args a -> Either UsageError a
397runArgs (os,us) c
398 | not (null bads) = Left $ Misunderstood $ map fst bads
399 | not (null dups) = Left $ TooManyOf (fst $ head dups) (concat $ take 1 $ snd $ head dups) -- only reports first dup.
400 | otherwise = makeError $ compute (expr c) (zipWith const [0..] (accepts c)) us
401 where
402 os' = sortOn fst os
403 dups = mapMaybe notSingle $ groupBy ((==) `on` fst) (os' :: [(String,[String])])
404 where notSingle [x] = Nothing
405 notSingle ((k,v):xs) = Just (k,v : map snd xs)
406 getbit = let r = Map.fromList $ zip (accepts c) [0..] in trace ("getbit = "++show r) r
407 goods :: [(Int,[String])]
408 (bads,goods) = let r = partitionEithers $ map f os' in trace ("(bads,goods)="++show r) r
409 where f (k,v) = case Map.lookup k getbit of
410 Just b -> Right (b,v)
411 Nothing -> Left (k,v)
412
413 valmap = IntMap.fromList goods
414 namemap = IntMap.fromList $ zip [0..] (accepts c)
415
416 vals = map snd goods
417 ulen = length us
418
419 makeError (_,Left e) = Left $ makeError' e
420 where
421 makeError' (Left xss) = Incompatible $ map (map (namemap IntMap.!)) xss
422 makeError' (Right [xs]) = Missing $ map (namemap IntMap.!) xs
423 makeError' (Right xss) = ChooseOne $ map (map (namemap IntMap.!)) xss
424 makeError (i,Right v)
425 | exactly ulen > sup i = Left $ TooManyParameters (ulen - superApprox (sup i))
426 | exactly ulen < inf i = Left $ InsufficientParameters (superApprox (inf i))
427 | otherwise = Right v
428
429
430 -- On success, returns Right, otherwise:
431 --
432 -- * @ Left (Right xss) @ - xss indicates unspecified required named-options.
433 --
434 -- * @ Left (Left xss) @ - xss is a list of mutually-exclusive sets of specified options.
435 --
436 compute :: Expr a -> [Int] -> [String] -> (Interval (SuperOrd Int), Either (Either [[Int]] [[Int]]) a)
437 compute (Prim f i) opts us
438 | null es = (i, Right $ f vals us )
439 | otherwise = (i, Left $ Right [es])
440 where
441 (es,vals) = partitionEithers
442 $ map (\k -> maybe (Left k) Right (k `IntMap.lookup` valmap)) opts
443 compute (Star d f b) opts us = (max (inf fi) (inf bi) ... max (sup fi) (sup bi), r)
444 where
445 r = case (fres,bres) of
446 (Right ff , Right bb) -> Right $ ff bb
447 (Left e , Right _) -> Left e
448 (Right _ , Left e) -> Left e
449 (Left (Right ls) , Left (Right rs)) -> Left $ Right [ mergeL l r | l <- ls, r <- rs ]
450 (Left (Left ls) , Left (Left rs)) -> Left $ Left (ls ++ rs)
451 (Left e , Left (Right _)) -> Left e
452 (Left (Right _) , Left e ) -> Left e
453 (fopts,bopts) = splitLists d opts
454 (fi,fres) = compute f fopts us
455 (bi,bres) = compute b bopts us
456 compute (Or d f g) opts us
457 = case () of
458 () | null fonly
459 , null gonly
460 , Left (Right fms) <- fr
461 , Left (Right gms) <- gr -> (hi, Left $ Right $ fms ++ gms)
462
463 () | Left (Left fss) <- fr
464 , Left (Left gss) <- gr -> (hi, Left (Left (fss ++ gss)))
465
466 () | null gonly, Left _ <- gr -> (fi,fr)
467 () | null fonly, Left _ <- fr -> (gi,gr)
468
469 () | null gonly, Right _ <- fr -> (fi,fr)
470 () | null fonly, Right _ <- gr -> (gi,gr)
471
472 () | Left (Left fss) <- fr -> (hi, Left (Left ( filter (not . null) (gonly : map (filter (not . (`elem` gopts))) fss))))
473 () | Left (Left gss) <- gr -> (hi, Left (Left ( filter (not . null) (fonly : map (filter (not . (`elem` fopts))) gss))))
474 () -> (hi, Left (Left [fonly,gonly]))
475
476 where
477 (fopts,gopts) = splitLists d opts
478 (fonly,gonly) = (filterPresent *** filterPresent) $ removeIntersection fopts gopts
479 filterPresent = filter (`IntMap.member` valmap)
480 (fi,fr) = compute f fopts us
481 (gi,gr) = compute g gopts us
482 hi = hull fi gi
483 compute Empty _ _ = error "CommandLine: empty evaluation"
484
485{-
486-- | Phase 2. Evaluate the given set of named and unnamed values and return
487-- the computed result or else indicate bad usage.
488--
489-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
490-- to obtain suitable input for this function.
491runArgsOlder :: ([(String,String)], [String]) -> ArgsOlder a -> Either UsageError a
492runArgsOlder (os,us) (ArgsOlder alts)
493 | not (null rs) = Right $ head rs
494 | not (null ls) = Left $ chooseError ls
495 | otherwise = Right $ error $ show (length alts,ls)
496 where
497 recs = map (tryCompute os us) alts
498 rs = rights recs
499 ls = lefts recs
500-}
501
502{-
503chooseError :: [UsageError] -> UsageError
504chooseError ls = case span ((==2) . rankError) $ sortOn rankError ls of
505 ([e],_) -> e
506 (e:es,_)
507 | overlap -> em
508 | otherwise -> -- trace ("ms="++show ms) $
509 case findPartition ms of
510 Just (xs@(_:_:_)) -> ChooseOne $ map return xs
511 _ -> em
512 where
513 em:ems = sortBy (comparing (maximum . map length . missingWhat)) (e:es)
514 ms = concatMap missingWhat (em:ems)
515 mi = foldr1 intersect ms
516 overlap = any null $ map (\\ mi) ms
517 (_,e:es) -> case takeWhile ((>2) . rankError) (e:es) of
518 [f] -> f
519 f:fs -> -- trace ("ws="++show (w:ws))
520 case u of
521 [_] -> f
522 _ -> Incompatible u
523 where u = foldr1 union $ w : takeWhile ((==wlen) . length) ws
524 w:ws = map misunderstoodWhat (f:fs)
525 wlen = length w
526 [] -> e
527-}
528
529
530{-
531-- Given a collection of sets, return a list of unique reprasentative members.
532findPartition :: Eq x => [[x]] -> Maybe [x]
533findPartition yss =
534 case sortBy (comparing length) yss of
535 []:_ -> Nothing
536 zss | not (null ds) -> Nothing
537 | otherwise -> _findPartition ps es xss3
538 where
539 (pss,xss0) = span isSingle zss
540 isSingle [x] = True
541 isSingle _ = False
542 ps = foldr union [] pss
543 xss1 = map (partition (`elem` ps)) xss0
544 (xss2,bs) = partition (null . fst) xss1
545 (cs,ds) = partition (null . drop 1 . fst) bs
546 es = foldr union [] $ map snd cs
547 xss3 = map snd xss2
548
549
550_findPartition :: Eq x => [x] -> [x] -> [[x]] -> Maybe [x]
551_findPartition ps qs [] = Just ps
552_findPartition ps qs (xs:xss)
553 | null cs = Nothing
554 | otherwise = listToMaybe ss
555 where
556 cs = filter (not . flip elem qs) xs
557 ts = init $ zipWith (\as (b:bs) -> (b,as++bs)) (inits cs) (tails cs)
558 ss = mapMaybe (\(t,tqs) -> _findPartition (t:ps) (tqs++qs) (filter (not . elem t) xss)) ts
559-}
diff --git a/Compat.hs b/lib/Compat.hs
index 3b77851..3b77851 100644
--- a/Compat.hs
+++ b/lib/Compat.hs
diff --git a/ControlMaybe.hs b/lib/ControlMaybe.hs
index 659dab7..659dab7 100644
--- a/ControlMaybe.hs
+++ b/lib/ControlMaybe.hs
diff --git a/CryptoCoins.hs b/lib/CryptoCoins.hs
index f417036..f417036 100644
--- a/CryptoCoins.hs
+++ b/lib/CryptoCoins.hs
diff --git a/DotLock.hs b/lib/DotLock.hs
index af05f5d..af05f5d 100644
--- a/DotLock.hs
+++ b/lib/DotLock.hs
diff --git a/FunctorToMaybe.hs b/lib/FunctorToMaybe.hs
index 658b024..658b024 100644
--- a/FunctorToMaybe.hs
+++ b/lib/FunctorToMaybe.hs
diff --git a/Hosts.hs b/lib/Hosts.hs
index 5f09de1..5f09de1 100644
--- a/Hosts.hs
+++ b/lib/Hosts.hs
diff --git a/KeyRing.hs b/lib/KeyRing.hs
index 0fbf2c2..1c6dea8 100644
--- a/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -42,6 +42,7 @@ module KeyRing
42 , Access(..) 42 , Access(..)
43 , FileType(..) 43 , FileType(..)
44 , InputFile(..) 44 , InputFile(..)
45 , Initializer(..)
45 , KeyFilter(..) 46 , KeyFilter(..)
46 -- * Results of a KeyRing Operation 47 -- * Results of a KeyRing Operation
47 , KeyRingRuntime(..) 48 , KeyRingRuntime(..)
@@ -49,8 +50,6 @@ module KeyRing
49 , KeyDB 50 , KeyDB
50 , KeyData(..) 51 , KeyData(..)
51 , SubKey(..) 52 , SubKey(..)
52 , packet
53 , locations
54 , keyflags 53 , keyflags
55 -- * Miscelaneous Utilities 54 -- * Miscelaneous Utilities
56 , isKey 55 , isKey
@@ -117,7 +116,7 @@ import Data.Bits ( (.|.), (.&.) )
117import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) 116import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
118import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) 117import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
119import Control.Arrow ( first, second ) 118import Control.Arrow ( first, second )
120import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) 119import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..))
121import Data.ByteString.Lazy ( ByteString ) 120import Data.ByteString.Lazy ( ByteString )
122import Text.Show.Pretty as PP ( ppShow ) 121import Text.Show.Pretty as PP ( ppShow )
123import Data.Binary {- decode, decodeOrFail -} 122import Data.Binary {- decode, decodeOrFail -}
@@ -244,10 +243,16 @@ data InputFile = HomeSec
244 -- ^ Contents will be read from the first descriptor and updated 243 -- ^ Contents will be read from the first descriptor and updated
245 -- content will be writen to the second. Note: Don't use Pipe 244 -- content will be writen to the second. Note: Don't use Pipe
246 -- for 'Wallet' files. (TODO: Wallet support) 245 -- for 'Wallet' files. (TODO: Wallet support)
246 | Generate Int GenerateKeyParams
247 -- ^ New key packets will be generated if there is no
248 -- matching content already in the key pool. The integer is
249 -- a unique id number so that multiple generations can be
250 -- inserted into 'opFiles'
247 deriving (Eq,Ord,Show) 251 deriving (Eq,Ord,Show)
248 252
249-- type UsageTag = String 253-- type UsageTag = String
250type Initializer = String 254data Initializer = NoCreate | Internal GenerateKeyParams | External String
255 deriving (Eq,Ord,Show)
251 256
252data FileType = KeyRingFile 257data FileType = KeyRingFile
253 | PEMFile 258 | PEMFile
@@ -320,10 +325,10 @@ data StreamInfo = StreamInfo
320 -- * The 'spill' setting is ignored and the file's contents are shared. 325 -- * The 'spill' setting is ignored and the file's contents are shared.
321 -- (TODO) 326 -- (TODO)
322 -- 327 --
323 , initializer :: Maybe String 328 , initializer :: Initializer
324 -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is 329 -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set,
325 -- interpretted as a shell command that may be used to create the key if it 330 -- then it is interpretted as a shell command that may be used to create
326 -- does not exist. 331 -- the key if it does not exist.
327 , transforms :: [Transform] 332 , transforms :: [Transform]
328 -- ^ Per-file transformations that occur before the contents of a file are 333 -- ^ Per-file transformations that occur before the contents of a file are
329 -- spilled into the common pool. 334 -- spilled into the common pool.
@@ -1288,6 +1293,26 @@ cachedContents maybePrompt ctx fd = do
1288 writeIORef ref (Just pw) 1293 writeIORef ref (Just pw)
1289 return pw 1294 return pw
1290 1295
1296generateSubkey ::
1297 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
1298 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1299 -> (GenerateKeyParams, StreamInfo)
1300 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1301generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1302 try kd' $ \(kd,report0) -> do
1303 let subs = do
1304 SubKey p sigs <- Map.elems $ keySubKeys kd
1305 filter (has_tag tag) $ map (packet . fst) sigs
1306 if null subs
1307 then do
1308 newkey <- generateKey genparam
1309 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1310 try kdr $ \(newkd,report) -> do
1311 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1312 else do
1313 return $ KikiSuccess (kd,report0)
1314generateSubkey _ kd _ = return kd
1315
1291importSecretKey :: 1316importSecretKey ::
1292 (MappedPacket -> IO (KikiCondition Packet)) 1317 (MappedPacket -> IO (KikiCondition Packet))
1293 -> KikiCondition 1318 -> KikiCondition
@@ -1418,12 +1443,16 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1418 ,[(FilePath,KikiReportAction)])) 1443 ,[(FilePath,KikiReportAction)]))
1419buildKeyDB ctx grip0 keyring = do 1444buildKeyDB ctx grip0 keyring = do
1420 let 1445 let
1421 files isring = do 1446 files istyp = do
1422 (f,stream) <- Map.toList (opFiles keyring) 1447 (f,stream) <- Map.toList (opFiles keyring)
1423 guard (isring $ typ stream) 1448 guard (istyp $ typ stream)
1424 resolveInputFile ctx f 1449 resolveInputFile ctx f
1425 1450
1426 ringMap = Map.filter (isring . typ) $ opFiles keyring 1451 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
1452 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
1453 where
1454 isgen (Generate _ _) _ = True
1455 isgen _ _ = False
1427 1456
1428 readp f stream = fmap readp0 $ readPacketsFromFile ctx f 1457 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1429 where 1458 where
@@ -1541,11 +1570,34 @@ buildKeyDB ctx grip0 keyring = do
1541 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 1570 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
1542 try db $ \(db,reportPEMs) -> do 1571 try db $ \(db,reportPEMs) -> do
1543 1572
1573 -- generate keys
1574 let gens = mapMaybe g $ Map.toList genMap
1575 where g (Generate _ params,v) = Just (params,v)
1576 g _ = Nothing
1577
1578 db <- generateInternals doDecrypt mwk db gens
1579 try db $ \(db,reportGens) -> do
1580
1544 r <- mergeHostFiles keyring db ctx 1581 r <- mergeHostFiles keyring db ctx
1545 try r $ \((db,hs),reportHosts) -> do 1582 try r $ \((db,hs),reportHosts) -> do
1546 1583
1547 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 1584 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
1548 , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) 1585 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
1586
1587generateInternals ::
1588 (MappedPacket -> IO (KikiCondition Packet))
1589 -> Maybe MappedPacket
1590 -> Map.Map KeyKey KeyData
1591 -> [(GenerateKeyParams,StreamInfo)]
1592 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1593generateInternals doDecrypt mwk db gens = do
1594 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
1595 Just kd0 -> do
1596 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
1597 try kd $ \(kd,reportGens) -> do
1598 let kk = keykey $ packet $ fromJust mwk
1599 return $ KikiSuccess (Map.insert kk kd db,reportGens)
1600 Nothing -> return $ KikiSuccess (db,[])
1549 1601
1550torhash :: Packet -> String 1602torhash :: Packet -> String
1551torhash key = fromMaybe "" $ derToBase32 <$> derRSA key 1603torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
@@ -1768,11 +1820,10 @@ readSecretPEMFile fname = do
1768 return $ dta 1820 return $ dta
1769 1821
1770doImport 1822doImport
1771 :: Ord k => 1823 :: (MappedPacket -> IO (KikiCondition Packet))
1772 (MappedPacket -> IO (KikiCondition Packet)) 1824 -> Map.Map KeyKey KeyData
1773 -> Map.Map k KeyData 1825 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1774 -> (FilePath, Maybe [Char], [k], StreamInfo, t) 1826 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1775 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1776doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 1827doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1777 flip (maybe $ return CannotImportMasterKey) 1828 flip (maybe $ return CannotImportMasterKey)
1778 subspec $ \tag -> do 1829 subspec $ \tag -> do
@@ -1812,18 +1863,21 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1812 return $ KikiSuccess (db',report++report') 1863 return $ KikiSuccess (db',report++report')
1813 1864
1814doImportG 1865doImportG
1815 :: Ord k => 1866 :: (MappedPacket -> IO (KikiCondition Packet))
1816 (MappedPacket -> IO (KikiCondition Packet)) 1867 -> Map.Map KeyKey KeyData
1817 -> Map.Map k KeyData 1868 -> [KeyKey] -- m0, only head is used
1818 -> [k] 1869 -> [SignatureSubpacket] -- tags
1819 -> [SignatureSubpacket] 1870 -> FilePath
1820 -> [Char]
1821 -> Packet 1871 -> Packet
1822 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) 1872 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1823doImportG doDecrypt db m0 tags fname key = do 1873doImportG doDecrypt db m0 tags fname key = do
1824 let kk = head m0 1874 let kk = head m0
1825 Just (KeyData top topsigs uids subs) = Map.lookup kk db 1875 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
1826 subkk = keykey key 1876 kdr <- insertSubkey doDecrypt kk kd tags fname key
1877 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
1878
1879insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1880 let subkk = keykey key
1827 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) 1881 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1828 []) 1882 [])
1829 ( (False,) . addOrigin ) 1883 ( (False,) . addOrigin )
@@ -1876,7 +1930,7 @@ doImportG doDecrypt db m0 tags fname key = do
1876 let SubKey subkey_p subsigs = subkey 1930 let SubKey subkey_p subsigs = subkey
1877 wk = packet top 1931 wk = packet top
1878 (xs',minsig,ys') = findTag tags wk key subsigs 1932 (xs',minsig,ys') = findTag tags wk key subsigs
1879 doInsert mbsig db = do 1933 doInsert mbsig = do
1880 -- NEW SUBKEY BINDING SIGNATURE 1934 -- NEW SUBKEY BINDING SIGNATURE
1881 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 1935 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
1882 try sig' $ \(sig',report) -> do 1936 try sig' $ \(sig',report) -> do
@@ -1884,7 +1938,7 @@ doImportG doDecrypt db m0 tags fname key = do
1884 let subs' = Map.insert subkk 1938 let subs' = Map.insert subkk
1885 (SubKey subkey_p $ xs'++[sig']++ys') 1939 (SubKey subkey_p $ xs'++[sig']++ys')
1886 subs 1940 subs
1887 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db 1941 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1888 , report ) 1942 , report )
1889 1943
1890 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) 1944 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
@@ -1893,12 +1947,12 @@ doImportG doDecrypt db m0 tags fname key = do
1893 in return (f report) 1947 in return (f report)
1894 1948
1895 case minsig of 1949 case minsig of
1896 Nothing -> doInsert Nothing db -- we need to create a new sig 1950 Nothing -> doInsert Nothing -- we need to create a new sig
1897 Just (True,sig) -> -- we can deduce is_new == False 1951 Just (True,sig) -> -- we can deduce is_new == False
1898 -- we may need to add a tor id 1952 -- we may need to add a tor id
1899 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db 1953 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1900 , report ) 1954 , report )
1901 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag 1955 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1902 1956
1903isCryptoCoinKey :: Packet -> Bool 1957isCryptoCoinKey :: Packet -> Bool
1904isCryptoCoinKey p = 1958isCryptoCoinKey p =
@@ -2405,7 +2459,9 @@ performManipulations doDecrypt rt wk manip = do
2405 2459
2406initializeMissingPEMFiles :: 2460initializeMissingPEMFiles ::
2407 KeyRingOperation 2461 KeyRingOperation
2408 -> InputFileContext -> Maybe String 2462 -> InputFileContext
2463 -> Maybe String
2464 -> Maybe MappedPacket
2409 -> (MappedPacket -> IO (KikiCondition Packet)) 2465 -> (MappedPacket -> IO (KikiCondition Packet))
2410 -> KeyDB 2466 -> KeyDB
2411 -> IO (KikiCondition ( (KeyDB,[( FilePath 2467 -> IO (KikiCondition ( (KeyDB,[( FilePath
@@ -2413,7 +2469,7 @@ initializeMissingPEMFiles ::
2413 , [MappedPacket] 2469 , [MappedPacket]
2414 , StreamInfo )]) 2470 , StreamInfo )])
2415 , [(FilePath,KikiReportAction)])) 2471 , [(FilePath,KikiReportAction)]))
2416initializeMissingPEMFiles operation ctx grip decrypt db = do 2472initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
2417 nonexistents <- 2473 nonexistents <-
2418 filterM (fmap not . doesFileExist . fst) 2474 filterM (fmap not . doesFileExist . fst)
2419 $ do (f,t) <- Map.toList (opFiles operation) 2475 $ do (f,t) <- Map.toList (opFiles operation)
@@ -2422,9 +2478,15 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2422 2478
2423 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do 2479 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
2424 (fname,stream) <- nonexistents 2480 (fname,stream) <- nonexistents
2425 guard $ isMutable stream 2481 let internalInitializer StreamInfo
2426 guard $ isSecretKeyFile (typ stream) 2482 { initializer = Internal _
2427 usage <- usageFromFilter (fill stream) -- TODO: Error if no result? 2483 , spill = KF_Match tag } = Just tag
2484 internalInitializer _ = Nothing
2485 mutableTag
2486 | isMutable stream = usageFromFilter (fill stream)
2487 | otherwise = Nothing
2488 usage <- maybeToList $ internalInitializer stream `mplus` mutableTag
2489 -- TODO: Report error if generating without specifying usage tag.
2428 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage 2490 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
2429 -- ms will contain duplicates if a top key has multiple matching 2491 -- ms will contain duplicates if a top key has multiple matching
2430 -- subkeys. This is intentional. 2492 -- subkeys. This is intentional.
@@ -2451,7 +2513,9 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2451 let cmds = mapMaybe getcmd missing 2513 let cmds = mapMaybe getcmd missing
2452 where 2514 where
2453 getcmd (fname,subspec,ms,stream) = do 2515 getcmd (fname,subspec,ms,stream) = do
2454 cmd <- initializer stream 2516 cmd <- case initializer stream of
2517 External str -> Just str
2518 _ -> Nothing
2455 return (fname,subspec,ms,stream,cmd) 2519 return (fname,subspec,ms,stream,cmd)
2456 rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do 2520 rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
2457 e <- systemEnv [ ("file",fname) 2521 e <- systemEnv [ ("file",fname)
@@ -2470,8 +2534,20 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do
2470 return (f,subspec,map fst ms,stream,cmd) 2534 return (f,subspec,map fst ms,stream,cmd)
2471 2535
2472 try v $ \(db,import_rs) -> do 2536 try v $ \(db,import_rs) -> do
2537
2538 -- generateInternals
2539 let internals = mapMaybe getParams missing
2540 where
2541 getParams (fname,subspec,ms,stream) =
2542 case initializer stream of
2543 Internal p -> Just (p, stream)
2544 _ -> Nothing
2545 v <- generateInternals decrypt mwk db internals
2546
2547 try v $ \(db,internals_rs) -> do
2548
2473 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs 2549 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
2474 ++ import_rs) 2550 ++ import_rs ++ internals_rs)
2475{- 2551{-
2476interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData 2552interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
2477interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" 2553interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
@@ -2657,6 +2733,7 @@ runKeyRing operation = do
2657 externals_ret <- initializeMissingPEMFiles operation 2733 externals_ret <- initializeMissingPEMFiles operation
2658 ctx 2734 ctx
2659 grip 2735 grip
2736 wk
2660 decrypt 2737 decrypt
2661 db 2738 db
2662 try' externals_ret $ \((db,exports),report_externals) -> do 2739 try' externals_ret $ \((db,exports),report_externals) -> do
@@ -3350,8 +3427,8 @@ getCrossSignedSubkeys topk subs tag = do
3350 return torsig 3427 return torsig
3351 guard (not $ null sigs') 3428 guard (not $ null sigs')
3352 return subk 3429 return subk
3353 where 3430
3354 has_tag tag p = isSignaturePacket p 3431has_tag tag p = isSignaturePacket p
3355 && or [ tag `elem` mapMaybe usage (hashed_subpackets p) 3432 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
3356 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] 3433 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
3357 3434
@@ -3501,5 +3578,6 @@ foreign import ccall unsafe "futimens"
3501onionNameForContact :: KeyKey -> KeyDB -> Maybe String 3578onionNameForContact :: KeyKey -> KeyDB -> Maybe String
3502onionNameForContact kk db = do 3579onionNameForContact kk db = do
3503 contact <- Map.lookup kk db 3580 contact <- Map.lookup kk db
3504 let (_,(name:_,_)) = getHostnames contact 3581 case getHostnames contact of
3505 return $ Char8.unpack name 3582 (_,(name:_,_)) -> Just $ Char8.unpack name
3583 _ -> Nothing
diff --git a/lib/Numeric/Interval.hs b/lib/Numeric/Interval.hs
new file mode 100644
index 0000000..df4bc33
--- /dev/null
+++ b/lib/Numeric/Interval.hs
@@ -0,0 +1,754 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
5{-# LANGUAGE DeriveGeneric #-}
6#endif
7-----------------------------------------------------------------------------
8-- |
9-- Module : Numeric.Interval
10-- Copyright : (c) Edward Kmett 2010-2013
11-- License : BSD3
12-- Maintainer : ekmett@gmail.com
13-- Stability : experimental
14-- Portability : DeriveDataTypeable
15-- Version : intervals-0.4.2 (minus distributive instance)
16--
17-- Interval arithmetic
18--
19-----------------------------------------------------------------------------
20
21module Numeric.Interval
22 ( Interval(..)
23 , (...)
24 , whole
25 , empty
26 , null
27 , singleton
28 , elem
29 , notElem
30 , inf
31 , sup
32 , singular
33 , width
34 , midpoint
35 , intersection
36 , hull
37 , bisection
38 , magnitude
39 , mignitude
40 , contains
41 , isSubsetOf
42 , certainly, (<!), (<=!), (==!), (>=!), (>!)
43 , possibly, (<?), (<=?), (==?), (>=?), (>?)
44 , clamp
45 , idouble
46 , ifloat
47 ) where
48
49import Control.Applicative hiding (empty)
50import Data.Data
51#ifdef VERSION_distributive
52import Data.Distributive
53#endif
54import Data.Foldable hiding (minimum, maximum, elem, notElem, null)
55import Data.Function (on)
56import Data.Monoid
57import Data.Traversable
58#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
59import GHC.Generics
60#endif
61import Prelude hiding (null, elem, notElem)
62
63-- $setup
64
65data Interval a = I !a !a deriving
66 ( Data
67 , Typeable
68#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
69 , Generic
70#if __GLASGOW_HASKELL__ >= 706
71 , Generic1
72#endif
73#endif
74 )
75
76instance Functor Interval where
77 fmap f (I a b) = I (f a) (f b)
78 {-# INLINE fmap #-}
79
80instance Foldable Interval where
81 foldMap f (I a b) = f a `mappend` f b
82 {-# INLINE foldMap #-}
83
84instance Traversable Interval where
85 traverse f (I a b) = I <$> f a <*> f b
86 {-# INLINE traverse #-}
87
88instance Applicative Interval where
89 pure a = I a a
90 {-# INLINE pure #-}
91 I f g <*> I a b = I (f a) (g b)
92 {-# INLINE (<*>) #-}
93
94instance Monad Interval where
95 return a = I a a
96 {-# INLINE return #-}
97 I a b >>= f = I a' b' where
98 I a' _ = f a
99 I _ b' = f b
100 {-# INLINE (>>=) #-}
101
102#ifdef VERSION_distributive
103instance Distributive Interval where
104 distribute f = fmap inf f ... fmap sup f
105 {-# INLINE distribute #-}
106#endif
107
108infix 3 ...
109
110negInfinity :: Fractional a => a
111negInfinity = (-1)/0
112{-# INLINE negInfinity #-}
113
114posInfinity :: Fractional a => a
115posInfinity = 1/0
116{-# INLINE posInfinity #-}
117
118nan :: Fractional a => a
119nan = 0/0
120
121fmod :: RealFrac a => a -> a -> a
122fmod a b = a - q*b where
123 q = realToFrac (truncate $ a / b :: Integer)
124{-# INLINE fmod #-}
125
126-- | The rule of thumb is you should only use this to construct using values
127-- that you took out of the interval. Otherwise, use I, to force rounding
128(...) :: a -> a -> Interval a
129(...) = I
130{-# INLINE (...) #-}
131
132-- | The whole real number line
133--
134-- >>> whole
135-- -Infinity ... Infinity
136whole :: Fractional a => Interval a
137whole = negInfinity ... posInfinity
138{-# INLINE whole #-}
139
140-- | An empty interval
141--
142-- >>> empty
143-- NaN ... NaN
144empty :: Fractional a => Interval a
145empty = nan ... nan
146{-# INLINE empty #-}
147
148-- | negation handles NaN properly
149--
150-- >>> null (1 ... 5)
151-- False
152--
153-- >>> null (1 ... 1)
154-- False
155--
156-- >>> null empty
157-- True
158null :: Ord a => Interval a -> Bool
159null x = not (inf x <= sup x)
160{-# INLINE null #-}
161
162-- | A singleton point
163--
164-- >>> singleton 1
165-- 1 ... 1
166singleton :: a -> Interval a
167singleton a = a ... a
168{-# INLINE singleton #-}
169
170-- | The infinumum (lower bound) of an interval
171--
172-- >>> inf (1 ... 20)
173-- 1
174inf :: Interval a -> a
175inf (I a _) = a
176{-# INLINE inf #-}
177
178-- | The supremum (upper bound) of an interval
179--
180-- >>> sup (1 ... 20)
181-- 20
182sup :: Interval a -> a
183sup (I _ b) = b
184{-# INLINE sup #-}
185
186-- | Is the interval a singleton point?
187-- N.B. This is fairly fragile and likely will not hold after
188-- even a few operations that only involve singletons
189--
190-- >>> singular (singleton 1)
191-- True
192--
193-- >>> singular (1.0 ... 20.0)
194-- False
195singular :: Ord a => Interval a -> Bool
196singular x = not (null x) && inf x == sup x
197{-# INLINE singular #-}
198
199instance Eq a => Eq (Interval a) where
200 (==) = (==!)
201 {-# INLINE (==) #-}
202
203instance Show a => Show (Interval a) where
204 showsPrec n (I a b) =
205 showParen (n > 3) $
206 showsPrec 3 a .
207 showString " ... " .
208 showsPrec 3 b
209
210-- | Calculate the width of an interval.
211--
212-- >>> width (1 ... 20)
213-- 19
214--
215-- >>> width (singleton 1)
216-- 0
217--
218-- >>> width empty
219-- NaN
220width :: Num a => Interval a -> a
221width (I a b) = b - a
222{-# INLINE width #-}
223
224-- | Magnitude
225--
226-- >>> magnitude (1 ... 20)
227-- 20
228--
229-- >>> magnitude (-20 ... 10)
230-- 20
231--
232-- >>> magnitude (singleton 5)
233-- 5
234magnitude :: (Num a, Ord a) => Interval a -> a
235magnitude x = (max `on` abs) (inf x) (sup x)
236{-# INLINE magnitude #-}
237
238-- | \"mignitude\"
239--
240-- >>> mignitude (1 ... 20)
241-- 1
242--
243-- >>> mignitude (-20 ... 10)
244-- 10
245--
246-- >>> mignitude (singleton 5)
247-- 5
248mignitude :: (Num a, Ord a) => Interval a -> a
249mignitude x = (min `on` abs) (inf x) (sup x)
250{-# INLINE mignitude #-}
251
252instance (Num a, Ord a) => Num (Interval a) where
253 I a b + I a' b' = (a + a') ... (b + b')
254 {-# INLINE (+) #-}
255 I a b - I a' b' = (a - b') ... (b - a')
256 {-# INLINE (-) #-}
257 I a b * I a' b' =
258 minimum [a * a', a * b', b * a', b * b']
259 ...
260 maximum [a * a', a * b', b * a', b * b']
261 {-# INLINE (*) #-}
262 abs x@(I a b)
263 | a >= 0 = x
264 | b <= 0 = negate x
265 | otherwise = 0 ... max (- a) b
266 {-# INLINE abs #-}
267
268 signum = increasing signum
269 {-# INLINE signum #-}
270
271 fromInteger i = singleton (fromInteger i)
272 {-# INLINE fromInteger #-}
273
274-- | Bisect an interval at its midpoint.
275--
276-- >>> bisection (10.0 ... 20.0)
277-- (10.0 ... 15.0,15.0 ... 20.0)
278--
279-- >>> bisection (singleton 5.0)
280-- (5.0 ... 5.0,5.0 ... 5.0)
281--
282-- >>> bisection empty
283-- (NaN ... NaN,NaN ... NaN)
284bisection :: Fractional a => Interval a -> (Interval a, Interval a)
285bisection x = (inf x ... m, m ... sup x)
286 where m = midpoint x
287{-# INLINE bisection #-}
288
289-- | Nearest point to the midpoint of the interval.
290--
291-- >>> midpoint (10.0 ... 20.0)
292-- 15.0
293--
294-- >>> midpoint (singleton 5.0)
295-- 5.0
296--
297-- >>> midpoint empty
298-- NaN
299midpoint :: Fractional a => Interval a -> a
300midpoint x = inf x + (sup x - inf x) / 2
301{-# INLINE midpoint #-}
302
303-- | Determine if a point is in the interval.
304--
305-- >>> elem 3.2 (1.0 ... 5.0)
306-- True
307--
308-- >>> elem 5 (1.0 ... 5.0)
309-- True
310--
311-- >>> elem 1 (1.0 ... 5.0)
312-- True
313--
314-- >>> elem 8 (1.0 ... 5.0)
315-- False
316--
317-- >>> elem 5 empty
318-- False
319--
320elem :: Ord a => a -> Interval a -> Bool
321elem x xs = x >= inf xs && x <= sup xs
322{-# INLINE elem #-}
323
324-- | Determine if a point is not included in the interval
325--
326-- >>> notElem 8 (1.0 ... 5.0)
327-- True
328--
329-- >>> notElem 1.4 (1.0 ... 5.0)
330-- False
331--
332-- And of course, nothing is a member of the empty interval.
333--
334-- >>> notElem 5 empty
335-- True
336notElem :: Ord a => a -> Interval a -> Bool
337notElem x xs = not (elem x xs)
338{-# INLINE notElem #-}
339
340-- | 'realToFrac' will use the midpoint
341instance Real a => Real (Interval a) where
342 toRational x
343 | null x = nan
344 | otherwise = a + (b - a) / 2
345 where
346 a = toRational (inf x)
347 b = toRational (sup x)
348 {-# INLINE toRational #-}
349
350instance Ord a => Ord (Interval a) where
351 compare x y
352 | sup x < inf y = LT
353 | inf x > sup y = GT
354 | sup x == inf y && inf x == sup y = EQ
355 | otherwise = error "Numeric.Interval.compare: ambiguous comparison"
356 {-# INLINE compare #-}
357
358 max (I a b) (I a' b') = max a a' ... max b b'
359 {-# INLINE max #-}
360
361 min (I a b) (I a' b') = min a a' ... min b b'
362 {-# INLINE min #-}
363
364-- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@
365divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a
366divNonZero (I a b) (I a' b') =
367 minimum [a / a', a / b', b / a', b / b']
368 ...
369 maximum [a / a', a / b', b / a', b / b']
370
371-- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y]
372divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a
373divPositive x@(I a b) y
374 | a == 0 && b == 0 = x
375 -- b < 0 || isNegativeZero b = negInfinity ... ( b / y)
376 | b < 0 = negInfinity ... ( b / y)
377 | a < 0 = whole
378 | otherwise = (a / y) ... posInfinity
379{-# INLINE divPositive #-}
380
381-- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0]
382divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a
383divNegative x@(I a b) y
384 | a == 0 && b == 0 = - x -- flip negative zeros
385 -- b < 0 || isNegativeZero b = (b / y) ... posInfinity
386 | b < 0 = (b / y) ... posInfinity
387 | a < 0 = whole
388 | otherwise = negInfinity ... (a / y)
389{-# INLINE divNegative #-}
390
391divZero :: (Fractional a, Ord a) => Interval a -> Interval a
392divZero x
393 | inf x == 0 && sup x == 0 = x
394 | otherwise = whole
395{-# INLINE divZero #-}
396
397instance (Fractional a, Ord a) => Fractional (Interval a) where
398 -- TODO: check isNegativeZero properly
399 x / y
400 | 0 `notElem` y = divNonZero x y
401 | iz && sz = empty -- division by 0
402 | iz = divPositive x (inf y)
403 | sz = divNegative x (sup y)
404 | otherwise = divZero x
405 where
406 iz = inf y == 0
407 sz = sup y == 0
408 recip (I a b) = on min recip a b ... on max recip a b
409 {-# INLINE recip #-}
410 fromRational r = let r' = fromRational r in r' ... r'
411 {-# INLINE fromRational #-}
412
413instance RealFrac a => RealFrac (Interval a) where
414 properFraction x = (b, x - fromIntegral b)
415 where
416 b = truncate (midpoint x)
417 {-# INLINE properFraction #-}
418 ceiling x = ceiling (sup x)
419 {-# INLINE ceiling #-}
420 floor x = floor (inf x)
421 {-# INLINE floor #-}
422 round x = round (midpoint x)
423 {-# INLINE round #-}
424 truncate x = truncate (midpoint x)
425 {-# INLINE truncate #-}
426
427instance (RealFloat a, Ord a) => Floating (Interval a) where
428 pi = singleton pi
429 {-# INLINE pi #-}
430 exp = increasing exp
431 {-# INLINE exp #-}
432 log (I a b) = (if a > 0 then log a else negInfinity) ... log b
433 {-# INLINE log #-}
434 cos x
435 | null x = empty
436 | width t >= pi = (-1) ... 1
437 | inf t >= pi = - cos (t - pi)
438 | sup t <= pi = decreasing cos t
439 | sup t <= 2 * pi = (-1) ... cos ((pi * 2 - sup t) `min` inf t)
440 | otherwise = (-1) ... 1
441 where
442 t = fmod x (pi * 2)
443 {-# INLINE cos #-}
444 sin x
445 | null x = empty
446 | otherwise = cos (x - pi / 2)
447 {-# INLINE sin #-}
448 tan x
449 | null x = empty
450 | inf t' <= - pi / 2 || sup t' >= pi / 2 = whole
451 | otherwise = increasing tan x
452 where
453 t = x `fmod` pi
454 t' | t >= pi / 2 = t - pi
455 | otherwise = t
456 {-# INLINE tan #-}
457 asin x@(I a b)
458 | null x || b < -1 || a > 1 = empty
459 | otherwise =
460 (if a <= -1 then -halfPi else asin a)
461 ...
462 (if b >= 1 then halfPi else asin b)
463 where
464 halfPi = pi / 2
465 {-# INLINE asin #-}
466 acos x@(I a b)
467 | null x || b < -1 || a > 1 = empty
468 | otherwise =
469 (if b >= 1 then 0 else acos b)
470 ...
471 (if a < -1 then pi else acos a)
472 {-# INLINE acos #-}
473 atan = increasing atan
474 {-# INLINE atan #-}
475 sinh = increasing sinh
476 {-# INLINE sinh #-}
477 cosh x@(I a b)
478 | null x = empty
479 | b < 0 = decreasing cosh x
480 | a >= 0 = increasing cosh x
481 | otherwise = I 0 $ cosh $ if - a > b
482 then a
483 else b
484 {-# INLINE cosh #-}
485 tanh = increasing tanh
486 {-# INLINE tanh #-}
487 asinh = increasing asinh
488 {-# INLINE asinh #-}
489 acosh x@(I a b)
490 | null x || b < 1 = empty
491 | otherwise = I lo $ acosh b
492 where lo | a <= 1 = 0
493 | otherwise = acosh a
494 {-# INLINE acosh #-}
495 atanh x@(I a b)
496 | null x || b < -1 || a > 1 = empty
497 | otherwise =
498 (if a <= - 1 then negInfinity else atanh a)
499 ...
500 (if b >= 1 then posInfinity else atanh b)
501 {-# INLINE atanh #-}
502
503-- | lift a monotone increasing function over a given interval
504increasing :: (a -> b) -> Interval a -> Interval b
505increasing f (I a b) = f a ... f b
506
507-- | lift a monotone decreasing function over a given interval
508decreasing :: (a -> b) -> Interval a -> Interval b
509decreasing f (I a b) = f b ... f a
510
511-- | We have to play some semantic games to make these methods make sense.
512-- Most compute with the midpoint of the interval.
513instance RealFloat a => RealFloat (Interval a) where
514 floatRadix = floatRadix . midpoint
515
516 floatDigits = floatDigits . midpoint
517 floatRange = floatRange . midpoint
518 decodeFloat = decodeFloat . midpoint
519 encodeFloat m e = singleton (encodeFloat m e)
520 exponent = exponent . midpoint
521 significand x = min a b ... max a b
522 where
523 (_ ,em) = decodeFloat (midpoint x)
524 (mi,ei) = decodeFloat (inf x)
525 (ms,es) = decodeFloat (sup x)
526 a = encodeFloat mi (ei - em - floatDigits x)
527 b = encodeFloat ms (es - em - floatDigits x)
528 scaleFloat n x = scaleFloat n (inf x) ... scaleFloat n (sup x)
529 isNaN x = isNaN (inf x) || isNaN (sup x)
530 isInfinite x = isInfinite (inf x) || isInfinite (sup x)
531 isDenormalized x = isDenormalized (inf x) || isDenormalized (sup x)
532 -- contains negative zero
533 isNegativeZero x = not (inf x > 0)
534 && not (sup x < 0)
535 && ( (sup x == 0 && (inf x < 0 || isNegativeZero (inf x)))
536 || (inf x == 0 && isNegativeZero (inf x))
537 || (inf x < 0 && sup x >= 0))
538 isIEEE x = isIEEE (inf x) && isIEEE (sup x)
539 atan2 = error "unimplemented"
540
541-- TODO: (^), (^^) to give tighter bounds
542
543-- | Calculate the intersection of two intervals.
544--
545-- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double)
546-- 5.0 ... 10.0
547intersection :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a
548intersection x@(I a b) y@(I a' b')
549 | x /=! y = empty
550 | otherwise = max a a' ... min b b'
551{-# INLINE intersection #-}
552
553-- | Calculate the convex hull of two intervals
554--
555-- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double)
556-- 0.0 ... 15.0
557--
558-- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double)
559-- 0.0 ... 85.0
560hull :: Ord a => Interval a -> Interval a -> Interval a
561hull x@(I a b) y@(I a' b')
562 | null x = y
563 | null y = x
564 | otherwise = min a a' ... max b b'
565{-# INLINE hull #-}
566
567-- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@
568--
569-- >>> (5 ... 10 :: Interval Double) <! (20 ... 30 :: Interval Double)
570-- True
571--
572-- >>> (5 ... 10 :: Interval Double) <! (10 ... 30 :: Interval Double)
573-- False
574--
575-- >>> (20 ... 30 :: Interval Double) <! (5 ... 10 :: Interval Double)
576-- False
577(<!) :: Ord a => Interval a -> Interval a -> Bool
578x <! y = sup x < inf y
579{-# INLINE (<!) #-}
580
581-- | For all @x@ in @X@, @y@ in @Y@. @x '<=' y@
582--
583-- >>> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double)
584-- True
585--
586-- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double)
587-- True
588--
589-- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double)
590-- False
591(<=!) :: Ord a => Interval a -> Interval a -> Bool
592x <=! y = sup x <= inf y
593{-# INLINE (<=!) #-}
594
595-- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@
596--
597-- Only singleton intervals return true
598--
599-- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double)
600-- True
601--
602-- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double)
603-- False
604(==!) :: Eq a => Interval a -> Interval a -> Bool
605x ==! y = sup x == inf y && inf x == sup y
606{-# INLINE (==!) #-}
607
608-- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@
609--
610-- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double)
611-- True
612--
613-- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double)
614-- False
615(/=!) :: Ord a => Interval a -> Interval a -> Bool
616x /=! y = sup x < inf y || inf x > sup y
617{-# INLINE (/=!) #-}
618
619-- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@
620--
621-- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double)
622-- True
623--
624-- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double)
625-- False
626(>!) :: Ord a => Interval a -> Interval a -> Bool
627x >! y = inf x > sup y
628{-# INLINE (>!) #-}
629
630-- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@
631--
632-- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double)
633-- True
634--
635-- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double)
636-- False
637(>=!) :: Ord a => Interval a -> Interval a -> Bool
638x >=! y = inf x >= sup y
639{-# INLINE (>=!) #-}
640
641-- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@
642--
643--
644certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
645certainly cmp l r
646 | lt && eq && gt = True
647 | lt && eq = l <=! r
648 | lt && gt = l /=! r
649 | lt = l <! r
650 | eq && gt = l >=! r
651 | eq = l ==! r
652 | gt = l >! r
653 | otherwise = False
654 where
655 lt = cmp LT EQ
656 eq = cmp EQ EQ
657 gt = cmp GT EQ
658{-# INLINE certainly #-}
659
660-- | Check if interval @X@ totally contains interval @Y@
661--
662-- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double)
663-- True
664--
665-- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double)
666-- False
667contains :: Ord a => Interval a -> Interval a -> Bool
668contains x y = null y
669 || (not (null x) && inf x <= inf y && sup y <= sup x)
670{-# INLINE contains #-}
671
672-- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@
673--
674-- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double)
675-- True
676--
677-- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double)
678-- False
679isSubsetOf :: Ord a => Interval a -> Interval a -> Bool
680isSubsetOf = flip contains
681{-# INLINE isSubsetOf #-}
682
683-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
684(<?) :: Ord a => Interval a -> Interval a -> Bool
685x <? y = inf x < sup y
686{-# INLINE (<?) #-}
687
688-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
689(<=?) :: Ord a => Interval a -> Interval a -> Bool
690x <=? y = inf x <= sup y
691{-# INLINE (<=?) #-}
692
693-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
694(==?) :: Ord a => Interval a -> Interval a -> Bool
695x ==? y = inf x <= sup y && sup x >= inf y
696{-# INLINE (==?) #-}
697
698-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
699(/=?) :: Eq a => Interval a -> Interval a -> Bool
700x /=? y = inf x /= sup y || sup x /= inf y
701{-# INLINE (/=?) #-}
702
703-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
704(>?) :: Ord a => Interval a -> Interval a -> Bool
705x >? y = sup x > inf y
706{-# INLINE (>?) #-}
707
708-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
709(>=?) :: Ord a => Interval a -> Interval a -> Bool
710x >=? y = sup x >= inf y
711{-# INLINE (>=?) #-}
712
713-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@?
714possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
715possibly cmp l r
716 | lt && eq && gt = True
717 | lt && eq = l <=? r
718 | lt && gt = l /=? r
719 | lt = l <? r
720 | eq && gt = l >=? r
721 | eq = l ==? r
722 | gt = l >? r
723 | otherwise = False
724 where
725 lt = cmp LT EQ
726 eq = cmp EQ EQ
727 gt = cmp GT EQ
728{-# INLINE possibly #-}
729
730-- | The nearest value to that supplied which is contained in the interval.
731clamp :: Ord a => Interval a -> a -> a
732clamp (I a b) x | x < a = a
733 | x > b = b
734 | otherwise = x
735
736-- | id function. Useful for type specification
737--
738-- >>> :t idouble (1 ... 3)
739-- idouble (1 ... 3) :: Interval Double
740idouble :: Interval Double -> Interval Double
741idouble = id
742
743-- | id function. Useful for type specification
744--
745-- >>> :t ifloat (1 ... 3)
746-- ifloat (1 ... 3) :: Interval Float
747ifloat :: Interval Float -> Interval Float
748ifloat = id
749
750-- Bugs:
751-- sin 1 :: Interval Double
752
753
754default (Integer,Double)
diff --git a/lib/Numeric/Interval/Bounded.hs b/lib/Numeric/Interval/Bounded.hs
new file mode 100644
index 0000000..2dd4d7b
--- /dev/null
+++ b/lib/Numeric/Interval/Bounded.hs
@@ -0,0 +1,9 @@
1module Numeric.Interval.Bounded where
2
3import Numeric.Interval
4
5whole' :: Bounded a => Interval a
6whole' = ( minBound ... maxBound )
7
8empty' :: Bounded a => Interval a
9empty' = ( maxBound ... minBound )
diff --git a/PEM.hs b/lib/PEM.hs
index e07b3d4..e07b3d4 100644
--- a/PEM.hs
+++ b/lib/PEM.hs
diff --git a/ProcessUtils.hs b/lib/ProcessUtils.hs
index 4e3ac38..4e3ac38 100644
--- a/ProcessUtils.hs
+++ b/lib/ProcessUtils.hs
diff --git a/ScanningParser.hs b/lib/ScanningParser.hs
index f99e120..f99e120 100644
--- a/ScanningParser.hs
+++ b/lib/ScanningParser.hs
diff --git a/lib/SuperOrd.hs b/lib/SuperOrd.hs
new file mode 100644
index 0000000..258a823
--- /dev/null
+++ b/lib/SuperOrd.hs
@@ -0,0 +1,23 @@
1module SuperOrd where
2
3data SuperOrd a
4 = NegativeInfinity
5 | SuperOrd { superApprox :: !a
6 , superCompareApprox :: !Ordering
7 }
8 | PositiveInfinity
9 deriving (Eq, Ord, Show)
10
11instance Bounded (SuperOrd a) where
12 minBound = NegativeInfinity
13 maxBound = PositiveInfinity
14
15exactly :: a -> SuperOrd a
16exactly a = SuperOrd a EQ
17
18lessThan :: a -> SuperOrd a
19lessThan a = SuperOrd a LT
20
21greaterThan :: a -> SuperOrd a
22greaterThan a = SuperOrd a GT
23
diff --git a/TimeUtil.hs b/lib/TimeUtil.hs
index 879bc32..879bc32 100644
--- a/TimeUtil.hs
+++ b/lib/TimeUtil.hs
diff --git a/dotlock.c b/lib/dotlock.c
index c111159..c111159 100644
--- a/dotlock.c
+++ b/lib/dotlock.c
diff --git a/dotlock.h b/lib/dotlock.h
index 3fb9bcb..3fb9bcb 100644
--- a/dotlock.h
+++ b/lib/dotlock.h
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-08 06:14:06 +0000