{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# OPTIONS_GHC -fno-warn-unused-imports#-}

module Data.KeyStore.Sections
  ( SECTIONS(..)
  , Code(..)
  , Sections(..)
  , SectionType(..)
  , KeyData(..)
  , KeyDataMode(..)
  , KeyPredicate
  , RetrieveDg(..)
  , initialise
  , rotate
  , rotateIfChanged
  , rotate_
  , retrieve
  , signKeystore
  , verifyKeystore
  , noKeys
  , allKeys
  , listKeys
  , keyPrededicate
  , keyHelp
  , sectionHelp
  , secretKeySummary
  , publicKeySummary
  , locateKeys
  , keyName
  , keyName_
  , passwordName
  , mkSection
  )
  where

import           Data.KeyStore.IO
import           Data.KeyStore.KS
import qualified Data.KeyStore.Types.AesonCompat  as A
import qualified Data.Text                        as T
import qualified Data.ByteString.Char8            as B
import qualified Data.ByteString.Lazy.Char8       as LBS
import qualified Data.HashMap.Strict              as HM
import qualified Data.Vector                      as V
import qualified Data.Map                         as Map
import           Data.API.Types
import           Data.Maybe
import           Data.List
import           Data.Char
import           Data.Ord
import           Data.String
import           Data.Monoid
import           Control.Lens(over)
import           Control.Applicative
import           Control.Monad
import           Text.Printf
import           System.FilePath
import           Safe


data SECTIONS h s k = SECTIONS


class (Bounded a,Enum a,Eq a, Ord a,Show a) => Code a where
    encode :: a -> String

    decode :: String -> Maybe a
    decode [Char]
s = forall a. [a] -> Maybe a
listToMaybe [ a
k | a
k<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], forall a. Code a => a -> [Char]
encode a
kforall a. Eq a => a -> a -> Bool
==[Char]
s ]


-- | This class describes the relationship between the host-id, section-id
-- and key-id types used to build a hierarchical deployment model for a
-- keystore. A minimal instance would have to define hostDeploySection.
-- The deploy example program contains a fairly thorough example of this
-- class being used to implement a quite realitic deploymrnt scenario.
class (Code h, Code s, Code k) => Sections h s k
    | s -> h, k -> h
    , h -> s, k -> s
    , s -> k, h -> k
    where
  hostDeploySection   :: h -> s                           -- ^ the deployment section: for a given host,
                                                          -- the starting section for locating the keys
                                                          -- during a deployment ('higher'/closer sections
                                                          -- taking priority)
  sectionType         :: s -> SectionType                 -- ^ whether the section holds the top key for the
                                                          -- keystore (i.e., keystore master key), the signing key
                                                          -- for the keystore or is a normal section containing
                                                          -- deployment keys
  superSections       :: s -> [s]                         -- ^ the sections that get a copy of the master
                                                          -- for this section (making all of its keys
                                                          -- available to them); N.B., the graph formed by this
                                                          -- this relationship over the sections must be acyclic
  keyIsHostIndexed    :: k -> Maybe (h->Bool)             -- ^ if the key is host-indexed then the predicate
                                                          -- specifies the hosts that use this key
  keyIsInSection      :: k -> s -> Bool                   -- ^ specifies which sections a key is resident in
  getKeyData          :: Maybe h -> s -> k -> IO KeyData  -- ^ loads the data for a particular key
  getKeyDataWithMode  :: Maybe h -> s -> k -> IO (KeyDataMode,KeyData)
                                                          -- ^ loads the data for a particular key, returning mode
  sectionSettings     :: Maybe s -> IO Settings           -- ^ loads the setting for a given settings
  describeKey         :: k -> String                      -- ^ describes the key (for the ks help command)
  describeSection     :: s -> String                      -- ^ describes the section (for the ks help command)
  sectionPWEnvVar     :: s -> EnvVar                      -- ^ secifies the environment variable containing the
                                                          -- ^ master password/provate key for for the given section

  sectionType                   = forall a b. a -> b -> a
const SectionType
ST_keys

  superSections                 = forall a b. a -> b -> a
const []

  keyIsHostIndexed              = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

  keyIsInSection                = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True

  getKeyData          Maybe h
mb s
s k
k    = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k.
Sections h s k =>
Maybe h -> s -> k -> IO (KeyDataMode, KeyData)
getKeyDataWithMode Maybe h
mb s
s k
k

  getKeyDataWithMode Maybe h
Nothing  s
s = forall h s k.
Sections h s k =>
[Char] -> k -> IO (KeyDataMode, KeyData)
get_kd forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode s
s
  getKeyDataWithMode (Just h
h) s
_ = forall h s k.
Sections h s k =>
[Char] -> k -> IO (KeyDataMode, KeyData)
get_kd forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode h
h

  sectionSettings               = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

  describeKey         k
k         = [Char]
"The '" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode k
k forall a. [a] -> [a] -> [a]
++ [Char]
"' key."

  describeSection     s
s         = [Char]
"The '" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s forall a. [a] -> [a] -> [a]
++ [Char]
"' Section."

  sectionPWEnvVar               = Text -> EnvVar
EnvVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"KEY_pw_" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Code a => a -> [Char]
encode


-- | Sections are used to hold the top (master) key for the keystore,
-- its signing key, or deployment keys
data SectionType
  = ST_top
  | ST_signing
  | ST_keys
  deriving (Int -> SectionType -> [Char] -> [Char]
[SectionType] -> [Char] -> [Char]
SectionType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SectionType] -> [Char] -> [Char]
$cshowList :: [SectionType] -> [Char] -> [Char]
show :: SectionType -> [Char]
$cshow :: SectionType -> [Char]
showsPrec :: Int -> SectionType -> [Char] -> [Char]
$cshowsPrec :: Int -> SectionType -> [Char] -> [Char]
Show,SectionType -> SectionType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SectionType -> SectionType -> Bool
$c/= :: SectionType -> SectionType -> Bool
== :: SectionType -> SectionType -> Bool
$c== :: SectionType -> SectionType -> Bool
Eq,Eq SectionType
SectionType -> SectionType -> Bool
SectionType -> SectionType -> Ordering
SectionType -> SectionType -> SectionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SectionType -> SectionType -> SectionType
$cmin :: SectionType -> SectionType -> SectionType
max :: SectionType -> SectionType -> SectionType
$cmax :: SectionType -> SectionType -> SectionType
>= :: SectionType -> SectionType -> Bool
$c>= :: SectionType -> SectionType -> Bool
> :: SectionType -> SectionType -> Bool
$c> :: SectionType -> SectionType -> Bool
<= :: SectionType -> SectionType -> Bool
$c<= :: SectionType -> SectionType -> Bool
< :: SectionType -> SectionType -> Bool
$c< :: SectionType -> SectionType -> Bool
compare :: SectionType -> SectionType -> Ordering
$ccompare :: SectionType -> SectionType -> Ordering
Ord)

-- | A key is  triple containing some (plain-text) identity information for the
-- key, some comment text and the secret text to be encrypted. Note that
-- the keystore doesn't rely on this information but merely stores it. (They
-- can be empty.) The identity field will often be used to storte the key's
-- identity within the system that generates and uses it, ofor example.
data KeyData =
  KeyData
    { KeyData -> Identity
kd_identity :: Identity
    , KeyData -> Comment
kd_comment  :: Comment
    , KeyData -> ByteString
kd_secret   :: B.ByteString
    }
  deriving (Int -> KeyData -> [Char] -> [Char]
[KeyData] -> [Char] -> [Char]
KeyData -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [KeyData] -> [Char] -> [Char]
$cshowList :: [KeyData] -> [Char] -> [Char]
show :: KeyData -> [Char]
$cshow :: KeyData -> [Char]
showsPrec :: Int -> KeyData -> [Char] -> [Char]
$cshowsPrec :: Int -> KeyData -> [Char] -> [Char]
Show,KeyData -> KeyData -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyData -> KeyData -> Bool
$c/= :: KeyData -> KeyData -> Bool
== :: KeyData -> KeyData -> Bool
$c== :: KeyData -> KeyData -> Bool
Eq)

data KeyDataMode
  = KDM_static
  | KDM_random
  deriving (KeyDataMode
forall a. a -> a -> Bounded a
maxBound :: KeyDataMode
$cmaxBound :: KeyDataMode
minBound :: KeyDataMode
$cminBound :: KeyDataMode
Bounded,Int -> KeyDataMode
KeyDataMode -> Int
KeyDataMode -> [KeyDataMode]
KeyDataMode -> KeyDataMode
KeyDataMode -> KeyDataMode -> [KeyDataMode]
KeyDataMode -> KeyDataMode -> KeyDataMode -> [KeyDataMode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: KeyDataMode -> KeyDataMode -> KeyDataMode -> [KeyDataMode]
$cenumFromThenTo :: KeyDataMode -> KeyDataMode -> KeyDataMode -> [KeyDataMode]
enumFromTo :: KeyDataMode -> KeyDataMode -> [KeyDataMode]
$cenumFromTo :: KeyDataMode -> KeyDataMode -> [KeyDataMode]
enumFromThen :: KeyDataMode -> KeyDataMode -> [KeyDataMode]
$cenumFromThen :: KeyDataMode -> KeyDataMode -> [KeyDataMode]
enumFrom :: KeyDataMode -> [KeyDataMode]
$cenumFrom :: KeyDataMode -> [KeyDataMode]
fromEnum :: KeyDataMode -> Int
$cfromEnum :: KeyDataMode -> Int
toEnum :: Int -> KeyDataMode
$ctoEnum :: Int -> KeyDataMode
pred :: KeyDataMode -> KeyDataMode
$cpred :: KeyDataMode -> KeyDataMode
succ :: KeyDataMode -> KeyDataMode
$csucc :: KeyDataMode -> KeyDataMode
Enum,KeyDataMode -> KeyDataMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyDataMode -> KeyDataMode -> Bool
$c/= :: KeyDataMode -> KeyDataMode -> Bool
== :: KeyDataMode -> KeyDataMode -> Bool
$c== :: KeyDataMode -> KeyDataMode -> Bool
Eq,Eq KeyDataMode
KeyDataMode -> KeyDataMode -> Bool
KeyDataMode -> KeyDataMode -> Ordering
KeyDataMode -> KeyDataMode -> KeyDataMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KeyDataMode -> KeyDataMode -> KeyDataMode
$cmin :: KeyDataMode -> KeyDataMode -> KeyDataMode
max :: KeyDataMode -> KeyDataMode -> KeyDataMode
$cmax :: KeyDataMode -> KeyDataMode -> KeyDataMode
>= :: KeyDataMode -> KeyDataMode -> Bool
$c>= :: KeyDataMode -> KeyDataMode -> Bool
> :: KeyDataMode -> KeyDataMode -> Bool
$c> :: KeyDataMode -> KeyDataMode -> Bool
<= :: KeyDataMode -> KeyDataMode -> Bool
$c<= :: KeyDataMode -> KeyDataMode -> Bool
< :: KeyDataMode -> KeyDataMode -> Bool
$c< :: KeyDataMode -> KeyDataMode -> Bool
compare :: KeyDataMode -> KeyDataMode -> Ordering
$ccompare :: KeyDataMode -> KeyDataMode -> Ordering
Ord,Int -> KeyDataMode -> [Char] -> [Char]
[KeyDataMode] -> [Char] -> [Char]
KeyDataMode -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [KeyDataMode] -> [Char] -> [Char]
$cshowList :: [KeyDataMode] -> [Char] -> [Char]
show :: KeyDataMode -> [Char]
$cshow :: KeyDataMode -> [Char]
showsPrec :: Int -> KeyDataMode -> [Char] -> [Char]
$cshowsPrec :: Int -> KeyDataMode -> [Char] -> [Char]
Show)

-- | One, many or all of the keys in a store may be rotated at a time.
-- we use one of these to specify which keys are to be rotated.
type KeyPredicate h s k = Maybe h -> s -> k -> Bool

-- | Requests to retrieve a key from the staor can fail for various reasons.

type Retrieve a = Either RetrieveDg a

-- | This type specifies the reasons that an attempt to access a key from the
-- store has failed. This kind of failure suggests an inconsistent model
-- and will be raised regardless of which keys have been stored in the store.
data RetrieveDg
  = RDG_key_not_reachable
  | RDG_no_such_host_key
  deriving (Int -> RetrieveDg -> [Char] -> [Char]
[RetrieveDg] -> [Char] -> [Char]
RetrieveDg -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [RetrieveDg] -> [Char] -> [Char]
$cshowList :: [RetrieveDg] -> [Char] -> [Char]
show :: RetrieveDg -> [Char]
$cshow :: RetrieveDg -> [Char]
showsPrec :: Int -> RetrieveDg -> [Char] -> [Char]
$cshowsPrec :: Int -> RetrieveDg -> [Char] -> [Char]
Show,RetrieveDg -> RetrieveDg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RetrieveDg -> RetrieveDg -> Bool
$c/= :: RetrieveDg -> RetrieveDg -> Bool
== :: RetrieveDg -> RetrieveDg -> Bool
$c== :: RetrieveDg -> RetrieveDg -> Bool
Eq,Eq RetrieveDg
RetrieveDg -> RetrieveDg -> Bool
RetrieveDg -> RetrieveDg -> Ordering
RetrieveDg -> RetrieveDg -> RetrieveDg
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RetrieveDg -> RetrieveDg -> RetrieveDg
$cmin :: RetrieveDg -> RetrieveDg -> RetrieveDg
max :: RetrieveDg -> RetrieveDg -> RetrieveDg
$cmax :: RetrieveDg -> RetrieveDg -> RetrieveDg
>= :: RetrieveDg -> RetrieveDg -> Bool
$c>= :: RetrieveDg -> RetrieveDg -> Bool
> :: RetrieveDg -> RetrieveDg -> Bool
$c> :: RetrieveDg -> RetrieveDg -> Bool
<= :: RetrieveDg -> RetrieveDg -> Bool
$c<= :: RetrieveDg -> RetrieveDg -> Bool
< :: RetrieveDg -> RetrieveDg -> Bool
$c< :: RetrieveDg -> RetrieveDg -> Bool
compare :: RetrieveDg -> RetrieveDg -> Ordering
$ccompare :: RetrieveDg -> RetrieveDg -> Ordering
Ord)

-- | Here we create the store and rotate in a buch of keys. N.B. All of the
-- section passwords must be bound in the process environment before calling
-- procedure.
initialise :: Sections h s k => CtxParams -> KeyPredicate h s k -> IO ()
initialise :: forall h s k.
Sections h s k =>
CtxParams -> KeyPredicate h s k -> IO ()
initialise CtxParams
cp KeyPredicate h s k
kp = do
    Settings
stgs <- forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt Bool
opt__sections_fix Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k.
Sections h s k =>
KeyPredicate h s k -> Maybe s -> IO Settings
scs KeyPredicate h s k
kp forall a. Maybe a
Nothing
    [Char] -> Settings -> IO ()
newKeyStore (CtxParams -> [Char]
the_keystore CtxParams
cp) Settings
stgs
    IC
ic <- CtxParams -> IO IC
instanceCtx CtxParams
cp
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall h s k.
Sections h s k =>
KeyPredicate h s k -> IC -> s -> IO ()
mks KeyPredicate h s k
kp IC
ic) [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound]
    forall h s k. Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotate IC
ic KeyPredicate h s k
kp
    forall a b. (a -> b) -> [a] -> [b]
map Key -> Name
_key_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO [Key]
keys IC
ic forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IC -> Name -> IO ()
keyInfo IC
ic)
  where
    scs :: Sections h s k => KeyPredicate h s k -> Maybe s -> IO Settings
    scs :: forall h s k.
Sections h s k =>
KeyPredicate h s k -> Maybe s -> IO Settings
scs = forall a b. a -> b -> a
const forall h s k. Sections h s k => Maybe s -> IO Settings
sectionSettings

    mks :: Sections h s k => KeyPredicate h s k -> IC -> s -> IO ()
    mks :: forall h s k.
Sections h s k =>
KeyPredicate h s k -> IC -> s -> IO ()
mks = forall a b. a -> b -> a
const forall h s k. Sections h s k => IC -> s -> IO ()
mkSection

-- | Rotate in a set of keys specified by the predicate.
rotate :: Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotate :: forall h s k. Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotate IC
ic = forall h s k.
Sections h s k =>
IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic forall a. Maybe a
Nothing Bool
False

-- | Rotate in a set of keys specified by the predicate, rotating each key only
-- if it has changed: NB the check is contingent on the secret text being
-- accessible; if the secret text is not accessible then the rotation will happen.
rotateIfChanged :: Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotateIfChanged :: forall h s k. Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotateIfChanged IC
ic = forall h s k.
Sections h s k =>
IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic forall a. Maybe a
Nothing Bool
True

-- | Rotate in a set of keys specified by the predicate with the first argument
-- controlling whether to squash duplicate rotations
rotate_ :: Sections h s k => IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ :: forall h s k.
Sections h s k =>
IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic Maybe KeyDataMode
mb Bool
ch KeyPredicate h s k
kp = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall h s k.
Sections h s k =>
Maybe KeyDataMode -> Bool -> IC -> Maybe h -> s -> k -> IO ()
rotate' Maybe KeyDataMode
mb Bool
ch IC
ic Maybe h
mb_h s
s k
k | (Maybe h
mb_h,s
s,k
k)<-forall h s k.
Sections h s k =>
KeyPredicate h s k -> [(Maybe h, s, k)]
listKeys KeyPredicate h s k
kp ]
  where
    ic' :: REFORMAT h s k
ic' = forall h s k. KeyPredicate h s k -> IC -> REFORMAT h s k
kp_RFT KeyPredicate h s k
kp IC
ic

-- | Retrieve the keys for a given host from the store. Note that the whole history for the given key is returned.
-- Note also that the secret text may not be present if it is not accessible (depnding upon hwich section passwords
-- are correctly bound in the process environment). Note also that the 'Retrieve' diagnostic should not fail if a
-- coherent model has been ddefined for 'Sections'.
retrieve :: Sections h s k => IC -> h -> k -> IO (Retrieve [Key])
retrieve :: forall h s k. Sections h s k => IC -> h -> k -> IO (Retrieve [Key])
retrieve IC
ic h
h k
k = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat forall {s} {k}. REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (\Name
nm->forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k. Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys forall {s} {k}. REFORMAT h s k
ic' Name
nm) forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => h -> k -> Retrieve Name
keyName h
h k
k
  where
    ic' :: REFORMAT h s k
ic' = forall h s k. h -> IC -> REFORMAT h s k
h_RFT h
h IC
ic

-- | Sign the keystore. (Requites the password for the signing section to be correctly
-- bound in the environment)
signKeystore :: Sections h s k => IC -> SECTIONS h s k -> IO B.ByteString
signKeystore :: forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> IO ByteString
signKeystore IC
ic SECTIONS h s k
scn = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile (CtxParams -> [Char]
the_keystore forall a b. (a -> b) -> a -> b
$ IC -> CtxParams
ic_ctx_params IC
ic) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IC -> Name -> ByteString -> IO ByteString
sign_ IC
ic (forall h s k. Sections h s k => s -> Name
sgn_nme forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => SECTIONS h s k -> s
signing_key SECTIONS h s k
scn)
  where
    ic' :: REFORMAT h s k
ic' = forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
scn IC
ic

-- Verify that the signature for a keystore matches the keystore.
verifyKeystore :: Sections h s k => IC -> SECTIONS h s k -> B.ByteString -> IO Bool
verifyKeystore :: forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> ByteString -> IO Bool
verifyKeystore IC
ic SECTIONS h s k
scn ByteString
sig = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile (CtxParams -> [Char]
the_keystore forall a b. (a -> b) -> a -> b
$ IC -> CtxParams
ic_ctx_params IC
ic) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (IC -> ByteString -> ByteString -> IO Bool
verify_ IC
ic) ByteString
sig
  where
    ic' :: REFORMAT h s k
ic' = forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
scn IC
ic

-- | A predicate specifying all of the keys in the store.
noKeys :: KeyPredicate h s k
noKeys :: forall h s k. KeyPredicate h s k
noKeys Maybe h
_ s
_ k
_ = Bool
False

-- | A predicate specifying none of the keys in the keystore.
allKeys :: KeyPredicate h s k
allKeys :: forall h s k. KeyPredicate h s k
allKeys Maybe h
_ s
_ k
_ = Bool
True

-- | List all of the keys specified by a KeyPredicate
listKeys :: Sections h s k => KeyPredicate h s k -> [(Maybe h,s,k)]
listKeys :: forall h s k.
Sections h s k =>
KeyPredicate h s k -> [(Maybe h, s, k)]
listKeys KeyPredicate h s k
kp = [ (Maybe h, s, k)
trp | trp :: (Maybe h, s, k)
trp@(Maybe h
mb_h,s
s,k
k)<-[(Maybe h, s, k)]
host_keysforall a. [a] -> [a] -> [a]
++forall {a}. [(Maybe a, s, k)]
non_host_keys, KeyPredicate h s k
kp Maybe h
mb_h s
s k
k ]
  where
    host_keys :: [(Maybe h, s, k)]
host_keys     = [ (forall a. a -> Maybe a
Just h
h ,s
s,k
k) | k
k<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], Just h -> Bool
isp<-[forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k], h
h<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], h -> Bool
isp h
h, let s :: s
s = forall h s k. Sections h s k => h -> k -> s
key_section h
h k
k ]
    non_host_keys :: [(Maybe a, s, k)]
non_host_keys = [ (forall a. Maybe a
Nothing,s
s,k
k) | k
k<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], Maybe (h -> Bool)
Nothing <-[forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k], s
s<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection k
k s
s             ]

-- | A utility for specifing a slice of the keys in the store, optionally specifying
-- host section and key that should belong to the slice. (If the host is specified then
-- the resulting predicate will only include host-indexed keys belonging to the
-- given host.)
keyPrededicate :: Sections h s k => Maybe h -> Maybe s -> Maybe k -> KeyPredicate h s k
keyPrededicate :: forall h s k.
Sections h s k =>
Maybe h -> Maybe s -> Maybe k -> KeyPredicate h s k
keyPrededicate Maybe h
mbh Maybe s
mbs Maybe k
mbk Maybe h
mbh_ s
s k
k = Bool
h_ok Bool -> Bool -> Bool
&& Bool
s_ok Bool -> Bool -> Bool
&& Bool
k_ok
  where
    h_ok :: Bool
h_ok = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\h
h->forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (h
hforall a. Eq a => a -> a -> Bool
==) Maybe h
mbh_) Maybe h
mbh
    s_ok :: Bool
s_ok = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True                  (s
sforall a. Eq a => a -> a -> Bool
==)       Maybe s
mbs
    k_ok :: Bool
k_ok = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True                  (k
kforall a. Eq a => a -> a -> Bool
==)       Maybe k
mbk

-- Generate some help text for the keys. If no key is specified then they are
-- merely listed, otherwise the help for the given key is listed.
keyHelp :: Sections h s k => Maybe k -> T.Text
keyHelp :: forall h s k. Sections h s k => Maybe k -> Text
keyHelp x :: Maybe k
x@Maybe k
Nothing  = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Code a => a -> [Char]
encode) [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound forall a. a -> a -> a
`asTypeOf` forall a. HasCallStack => Maybe a -> a
fromJust Maybe k
x ]
keyHelp   (Just k
k) = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
f forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ (,) (forall a. Code a => a -> [Char]
encode k
k)    [Char]
""                         ]
    , [ (,) [Char]
"  hosts:"    [Char]
hln | Just [Char]
hln <- [Maybe [Char]
mb_hln] ]
    , [ (,) [Char]
"  sections:" [Char]
sln | Maybe [Char]
Nothing  <- [Maybe [Char]
mb_hln] ]
    ]) forall a. [a] -> [a] -> [a]
++ [Char]
"" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"  "forall a. [a] -> [a] -> [a]
++) ([Char] -> [[Char]]
lines forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => k -> [Char]
describeKey k
k) forall a. [a] -> [a] -> [a]
++ [[Char]
""]
  where
    mb_hln :: Maybe [Char]
mb_hln = forall a. Code a => (a -> Bool) -> [Char]
fmt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k
    sln :: [Char]
sln    = forall a. Code a => (a -> Bool) -> [Char]
fmt  forall a b. (a -> b) -> a -> b
$  forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection   k
k

    f :: ([Char], [Char]) -> [Char]
f      = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => [Char] -> r
printf [Char]
"%-10s %s"

-- Generate some help text for the sectionss. If no section is specified then they are
-- merely listed, otherwise the help for the given section is listed.
sectionHelp :: Sections h s k => Maybe s -> IO T.Text
sectionHelp :: forall h s k. Sections h s k => Maybe s -> IO Text
sectionHelp x :: Maybe s
x@Maybe s
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Code a => a -> [Char]
encode) [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound  forall a. a -> a -> a
`asTypeOf` forall a. HasCallStack => Maybe a -> a
fromJust Maybe s
x ]
sectionHelp   (Just s
s) = do
  Settings
stgs <- forall h s k. Sections h s k => Maybe s -> IO Settings
sectionSettings forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just s
s
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
f forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ (,) (forall a. Code a => a -> [Char]
encode s
s)          [Char]
typ  ]
    , [ (,) [Char]
"  p/w env var:"    [Char]
env  ]
    , [ (,) [Char]
"  hosts:"          [Char]
hln  ]
    , [ (,) [Char]
"  super sections:" [Char]
sln  ]
    , [ (,) [Char]
"  under sections:" [Char]
uln  ]
    , [ (,) [Char]
"  keys:"           [Char]
kln  ]
    , [ (,) [Char]
"  settings"        [Char]
""   ]
    ]) forall a. [a] -> [a] -> [a]
++ Settings -> [[Char]]
fmt_s Settings
stgs forall a. [a] -> [a] -> [a]
++ [Char]
"" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"  "forall a. [a] -> [a] -> [a]
++) ([Char] -> [[Char]]
lines forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> [Char]
describeSection s
s) forall a. [a] -> [a] -> [a]
++ [[Char]
""]
  where
    typ :: [Char]
typ = case forall h s k. Sections h s k => s -> SectionType
sectionType s
s of
        SectionType
ST_top     -> [Char]
"(top)"
        SectionType
ST_signing -> [Char]
"(signing)"
        SectionType
ST_keys    -> [Char]
"(keys)"
    env :: [Char]
env = [Char]
"$" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (EnvVar -> Text
_EnvVar forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s)
    hln :: [Char]
hln = [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [ forall a. Code a => a -> [Char]
encode h
h | h
h<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], forall h s k. Sections h s k => h -> s
hostDeploySection h
hforall a. Eq a => a -> a -> Bool
==s
s ]
    sln :: [Char]
sln = [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Code a => a -> [Char]
encode forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> [s]
superSections s
s
    uln :: [Char]
uln = [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Code a => a -> [Char]
encode forall a b. (a -> b) -> a -> b
$ [ s
s_ | s
s_<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], s
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall h s k. Sections h s k => s -> [s]
superSections s
s_ ]
    kln :: [Char]
kln = forall a. Code a => (a -> Bool) -> [Char]
fmt forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection s
s

    f :: ([Char], [Char]) -> [Char]
f   = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => [Char] -> r
printf [Char]
"%-20s %s"

    fmt_s :: Settings -> [[Char]]
fmt_s Settings
stgs = forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    "forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
LBS.unpack forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
A.encode forall a b. (a -> b) -> a -> b
$ Object -> Value
A.Object forall a b. (a -> b) -> a -> b
$ forall a. HashMap Text a -> KM a
A.intoKM forall a b. (a -> b) -> a -> b
$ Settings -> HashMap Text Value
_Settings Settings
stgs

-- | List a shell script for establishing all of the keys in the environment. NB For this
-- to work the password for the top section (or the passwords for all of the sections
-- must be bound if the store does not maintain a top key).
secretKeySummary :: Sections h s k => IC -> SECTIONS h s k -> IO T.Text
secretKeySummary :: forall h s k. Sections h s k => IC -> SECTIONS h s k -> IO Text
secretKeySummary IC
ic SECTIONS h s k
scn = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {h} {s} {k}. Sections h s k => s -> IO Text
f (forall h s k. Sections h s k => SECTIONS h s k -> [s]
sections SECTIONS h s k
scn)
  where
    f :: s -> IO Text
f s
s = do
      Text
sec <- [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
B.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IC -> Bool -> Name -> IO ByteString
showSecret IC
ic Bool
False forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> Name
passwordName s
s)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"export ",EnvVar -> Text
_EnvVar forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s,Text
"=",Text
sec]

    ic' :: REFORMAT h s k
ic' = forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
scn IC
ic

-- | List a shell script for storing the public signing key for the store.
publicKeySummary :: Sections h s k => IC -> SECTIONS h s k -> FilePath -> IO T.Text
publicKeySummary :: forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> [Char] -> IO Text
publicKeySummary IC
ic SECTIONS h s k
scn [Char]
fp = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ ByteString -> Text
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> Bool -> Name -> IO ByteString
showPublic IC
ic Bool
True (forall h s k. Sections h s k => s -> Name
sgn_nme forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => SECTIONS h s k -> s
signing_key SECTIONS h s k
scn)
  where
    f :: ByteString -> Text
f ByteString
b = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"echo '" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
B.unpack ByteString
b forall a. [a] -> [a] -> [a]
++ [Char]
"' >" forall a. [a] -> [a] -> [a]
++ [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

    ic' :: REFORMAT h s k
ic' = forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
scn IC
ic

-- | List all of the keys that have the given name as their prefix. If the
-- generic name of a key is given then it will list the complete history for
-- the key, the current (or most recent) entry first.
locateKeys :: Sections h s k => IC -> SECTIONS h s k -> Name -> IO [Key]
locateKeys :: forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> Name -> IO [Key]
locateKeys IC
ic SECTIONS h s k
scn Name
nm = forall h s k. Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys REFORMAT h s k
ic' Name
nm
  where
    ic' :: REFORMAT h s k
ic' = forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
scn IC
ic

locate_keys :: Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys :: forall h s k. Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys REFORMAT h s k
ic' Name
nm = forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Key -> Name
_key_name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Key -> Bool
yup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO [Key]
keys IC
ic
  where
    yup :: Key -> Bool
yup     = Name -> Bool
isp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Name
_key_name
    isp :: Name -> Bool
isp Name
nm' = [Char]
nm_s forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Name -> [Char]
_name Name
nm'
    nm_s :: [Char]
nm_s    = Name -> [Char]
_name Name
nm
    ic :: IC
ic      = forall h s k. REFORMAT h s k -> IC
_REFORMAT REFORMAT h s k
ic'

-- | Return the generic name for a given key thst is used by the specified
-- host, returning a failure diagnostic if the host does not have such a key
-- on the given Section model.
keyName :: Sections h s k => h -> k -> Retrieve Name
keyName :: forall h s k. Sections h s k => h -> k -> Retrieve Name
keyName h
h k
k = do
  Maybe h
mb_h <- case forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k of
            Maybe (h -> Bool)
Nothing             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just h -> Bool
hp | h -> Bool
hp h
h      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just h
h
                    | Bool
otherwise -> forall a b. a -> Either a b
Left RetrieveDg
RDG_no_such_host_key
  s
s <- forall h s k. Sections h s k => h -> k -> Retrieve s
keySection h
h k
k
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => Maybe h -> s -> k -> Name
keyName_ Maybe h
mb_h s
s k
k

-- | Basic function for generating a key name from the host (if it is
-- host indexex), section name and key id.
keyName_ :: Sections h s k => Maybe h -> s -> k -> Name
keyName_ :: forall h s k. Sections h s k => Maybe h -> s -> k -> Name
keyName_ Maybe h
mb_h s
s k
k = [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode s
s forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode k
k forall a. [a] -> [a] -> [a]
++ [Char]
hst_sfx forall a. [a] -> [a] -> [a]
++ [Char]
"/"
  where
    hst_sfx :: [Char]
hst_sfx = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\h
h -> [Char]
"/" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode h
h) Maybe h
mb_h

-- a wrapper on keySection used internally in functional contexts
key_section :: Sections h s k => h -> k -> s
key_section :: forall h s k. Sections h s k => h -> k -> s
key_section h
h k
k = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a} {a}. Show a => a -> a
oops forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => h -> k -> Retrieve s
keySection h
h k
k
  where
    oops :: a -> a
oops a
dg = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"key_section: " forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode h
h forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode k
k forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
dg

-- | Return the section that a host stores a given key in, returning a
-- failure diagnostic if the host does not keep such a key in the given
-- 'Section' model.
keySection :: Sections h s k => h -> k -> Retrieve s
keySection :: forall h s k. Sections h s k => h -> k -> Retrieve s
keySection h
h k
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left RetrieveDg
RDG_key_not_reachable) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
  forall a. (a -> Bool) -> [a] -> [a]
filter (forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection k
k) forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> [s]
lower_sections forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => h -> s
hostDeploySection h
h

-- | The name of the key that stores the password for a given sections.
passwordName :: Sections h s k => s -> Name
passwordName :: forall h s k. Sections h s k => s -> Name
passwordName s
s = [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
"/pw/" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s

fmt :: Code a => (a->Bool) -> String
fmt :: forall a. Code a => (a -> Bool) -> [Char]
fmt a -> Bool
p  = [[Char]] -> [Char]
unwords [ forall a. Code a => a -> [Char]
encode a
h | a
h<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], a -> Bool
p a
h ]

rotate' :: Sections h s k => Maybe KeyDataMode -> Bool -> IC -> Maybe h -> s -> k -> IO ()
rotate' :: forall h s k.
Sections h s k =>
Maybe KeyDataMode -> Bool -> IC -> Maybe h -> s -> k -> IO ()
rotate' Maybe KeyDataMode
mb Bool
ch IC
ic Maybe h
mb_h s
s k
k = do
    (KeyDataMode
kdm,kd :: KeyData
kd@KeyData{ByteString
Comment
Identity
kd_secret :: ByteString
kd_comment :: Comment
kd_identity :: Identity
kd_secret :: KeyData -> ByteString
kd_comment :: KeyData -> Comment
kd_identity :: KeyData -> Identity
..}) <- forall h s k.
Sections h s k =>
Maybe h -> s -> k -> IO (KeyDataMode, KeyData)
getKeyDataWithMode Maybe h
mb_h s
s k
k
    -- if the KeyDataMode is specified but does not match the key's mode then squash the rotation
    case forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
==KeyDataMode
kdm) Maybe KeyDataMode
mb of
      Bool
True  -> do
        -- iff ch then compare the new value with the old
        Bool
ok <- case Bool
ch of
          Bool
True  -> do
            -- if key has not changed, or the secret text is not available
            -- then squash the rotation
            [Maybe KeyData]
mbkds <- forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe KeyData
key2KeyData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> Name -> IO [Key]
locateKeys IC
ic (forall k h s. k -> SECTIONS h s k
mks k
k) Name
g_nm
            case [Maybe KeyData]
mbkds of
              Just KeyData
kd':[Maybe KeyData]
_ | KeyData
kdforall a. Eq a => a -> a -> Bool
==KeyData
kd' -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False    -- the key has not changes
              Maybe KeyData
Nothing :[Maybe KeyData]
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False    -- secret not accessible to compare
              [Maybe KeyData]
_                    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Bool
False ->
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$ do
          Name
n_nm <- IC -> Name -> IO Name
unique_nme IC
ic Name
g_nm
          [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"rotating: " forall a. [a] -> [a] -> [a]
++ Name -> [Char]
_name Name
n_nm
          IC
-> Name
-> Comment
-> Identity
-> Maybe EnvVar
-> Maybe ByteString
-> IO ()
createKey IC
ic Name
n_nm Comment
kd_comment Identity
kd_identity forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
kd_secret
      Bool
False ->
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    g_nm :: Name
g_nm = forall h s k. Sections h s k => Maybe h -> s -> k -> Name
keyName_ Maybe h
mb_h s
s k
k

    mks :: k -> SECTIONS h s k
    mks :: forall k h s. k -> SECTIONS h s k
mks = forall a b. a -> b -> a
const forall h s k. SECTIONS h s k
SECTIONS

lower_sections :: Sections h s k => s -> [s]
lower_sections :: forall h s k. Sections h s k => s -> [s]
lower_sections s
s0 =
  s
s0 forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ s
sforall a. a -> [a] -> [a]
:forall h s k. Sections h s k => s -> [s]
lower_sections s
s | s
s<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], s
s0 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall h s k. Sections h s k => s -> [s]
superSections s
s ]

mkSection :: Sections h s k => IC -> s -> IO ()
mkSection :: forall h s k. Sections h s k => IC -> s -> IO ()
mkSection IC
ic s
s = do
  forall h s k. Sections h s k => IC -> s -> IO ()
mk_section IC
ic s
s
  case forall h s k. Sections h s k => s -> SectionType
sectionType s
s of
    SectionType
ST_top     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    SectionType
ST_signing -> forall h s k. Sections h s k => IC -> s -> IO ()
add_signing IC
ic s
s
    SectionType
ST_keys    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

mk_section :: Sections h s k => IC -> s -> IO ()
mk_section :: forall h s k. Sections h s k => IC -> s -> IO ()
mk_section IC
ic s
s =
 do forall h s k. Sections h s k => IC -> s -> IO ()
add_password IC
ic s
s
    forall h s k. Sections h s k => IC -> s -> IO ()
add_save_key IC
ic s
s
    forall h s k. Sections h s k => IC -> s -> IO ()
add_trigger  IC
ic s
s
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall h s k. Sections h s k => IC -> s -> s -> IO ()
backup_password IC
ic s
s) forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> [s]
superSections s
s

add_signing :: Sections h s k => IC -> s -> IO ()
add_signing :: forall h s k. Sections h s k => IC -> s -> IO ()
add_signing IC
ic s
s = IC -> Name -> Comment -> Identity -> [Safeguard] -> IO ()
createRSAKeyPair IC
ic (forall h s k. Sections h s k => s -> Name
sgn_nme s
s) Comment
cmt Identity
"" [Safeguard
pw_sg]
  where
    cmt :: Comment
cmt   = Text -> Comment
Comment  forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"signing key"
    pw_sg :: Safeguard
pw_sg = [Name] -> Safeguard
safeguard [forall h s k. Sections h s k => s -> Name
passwordName s
s]

add_password :: Sections h s k => IC -> s -> IO ()
add_password :: forall h s k. Sections h s k => IC -> s -> IO ()
add_password IC
ic s
s = IC
-> Name
-> Comment
-> Identity
-> Maybe EnvVar
-> Maybe ByteString
-> IO ()
createKey IC
ic Name
nm Comment
cmt Identity
ide (forall a. a -> Maybe a
Just EnvVar
ev) forall a. Maybe a
Nothing
  where
    cmt :: Comment
cmt = Text -> Comment
Comment  forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"password for " forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s
    ide :: Identity
ide = Identity
""
    ev :: EnvVar
ev  = forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s

    nm :: Name
nm  = forall h s k. Sections h s k => s -> Name
passwordName s
s

add_save_key :: Sections h s k => IC -> s -> IO ()
add_save_key :: forall h s k. Sections h s k => IC -> s -> IO ()
add_save_key IC
ic s
s = IC -> Name -> Comment -> Identity -> [Safeguard] -> IO ()
createRSAKeyPair IC
ic Name
nm Comment
cmt Identity
ide [Safeguard
pw_sg]
  where
    nm :: Name
nm    = forall h s k. Sections h s k => s -> Name
sve_nme s
s
    cmt :: Comment
cmt   = Text -> Comment
Comment  forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"save key for " forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s
    ide :: Identity
ide   = Identity
""
    pw_sg :: Safeguard
pw_sg = [Name] -> Safeguard
safeguard [forall h s k. Sections h s k => s -> Name
passwordName s
s]

add_trigger :: Sections h s k => IC -> s -> IO ()
add_trigger :: forall h s k. Sections h s k => IC -> s -> IO ()
add_trigger IC
ic s
s = do
    Settings
stgs <- (forall h s k. Sections h s k => s -> Settings
bu_settings s
s forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h s k. Sections h s k => Maybe s -> IO Settings
sectionSettings (forall a. a -> Maybe a
Just s
s)
    IC -> TriggerID -> Pattern -> Settings -> IO ()
addTrigger' IC
ic TriggerID
tid Pattern
pat Settings
stgs
  where
    tid :: TriggerID
tid    = Text -> TriggerID
TriggerID forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode s
s
    pat :: Pattern
pat    = forall h s k. Sections h s k => s -> Pattern
scn_pattern s
s

bu_settings :: Sections h s k => s -> Settings
bu_settings :: forall h s k. Sections h s k => s -> Settings
bu_settings s
s = HashMap Text Value -> Settings
Settings forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ (Text
"backup.keys"
      , Array -> Value
A.Array forall a b. (a -> b) -> a -> b
$ forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Name -> [Char]
_name forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => s -> Name
sve_nme s
s
      )
    ]

signing_key :: Sections h s k => SECTIONS h s k -> s
signing_key :: forall h s k. Sections h s k => SECTIONS h s k -> s
signing_key SECTIONS h s k
_ = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
oops forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [ s
s_ | s
s_<-[forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound], forall h s k. Sections h s k => s -> SectionType
sectionType s
s_ forall a. Eq a => a -> a -> Bool
== SectionType
ST_signing ]
  where
    oops :: a
oops = forall a. HasCallStack => [Char] -> a
error [Char]
"signing_key: there is no signing key!"

sections :: Sections h s k => SECTIONS h s k -> [s]
sections :: forall h s k. Sections h s k => SECTIONS h s k -> [s]
sections SECTIONS h s k
_ = [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound]

backup_password :: Sections h s k => IC -> s -> s -> IO ()
backup_password :: forall h s k. Sections h s k => IC -> s -> s -> IO ()
backup_password IC
ic s
s s
sv_s = IC -> Name -> Safeguard -> IO ()
secureKey IC
ic (forall h s k. Sections h s k => s -> Name
passwordName s
s) forall a b. (a -> b) -> a -> b
$ [Name] -> Safeguard
safeguard [forall h s k. Sections h s k => s -> Name
sve_nme s
sv_s]

sgn_nme :: Sections h s k => s -> Name
sgn_nme :: forall h s k. Sections h s k => s -> Name
sgn_nme s
s = [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode s
s forall a. [a] -> [a] -> [a]
++ [Char]
"/keystore_signing_key"

sve_nme :: Sections h s k => s -> Name
sve_nme :: forall h s k. Sections h s k => s -> Name
sve_nme s
s = [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
"/save/" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s

scn_pattern :: Sections h s k => s -> Pattern
scn_pattern :: forall h s k. Sections h s k => s -> Pattern
scn_pattern s
s = [Char] -> Pattern
pattern forall a b. (a -> b) -> a -> b
$ [Char]
"^" forall a. [a] -> [a] -> [a]
++ forall a. Code a => a -> [Char]
encode s
s forall a. [a] -> [a] -> [a]
++ [Char]
"/.*"

unique_nme :: IC -> Name -> IO Name
unique_nme :: IC -> Name -> IO Name
unique_nme IC
ic Name
nm =
 do [Name]
nms <- forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Key -> Name
_key_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO [Key]
keys IC
ic
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> Name -> Name
unique_nme' [Name]
nms Name
nm
  where
    isp :: Name -> Bool
isp Name
nm' = Name -> [Char]
_name Name
nm forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Name -> [Char]
_name Name
nm'

unique_nme' :: [Name] -> Name -> Name
unique_nme' :: [Name] -> Name -> Name
unique_nme' [Name]
nms Name
nm0 = forall a. HasCallStack => [Char] -> [a] -> a
headNote [Char]
"unique_name'" [Name]
c_nms
  where
    c_nms :: [Name]
c_nms = [ Name
nm | Int
i<-[forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
nmsforall a. Num a => a -> a -> a
+Int
1..], let nm :: Name
nm=Int -> Name -> Name
nname Int
i Name
nm0, Name
nm forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
nms ]

    nname :: Int -> Name -> Name
    nname :: Int -> Name -> Name
nname Int
i Name
nm_ = [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ Name -> [Char]
_name Name
nm_ forall a. [a] -> [a] -> [a]
++ forall r. PrintfType r => [Char] -> r
printf [Char]
"%03d" Int
i

the_keystore :: CtxParams -> FilePath
the_keystore :: CtxParams -> [Char]
the_keystore = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"keystore.json" forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtxParams -> Maybe [Char]
cp_store

get_kd :: Sections h s k => String -> k -> IO (KeyDataMode,KeyData)
get_kd :: forall h s k.
Sections h s k =>
[Char] -> k -> IO (KeyDataMode, KeyData)
get_kd [Char]
sd k
k = do
  ByteString
ide <- [Char] -> IO ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
fp [Char]
"_id"
  ByteString
cmt <- [Char] -> IO ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
fp [Char]
"_cmt"
  ByteString
sec <- [Char] -> IO ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
fp [Char]
""
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( KeyDataMode
KDM_static
    , KeyData
        { kd_identity :: Identity
kd_identity = Text -> Identity
Identity forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B.unpack ByteString
ide
        , kd_comment :: Comment
kd_comment  = Text -> Comment
Comment  forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B.unpack ByteString
cmt
        , kd_secret :: ByteString
kd_secret   = ByteString
sec
        }
    )
  where
    fp :: [Char] -> [Char]
fp [Char]
sfx = [Char]
sd [Char] -> [Char] -> [Char]
</> forall a. Code a => a -> [Char]
encode k
k forall a. [a] -> [a] -> [a]
++ [Char]
sfx


--------------------------------------------------------------------------------
--
-- Reformating the KeyStore Names to Allow Prefixes (#3)
--
--------------------------------------------------------------------------------


reformat :: Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat :: forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat rft :: REFORMAT h s k
rft@(REFORMAT IC
ic) IO a
p = Encoding -> IC -> IO ()
reformat_ic (forall h s k. Sections h s k => REFORMAT h s k -> Encoding
encoding REFORMAT h s k
rft) IC
ic forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
p

-- Proxy city!

data REFORMAT h s k = REFORMAT { forall h s k. REFORMAT h s k -> IC
_REFORMAT :: IC }

data CODE a = CODE

scn_RFT :: SECTIONS     h s k -> IC -> REFORMAT h s k
kp_RFT  :: KeyPredicate h s k -> IC -> REFORMAT h s k
h_RFT   ::              h     -> IC -> REFORMAT h s k

scn_RFT :: forall h s k. SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
_ IC
ic = forall h s k. IC -> REFORMAT h s k
REFORMAT IC
ic
kp_RFT :: forall h s k. KeyPredicate h s k -> IC -> REFORMAT h s k
kp_RFT  KeyPredicate h s k
_ IC
ic = forall h s k. IC -> REFORMAT h s k
REFORMAT IC
ic
h_RFT :: forall h s k. h -> IC -> REFORMAT h s k
h_RFT   h
_ IC
ic = forall h s k. IC -> REFORMAT h s k
REFORMAT IC
ic

reformat_ic :: Encoding -> IC -> IO ()
reformat_ic :: Encoding -> IC -> IO ()
reformat_ic Encoding
enc IC
ic = do
  (Ctx
ctx,State
st) <- IC -> IO (Ctx, State)
getCtxState IC
ic
  IC -> Ctx -> State -> IO ()
putCtxState IC
ic Ctx
ctx forall a b. (a -> b) -> a -> b
$
    State
st { st_keystore :: KeyStore
st_keystore = Encoding -> KeyStore -> KeyStore
reformat_keystore Encoding
enc forall a b. (a -> b) -> a -> b
$ State -> KeyStore
st_keystore State
st }

reformat_keystore :: Encoding -> KeyStore -> KeyStore
reformat_keystore :: Encoding -> KeyStore -> KeyStore
reformat_keystore Encoding
enc KeyStore
ks =
  case forall a. Opt a -> Settings -> a
getSettingsOpt Opt Bool
opt__sections_fix forall a b. (a -> b) -> a -> b
$ Configuration -> Settings
_cfg_settings forall a b. (a -> b) -> a -> b
$ KeyStore -> Configuration
_ks_config KeyStore
ks of
    Bool
True  -> KeyStore
ks
    Bool
False -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' KeyStore Configuration
ks_config (Encoding -> Configuration -> Configuration
reformat_config  Encoding
enc) forall a b. (a -> b) -> a -> b
$
             forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' KeyStore KeyMap
ks_keymap (Encoding -> KeyMap -> KeyMap
reformat_key_map Encoding
enc) KeyStore
ks

reformat_config :: Encoding -> Configuration -> Configuration
reformat_config :: Encoding -> Configuration -> Configuration
reformat_config Encoding
enc =
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Configuration Settings
cfg_settings (forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt Bool
opt__sections_fix Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Configuration Settings
cfg_settings (Encoding -> Settings -> Settings
reformat_settings Encoding
enc) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Configuration TriggerMap
cfg_triggers (Encoding -> TriggerMap -> TriggerMap
reformat_triggers Encoding
enc)

reformat_triggers :: Encoding -> TriggerMap -> TriggerMap
reformat_triggers :: Encoding -> TriggerMap -> TriggerMap
reformat_triggers Encoding
enc = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a b. (a -> b) -> a -> b
$
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Trigger Pattern
trg_pattern  (Encoding -> Pattern -> Pattern
reformat_pattern  Encoding
enc) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Trigger Settings
trg_settings (Encoding -> Settings -> Settings
reformat_settings Encoding
enc)

reformat_settings :: Encoding -> Settings -> Settings
reformat_settings :: Encoding -> Settings -> Settings
reformat_settings Encoding
enc Settings
stgs =
  case forall a. Opt a -> Settings -> Maybe a
getSettingsOpt' Opt [Name]
opt__backup_keys Settings
stgs of
    Maybe [Name]
Nothing  -> Settings
stgs
    Just [Name]
nms -> forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt [Name]
opt__backup_keys (forall a b. (a -> b) -> [a] -> [b]
map (Encoding -> Name -> Name
reformat_name Encoding
enc) [Name]
nms) Settings
stgs

reformat_pattern :: Encoding -> Pattern -> Pattern
reformat_pattern :: Encoding -> Pattern -> Pattern
reformat_pattern Encoding
enc Pattern
pat = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
oops forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Munch a -> [Char] -> Maybe a
run_munch (Encoding -> Munch Pattern
m_pattern Encoding
enc) forall a b. (a -> b) -> a -> b
$ Pattern -> [Char]
_pat_string Pattern
pat
  where
    oops :: a
oops = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"reformat_pattern: bad pattern format: " forall a. [a] -> [a] -> [a]
++ Pattern -> [Char]
_pat_string Pattern
pat

reformat_key_map :: Encoding -> KeyMap -> KeyMap
reformat_key_map :: Encoding -> KeyMap -> KeyMap
reformat_key_map Encoding
enc KeyMap
km = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Encoding -> Name -> Name
reformat_name Encoding
enc Name
nm,Key -> Key
r_ky Key
ky) | (Name
nm,Key
ky)<-forall k a. Map k a -> [(k, a)]
Map.toList KeyMap
km ]
  where
    r_ky :: Key -> Key
r_ky =
      forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Key Name
key_name          (Encoding -> Name -> Name
reformat_name Encoding
enc) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Key EncrypedCopyMap
key_secret_copies (Encoding -> EncrypedCopyMap -> EncrypedCopyMap
reformat_ecm  Encoding
enc)

reformat_ecm :: Encoding -> EncrypedCopyMap -> EncrypedCopyMap
reformat_ecm :: Encoding -> EncrypedCopyMap -> EncrypedCopyMap
reformat_ecm Encoding
enc EncrypedCopyMap
ecm = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Encoding -> Safeguard -> Safeguard
reformat_sg Encoding
enc Safeguard
sg,EncrypedCopy -> EncrypedCopy
r_ec EncrypedCopy
ec) | (Safeguard
sg,EncrypedCopy
ec)<-forall k a. Map k a -> [(k, a)]
Map.toList EncrypedCopyMap
ecm ]
  where
    r_ec :: EncrypedCopy -> EncrypedCopy
r_ec = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' EncrypedCopy Safeguard
ec_safeguard (Encoding -> Safeguard -> Safeguard
reformat_sg Encoding
enc)

reformat_sg :: Encoding -> Safeguard -> Safeguard
reformat_sg :: Encoding -> Safeguard -> Safeguard
reformat_sg Encoding
enc = [Name] -> Safeguard
safeguard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Encoding -> Name -> Name
reformat_name Encoding
enc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Safeguard -> [Name]
safeguardKeys

reformat_name :: Encoding -> Name -> Name
reformat_name :: Encoding -> Name -> Name
reformat_name Encoding
enc Name
nm = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a
oops forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Munch a -> [Char] -> Maybe a
run_munch (Encoding -> Munch Name
m_name Encoding
enc) forall a b. (a -> b) -> a -> b
$ Name -> [Char]
_name Name
nm
  where
    oops :: a
oops = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"reformat_name: bad name format: " forall a. [a] -> [a] -> [a]
++ Name -> [Char]
_name Name
nm

m_pattern :: Encoding -> Munch Pattern
m_pattern :: Encoding -> Munch Pattern
m_pattern Encoding
enc = do
  [Char] -> Munch ()
munch_ [Char]
"^"
  [Char]
s <- Encoding -> Munch [Char]
enc_s Encoding
enc
  [Char] -> Munch ()
munch_ [Char]
"_.*"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"^" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"/.*"

m_name, m_save, m_pw, m_section :: Encoding -> Munch Name

m_name :: Encoding -> Munch Name
m_name Encoding
enc = Encoding -> Munch Name
m_save Encoding
enc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Encoding -> Munch Name
m_pw Encoding
enc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Encoding -> Munch Name
m_section Encoding
enc

m_save :: Encoding -> Munch Name
m_save Encoding
enc = do
  [Char] -> Munch ()
munch_ [Char]
"save_"
  [Char]
s <- Encoding -> Munch [Char]
enc_s Encoding
enc
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
"/save/" forall a. [a] -> [a] -> [a]
++ [Char]
s

m_pw :: Encoding -> Munch Name
m_pw Encoding
enc = do
  [Char] -> Munch ()
munch_ [Char]
"pw_"
  [Char]
s <- Encoding -> Munch [Char]
enc_s Encoding
enc
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
"/pw/" forall a. [a] -> [a] -> [a]
++ [Char]
s

m_section :: Encoding -> Munch Name
m_section Encoding
enc = do
  [Char]
s <- Encoding -> Munch [Char]
enc_s Encoding
enc
  Encoding -> [Char] -> Munch Name
m_section_signing Encoding
enc [Char]
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Encoding -> [Char] -> Munch Name
m_section_key Encoding
enc [Char]
s

m_section_key, m_section_signing  :: Encoding -> String -> Munch Name

m_section_signing :: Encoding -> [Char] -> Munch Name
m_section_signing Encoding
_ [Char]
s = do
  [Char] -> Munch ()
munch_ [Char]
"_keystore_signing_key"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"/keystore_signing_key"

m_section_key :: Encoding -> [Char] -> Munch Name
m_section_key Encoding
enc [Char]
s = do
  [Char] -> Munch ()
munch_ [Char]
"_"
  [Char]
k <- Encoding -> Munch [Char]
enc_k Encoding
enc
  Encoding -> [Char] -> [Char] -> Munch Name
m_section_key_host Encoding
enc [Char]
s [Char]
k forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Encoding -> [Char] -> [Char] -> Munch Name
m_section_key_vrn Encoding
enc [Char]
s [Char]
k

m_section_key_vrn, m_section_key_host :: Encoding -> String -> String -> Munch Name

m_section_key_vrn :: Encoding -> [Char] -> [Char] -> Munch Name
m_section_key_vrn Encoding
_ [Char]
s [Char]
k = do
  [Char] -> Munch ()
munch_ [Char]
"_"
  [Char]
v <- Munch [Char]
munch_vrn
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
s forall a. [a] -> [a] -> [a]
++[Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
k forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
v

m_section_key_host :: Encoding -> [Char] -> [Char] -> Munch Name
m_section_key_host Encoding
enc [Char]
s [Char]
k = do
  [Char] -> Munch ()
munch_ [Char]
"_"
  [Char]
h <- Encoding -> Munch [Char]
enc_h Encoding
enc
  [Char] -> Munch ()
munch_ [Char]
"_"
  [Char]
v <- Munch [Char]
munch_vrn
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Name
name' forall a b. (a -> b) -> a -> b
$ [Char]
s forall a. [a] -> [a] -> [a]
++[Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
k forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
h forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
v

munch_vrn :: Munch String
munch_vrn :: Munch [Char]
munch_vrn = do
  Char
c1 <- (Char -> Bool) -> Munch Char
munch1 Char -> Bool
isDigit
  Char
c2 <- (Char -> Bool) -> Munch Char
munch1 Char -> Bool
isDigit
  Char
c3 <- (Char -> Bool) -> Munch Char
munch1 Char -> Bool
isDigit
  forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c1,Char
c2,Char
c3]

-- Capturing the host, section and key encodings in a nice convenient
-- monotype that we can pass around.

data Encoding =
  Encoding
    { Encoding -> Munch [Char]
enc_h, Encoding -> Munch [Char]
enc_s, Encoding -> Munch [Char]
enc_k :: Munch String
    }

encoding :: Sections h s k => REFORMAT h s k -> Encoding
encoding :: forall h s k. Sections h s k => REFORMAT h s k -> Encoding
encoding REFORMAT h s k
rft =
  Encoding
    { enc_h :: Munch [Char]
enc_h = forall a. Code a => CODE a -> Munch [Char]
code_m forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => REFORMAT h s k -> CODE h
host_c    REFORMAT h s k
rft
    , enc_s :: Munch [Char]
enc_s = forall a. Code a => CODE a -> Munch [Char]
code_m forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => REFORMAT h s k -> CODE s
section_c REFORMAT h s k
rft
    , enc_k :: Munch [Char]
enc_k = forall a. Code a => CODE a -> Munch [Char]
code_m forall a b. (a -> b) -> a -> b
$ forall h s k. Sections h s k => REFORMAT h s k -> CODE k
key_c     REFORMAT h s k
rft
    }
  where
    host_c      :: Sections h s k => REFORMAT h s k -> CODE h
    host_c :: forall h s k. Sections h s k => REFORMAT h s k -> CODE h
host_c    REFORMAT h s k
_ = forall a. CODE a
CODE

    section_c   :: Sections h s k => REFORMAT h s k -> CODE s
    section_c :: forall h s k. Sections h s k => REFORMAT h s k -> CODE s
section_c REFORMAT h s k
_ = forall a. CODE a
CODE

    key_c       :: Sections h s k => REFORMAT h s k -> CODE k
    key_c :: forall h s k. Sections h s k => REFORMAT h s k -> CODE k
key_c     REFORMAT h s k
_ = forall a. CODE a
CODE

code_m :: Code a => CODE a -> Munch String
code_m :: forall a. Code a => CODE a -> Munch [Char]
code_m CODE a
c = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall (f :: * -> *) a. Alternative f => f a
empty forall a b. (a -> b) -> a -> b
$ [ [Char] -> Munch [Char]
munch forall a b. (a -> b) -> a -> b
$ forall a. Code a => a -> [Char]
encode a
x | a
x<-forall a. Code a => CODE a -> [a]
bds CODE a
c ]
  where
    bds :: Code a => CODE a -> [a]
    bds :: forall a. Code a => CODE a -> [a]
bds CODE a
_ = [forall a. Bounded a => a
minBound..forall a. Bounded a => a
maxBound]

-- our Munch Monad

newtype Munch a = Munch { forall a. Munch a -> [Char] -> Maybe (a, [Char])
_Munch :: String -> Maybe (a,String) }

instance Functor Munch where
  fmap :: forall a b. (a -> b) -> Munch a -> Munch b
fmap a -> b
f Munch a
m = Munch a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance Applicative Munch where
  pure :: forall a. a -> Munch a
pure a
x  = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ \[Char]
s -> forall a. a -> Maybe a
Just (a
x,[Char]
s)
  <*> :: forall a b. Munch (a -> b) -> Munch a -> Munch b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative Munch where
  empty :: forall a. Munch a
empty     = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Maybe a
Nothing
  <|> :: forall a. Munch a -> Munch a -> Munch a
(<|>) Munch a
x Munch a
y = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ \[Char]
s -> forall a. Munch a -> [Char] -> Maybe (a, [Char])
_Munch Munch a
x [Char]
s forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Munch a -> [Char] -> Maybe (a, [Char])
_Munch Munch a
y [Char]
s

instance Monad Munch where
  return :: forall a. a -> Munch a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: forall a b. Munch a -> (a -> Munch b) -> Munch b
(>>=) Munch a
m a -> Munch b
f = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ \[Char]
s -> forall a. Munch a -> [Char] -> Maybe (a, [Char])
_Munch Munch a
m [Char]
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
x,[Char]
s') -> forall a. Munch a -> [Char] -> Maybe (a, [Char])
_Munch (a -> Munch b
f a
x) [Char]
s'

run_munch :: Munch a -> String -> Maybe a
run_munch :: forall a. Munch a -> [Char] -> Maybe a
run_munch (Munch [Char] -> Maybe (a, [Char])
f) [Char]
str = case [Char] -> Maybe (a, [Char])
f [Char]
str of
  Just (a
x,[Char]
"") -> forall a. a -> Maybe a
Just a
x
  Maybe (a, [Char])
_           -> forall a. Maybe a
Nothing

munch1 :: (Char->Bool) -> Munch Char
munch1 :: (Char -> Bool) -> Munch Char
munch1 Char -> Bool
p = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ \[Char]
str -> case [Char]
str of
  Char
c:[Char]
t | Char -> Bool
p Char
c -> forall a. a -> Maybe a
Just (Char
c,[Char]
t)
  [Char]
_         -> forall a. Maybe a
Nothing

munch_ :: String -> Munch ()
munch_ :: [Char] -> Munch ()
munch_ [Char]
s = forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Munch [Char]
munch [Char]
s

munch :: String -> Munch String
munch :: [Char] -> Munch [Char]
munch [Char]
str_p = forall a. ([Char] -> Maybe (a, [Char])) -> Munch a
Munch forall a b. (a -> b) -> a -> b
$ \[Char]
str -> case [Char]
str_p forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
str of
  Bool
True  -> forall a. a -> Maybe a
Just ([Char]
str_p,forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str_p) [Char]
str)
  Bool
False -> forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

key2KeyData :: Key -> Maybe KeyData
key2KeyData :: Key -> Maybe KeyData
key2KeyData Key{Bool
Maybe PublicKey
Maybe PrivateKey
Maybe ClearText
Maybe EnvVar
Maybe Hash
UTCTime
EncrypedCopyMap
Name
Comment
Identity
_key_created_at :: Key -> UTCTime
_key_clear_private :: Key -> Maybe PrivateKey
_key_clear_text :: Key -> Maybe ClearText
_key_secret_copies :: Key -> EncrypedCopyMap
_key_public :: Key -> Maybe PublicKey
_key_hash :: Key -> Maybe Hash
_key_env_var :: Key -> Maybe EnvVar
_key_is_binary :: Key -> Bool
_key_identity :: Key -> Identity
_key_comment :: Key -> Comment
_key_created_at :: UTCTime
_key_clear_private :: Maybe PrivateKey
_key_clear_text :: Maybe ClearText
_key_secret_copies :: EncrypedCopyMap
_key_public :: Maybe PublicKey
_key_hash :: Maybe Hash
_key_env_var :: Maybe EnvVar
_key_is_binary :: Bool
_key_identity :: Identity
_key_comment :: Comment
_key_name :: Name
_key_name :: Key -> Name
..} = ClearText -> KeyData
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ClearText
_key_clear_text
  where
    f :: ClearText -> KeyData
f (ClearText(Binary ByteString
bs)) =
      KeyData
        { kd_identity :: Identity
kd_identity = Identity
_key_identity
        , kd_comment :: Comment
kd_comment  = Comment
_key_comment
        , kd_secret :: ByteString
kd_secret   = ByteString
bs
        }

name' :: String -> Name
name' :: [Char] -> Name
name' = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
errorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> [Char]
show) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> E Name
name