{-# 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 String
s = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [ a
k | a
k<-[a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound], a -> String
forall a. Code a => a -> String
encode a
kString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
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                   = SectionType -> s -> SectionType
forall a b. a -> b -> a
const SectionType
ST_keys

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

  keyIsHostIndexed              = Maybe (h -> Bool) -> k -> Maybe (h -> Bool)
forall a b. a -> b -> a
const Maybe (h -> Bool)
forall a. Maybe a
Nothing

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

  getKeyData          Maybe h
mb s
s k
k    = (KeyDataMode, KeyData) -> KeyData
forall a b. (a, b) -> b
snd ((KeyDataMode, KeyData) -> KeyData)
-> IO (KeyDataMode, KeyData) -> IO KeyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe h -> s -> k -> IO (KeyDataMode, KeyData)
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 = String -> k -> IO (KeyDataMode, KeyData)
forall h s k.
Sections h s k =>
String -> k -> IO (KeyDataMode, KeyData)
get_kd (String -> k -> IO (KeyDataMode, KeyData))
-> String -> k -> IO (KeyDataMode, KeyData)
forall a b. (a -> b) -> a -> b
$ s -> String
forall a. Code a => a -> String
encode s
s
  getKeyDataWithMode (Just h
h) s
_ = String -> k -> IO (KeyDataMode, KeyData)
forall h s k.
Sections h s k =>
String -> k -> IO (KeyDataMode, KeyData)
get_kd (String -> k -> IO (KeyDataMode, KeyData))
-> String -> k -> IO (KeyDataMode, KeyData)
forall a b. (a -> b) -> a -> b
$ h -> String
forall a. Code a => a -> String
encode h
h

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

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

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

  sectionPWEnvVar               = Text -> EnvVar
EnvVar (Text -> EnvVar) -> (s -> Text) -> s -> EnvVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"KEY_pw_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (s -> String) -> s -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Code a => a -> String
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 -> String -> String
[SectionType] -> String -> String
SectionType -> String
(Int -> SectionType -> String -> String)
-> (SectionType -> String)
-> ([SectionType] -> String -> String)
-> Show SectionType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SectionType] -> String -> String
$cshowList :: [SectionType] -> String -> String
show :: SectionType -> String
$cshow :: SectionType -> String
showsPrec :: Int -> SectionType -> String -> String
$cshowsPrec :: Int -> SectionType -> String -> String
Show,SectionType -> SectionType -> Bool
(SectionType -> SectionType -> Bool)
-> (SectionType -> SectionType -> Bool) -> Eq SectionType
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
Eq SectionType
-> (SectionType -> SectionType -> Ordering)
-> (SectionType -> SectionType -> Bool)
-> (SectionType -> SectionType -> Bool)
-> (SectionType -> SectionType -> Bool)
-> (SectionType -> SectionType -> Bool)
-> (SectionType -> SectionType -> SectionType)
-> (SectionType -> SectionType -> SectionType)
-> Ord 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
$cp1Ord :: Eq SectionType
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 -> String -> String
[KeyData] -> String -> String
KeyData -> String
(Int -> KeyData -> String -> String)
-> (KeyData -> String)
-> ([KeyData] -> String -> String)
-> Show KeyData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [KeyData] -> String -> String
$cshowList :: [KeyData] -> String -> String
show :: KeyData -> String
$cshow :: KeyData -> String
showsPrec :: Int -> KeyData -> String -> String
$cshowsPrec :: Int -> KeyData -> String -> String
Show,KeyData -> KeyData -> Bool
(KeyData -> KeyData -> Bool)
-> (KeyData -> KeyData -> Bool) -> Eq KeyData
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
KeyDataMode -> KeyDataMode -> Bounded 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]
(KeyDataMode -> KeyDataMode)
-> (KeyDataMode -> KeyDataMode)
-> (Int -> KeyDataMode)
-> (KeyDataMode -> Int)
-> (KeyDataMode -> [KeyDataMode])
-> (KeyDataMode -> KeyDataMode -> [KeyDataMode])
-> (KeyDataMode -> KeyDataMode -> [KeyDataMode])
-> (KeyDataMode -> KeyDataMode -> KeyDataMode -> [KeyDataMode])
-> Enum 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
(KeyDataMode -> KeyDataMode -> Bool)
-> (KeyDataMode -> KeyDataMode -> Bool) -> Eq KeyDataMode
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
Eq KeyDataMode
-> (KeyDataMode -> KeyDataMode -> Ordering)
-> (KeyDataMode -> KeyDataMode -> Bool)
-> (KeyDataMode -> KeyDataMode -> Bool)
-> (KeyDataMode -> KeyDataMode -> Bool)
-> (KeyDataMode -> KeyDataMode -> Bool)
-> (KeyDataMode -> KeyDataMode -> KeyDataMode)
-> (KeyDataMode -> KeyDataMode -> KeyDataMode)
-> Ord 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
$cp1Ord :: Eq KeyDataMode
Ord,Int -> KeyDataMode -> String -> String
[KeyDataMode] -> String -> String
KeyDataMode -> String
(Int -> KeyDataMode -> String -> String)
-> (KeyDataMode -> String)
-> ([KeyDataMode] -> String -> String)
-> Show KeyDataMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [KeyDataMode] -> String -> String
$cshowList :: [KeyDataMode] -> String -> String
show :: KeyDataMode -> String
$cshow :: KeyDataMode -> String
showsPrec :: Int -> KeyDataMode -> String -> String
$cshowsPrec :: Int -> KeyDataMode -> String -> String
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 -> String -> String
[RetrieveDg] -> String -> String
RetrieveDg -> String
(Int -> RetrieveDg -> String -> String)
-> (RetrieveDg -> String)
-> ([RetrieveDg] -> String -> String)
-> Show RetrieveDg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RetrieveDg] -> String -> String
$cshowList :: [RetrieveDg] -> String -> String
show :: RetrieveDg -> String
$cshow :: RetrieveDg -> String
showsPrec :: Int -> RetrieveDg -> String -> String
$cshowsPrec :: Int -> RetrieveDg -> String -> String
Show,RetrieveDg -> RetrieveDg -> Bool
(RetrieveDg -> RetrieveDg -> Bool)
-> (RetrieveDg -> RetrieveDg -> Bool) -> Eq RetrieveDg
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
Eq RetrieveDg
-> (RetrieveDg -> RetrieveDg -> Ordering)
-> (RetrieveDg -> RetrieveDg -> Bool)
-> (RetrieveDg -> RetrieveDg -> Bool)
-> (RetrieveDg -> RetrieveDg -> Bool)
-> (RetrieveDg -> RetrieveDg -> Bool)
-> (RetrieveDg -> RetrieveDg -> RetrieveDg)
-> (RetrieveDg -> RetrieveDg -> RetrieveDg)
-> Ord 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
$cp1Ord :: Eq RetrieveDg
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 :: CtxParams -> KeyPredicate h s k -> IO ()
initialise CtxParams
cp KeyPredicate h s k
kp = do
    Settings
stgs <- Opt Bool -> Bool -> Settings -> Settings
forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt Bool
opt__sections_fix Bool
True (Settings -> Settings) -> IO Settings -> IO Settings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPredicate h s k -> Maybe s -> IO Settings
forall h s k.
Sections h s k =>
KeyPredicate h s k -> Maybe s -> IO Settings
scs KeyPredicate h s k
kp Maybe s
forall a. Maybe a
Nothing
    String -> Settings -> IO ()
newKeyStore (CtxParams -> String
the_keystore CtxParams
cp) Settings
stgs
    IC
ic <- CtxParams -> IO IC
instanceCtx CtxParams
cp
    (s -> IO ()) -> [s] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (KeyPredicate h s k -> IC -> s -> IO ()
forall h s k.
Sections h s k =>
KeyPredicate h s k -> IC -> s -> IO ()
mks KeyPredicate h s k
kp IC
ic) [s
forall a. Bounded a => a
minBound..s
forall a. Bounded a => a
maxBound]
    IC -> KeyPredicate h s k -> IO ()
forall h s k. Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotate IC
ic KeyPredicate h s k
kp
    (Key -> Name) -> [Key] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Name
_key_name ([Key] -> [Name]) -> IO [Key] -> IO [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> IO [Key]
keys IC
ic IO [Name] -> ([Name] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Name -> IO ()) -> [Name] -> IO ()
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 :: KeyPredicate h s k -> Maybe s -> IO Settings
scs = (Maybe s -> IO Settings)
-> KeyPredicate h s k -> Maybe s -> IO Settings
forall a b. a -> b -> a
const Maybe s -> IO Settings
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 :: KeyPredicate h s k -> IC -> s -> IO ()
mks = (IC -> s -> IO ()) -> KeyPredicate h s k -> IC -> s -> IO ()
forall a b. a -> b -> a
const IC -> s -> IO ()
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 :: IC -> KeyPredicate h s k -> IO ()
rotate IC
ic = IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
forall h s k.
Sections h s k =>
IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic Maybe KeyDataMode
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 :: IC -> KeyPredicate h s k -> IO ()
rotateIfChanged IC
ic = IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
forall h s k.
Sections h s k =>
IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic Maybe KeyDataMode
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_ :: IC -> Maybe KeyDataMode -> Bool -> KeyPredicate h s k -> IO ()
rotate_ IC
ic Maybe KeyDataMode
mb Bool
ch KeyPredicate h s k
kp = REFORMAT h s k -> IO () -> IO ()
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Maybe KeyDataMode -> Bool -> IC -> Maybe h -> s -> k -> IO ()
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)<-KeyPredicate h s k -> [(Maybe h, s, 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' = KeyPredicate h s k -> IC -> REFORMAT h s k
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 :: IC -> h -> k -> IO (Retrieve [Key])
retrieve IC
ic h
h k
k = REFORMAT h s k -> IO (Retrieve [Key]) -> IO (Retrieve [Key])
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
forall s k. REFORMAT h s k
ic' (IO (Retrieve [Key]) -> IO (Retrieve [Key]))
-> IO (Retrieve [Key]) -> IO (Retrieve [Key])
forall a b. (a -> b) -> a -> b
$ (RetrieveDg -> IO (Retrieve [Key]))
-> (Name -> IO (Retrieve [Key]))
-> Either RetrieveDg Name
-> IO (Retrieve [Key])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Retrieve [Key] -> IO (Retrieve [Key])
forall (m :: * -> *) a. Monad m => a -> m a
return (Retrieve [Key] -> IO (Retrieve [Key]))
-> (RetrieveDg -> Retrieve [Key])
-> RetrieveDg
-> IO (Retrieve [Key])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetrieveDg -> Retrieve [Key]
forall a b. a -> Either a b
Left) (\Name
nm->[Key] -> Retrieve [Key]
forall a b. b -> Either a b
Right ([Key] -> Retrieve [Key]) -> IO [Key] -> IO (Retrieve [Key])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> REFORMAT h s k -> Name -> IO [Key]
forall h s k. Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys REFORMAT h s k
forall s k. REFORMAT h s k
ic' Name
nm) (Either RetrieveDg Name -> IO (Retrieve [Key]))
-> Either RetrieveDg Name -> IO (Retrieve [Key])
forall a b. (a -> b) -> a -> b
$ h -> k -> Either RetrieveDg Name
forall h s k. Sections h s k => h -> k -> Either RetrieveDg Name
keyName h
h k
k
  where
    ic' :: REFORMAT h s k
ic' = h -> IC -> REFORMAT h s k
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 :: IC -> SECTIONS h s k -> IO ByteString
signKeystore IC
ic SECTIONS h s k
scn = REFORMAT h s k -> IO ByteString -> IO ByteString
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile (CtxParams -> String
the_keystore (CtxParams -> String) -> CtxParams -> String
forall a b. (a -> b) -> a -> b
$ IC -> CtxParams
ic_ctx_params IC
ic) IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IC -> Name -> ByteString -> IO ByteString
sign_ IC
ic (s -> Name
forall h s k. Sections h s k => s -> Name
sgn_nme (s -> Name) -> s -> Name
forall a b. (a -> b) -> a -> b
$ SECTIONS h s k -> s
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' = SECTIONS h s k -> IC -> REFORMAT h s k
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 :: IC -> SECTIONS h s k -> ByteString -> IO Bool
verifyKeystore IC
ic SECTIONS h s k
scn ByteString
sig = REFORMAT h s k -> IO Bool -> IO Bool
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile (CtxParams -> String
the_keystore (CtxParams -> String) -> CtxParams -> String
forall a b. (a -> b) -> a -> b
$ IC -> CtxParams
ic_ctx_params IC
ic) IO ByteString -> (ByteString -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> ByteString -> IO Bool)
-> ByteString -> ByteString -> IO Bool
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' = SECTIONS h s k -> IC -> REFORMAT h s k
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 :: 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 :: 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 :: 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_keys[(Maybe h, s, k)] -> [(Maybe h, s, k)] -> [(Maybe h, s, k)]
forall a. [a] -> [a] -> [a]
++[(Maybe h, s, k)]
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     = [ (h -> Maybe h
forall a. a -> Maybe a
Just h
h ,s
s,k
k) | k
k<-[k
forall a. Bounded a => a
minBound..k
forall a. Bounded a => a
maxBound], Just h -> Bool
isp<-[k -> Maybe (h -> Bool)
forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k], h
h<-[h
forall a. Bounded a => a
minBound..h
forall a. Bounded a => a
maxBound], h -> Bool
isp h
h, let s :: s
s = h -> k -> 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 = [ (Maybe a
forall a. Maybe a
Nothing,s
s,k
k) | k
k<-[k
forall a. Bounded a => a
minBound..k
forall a. Bounded a => a
maxBound], Maybe (h -> Bool)
Nothing <-[k -> Maybe (h -> Bool)
forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k], s
s<-[s
forall a. Bounded a => a
minBound..s
forall a. Bounded a => a
maxBound], k -> s -> Bool
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 :: 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 = Bool -> (h -> Bool) -> Maybe h -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\h
h->Bool -> (h -> Bool) -> Maybe h -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (h
hh -> h -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe h
mbh_) Maybe h
mbh
    s_ok :: Bool
s_ok = Bool -> (s -> Bool) -> Maybe s -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True                  (s
ss -> s -> Bool
forall a. Eq a => a -> a -> Bool
==)       Maybe s
mbs
    k_ok :: Bool
k_ok = Bool -> (k -> Bool) -> Maybe k -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True                  (k
kk -> k -> Bool
forall 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 :: Maybe k -> Text
keyHelp x :: Maybe k
x@Maybe k
Nothing  = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (k -> Text) -> [k] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (k -> String) -> k -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> String
forall a. Code a => a -> String
encode) [k
forall a. Bounded a => a
minBound..k
forall a. Bounded a => a
maxBound k -> k -> k
forall a. a -> a -> a
`asTypeOf` Maybe k -> k
forall a. HasCallStack => Maybe a -> a
fromJust Maybe k
x ]
keyHelp   (Just k
k) = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
f ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ (,) (k -> String
forall a. Code a => a -> String
encode k
k)    String
""                         ]
    , [ (,) String
"  hosts:"    String
hln | Just String
hln <- [Maybe String
mb_hln] ]
    , [ (,) String
"  sections:" String
sln | Maybe String
Nothing  <- [Maybe String
mb_hln] ]
    ]) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ k -> String
forall h s k. Sections h s k => k -> String
describeKey k
k) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]
  where
    mb_hln :: Maybe String
mb_hln = (h -> Bool) -> String
forall a. Code a => (a -> Bool) -> String
fmt ((h -> Bool) -> String) -> Maybe (h -> Bool) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Maybe (h -> Bool)
forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k
    sln :: String
sln    = (s -> Bool) -> String
forall a. Code a => (a -> Bool) -> String
fmt  ((s -> Bool) -> String) -> (s -> Bool) -> String
forall a b. (a -> b) -> a -> b
$  k -> s -> Bool
forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection   k
k

    f :: (String, String) -> String
f      = (String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> String -> String) -> (String, String) -> String)
-> (String -> String -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-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 :: Maybe s -> IO Text
sectionHelp x :: Maybe s
x@Maybe s
Nothing  = Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (s -> Text) -> [s] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Code a => a -> String
encode) [s
forall a. Bounded a => a
minBound..s
forall a. Bounded a => a
maxBound  s -> s -> s
forall a. a -> a -> a
`asTypeOf` Maybe s -> s
forall a. HasCallStack => Maybe a -> a
fromJust Maybe s
x ]
sectionHelp   (Just s
s) = do
  Settings
stgs <- Maybe s -> IO Settings
forall h s k. Sections h s k => Maybe s -> IO Settings
sectionSettings (Maybe s -> IO Settings) -> Maybe s -> IO Settings
forall a b. (a -> b) -> a -> b
$ s -> Maybe s
forall a. a -> Maybe a
Just s
s
  Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
f ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ (,) (s -> String
forall a. Code a => a -> String
encode s
s)          String
typ  ]
    , [ (,) String
"  p/w env var:"    String
env  ]
    , [ (,) String
"  hosts:"          String
hln  ]
    , [ (,) String
"  super sections:" String
sln  ]
    , [ (,) String
"  under sections:" String
uln  ]
    , [ (,) String
"  keys:"           String
kln  ]
    , [ (,) String
"  settings"        String
""   ]
    ]) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Settings -> [String]
fmt_s Settings
stgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ s -> String
forall h s k. Sections h s k => s -> String
describeSection s
s) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]
  where
    typ :: String
typ = case s -> SectionType
forall h s k. Sections h s k => s -> SectionType
sectionType s
s of
        SectionType
ST_top     -> String
"(top)"
        SectionType
ST_signing -> String
"(signing)"
        SectionType
ST_keys    -> String
"(keys)"
    env :: String
env = String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (EnvVar -> Text
_EnvVar (EnvVar -> Text) -> EnvVar -> Text
forall a b. (a -> b) -> a -> b
$ s -> EnvVar
forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s)
    hln :: String
hln = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [ h -> String
forall a. Code a => a -> String
encode h
h | h
h<-[h
forall a. Bounded a => a
minBound..h
forall a. Bounded a => a
maxBound], h -> s
forall h s k. Sections h s k => h -> s
hostDeploySection h
hs -> s -> Bool
forall a. Eq a => a -> a -> Bool
==s
s ]
    sln :: String
sln = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (s -> String) -> [s] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map s -> String
forall a. Code a => a -> String
encode ([s] -> [String]) -> [s] -> [String]
forall a b. (a -> b) -> a -> b
$ s -> [s]
forall h s k. Sections h s k => s -> [s]
superSections s
s
    uln :: String
uln = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (s -> String) -> [s] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map s -> String
forall a. Code a => a -> String
encode ([s] -> [String]) -> [s] -> [String]
forall a b. (a -> b) -> a -> b
$ [ s
s_ | s
s_<-[s
forall a. Bounded a => a
minBound..s
forall a. Bounded a => a
maxBound], s
s s -> [s] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` s -> [s]
forall h s k. Sections h s k => s -> [s]
superSections s
s_ ]
    kln :: String
kln = (k -> Bool) -> String
forall a. Code a => (a -> Bool) -> String
fmt ((k -> Bool) -> String) -> (k -> Bool) -> String
forall a b. (a -> b) -> a -> b
$ (k -> s -> Bool) -> s -> k -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip k -> s -> Bool
forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection s
s

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

    fmt_s :: Settings -> [String]
fmt_s Settings
stgs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
LBS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Object -> Value
A.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Object
forall a. HashMap Text a -> KM a
A.intoKM (HashMap Text Value -> Object) -> HashMap Text Value -> Object
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 :: IC -> SECTIONS h s k -> IO Text
secretKeySummary IC
ic SECTIONS h s k
scn = REFORMAT h s k -> IO Text -> IO Text
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> IO [Text] -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (s -> IO Text) -> [s] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM s -> IO Text
forall h s k. Sections h s k => s -> IO Text
f (SECTIONS h s k -> [s]
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 <- String -> Text
T.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IC -> Bool -> Name -> IO ByteString
showSecret IC
ic Bool
False (Name -> IO ByteString) -> Name -> IO ByteString
forall a b. (a -> b) -> a -> b
$ s -> Name
forall h s k. Sections h s k => s -> Name
passwordName s
s)
      Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"export ",EnvVar -> Text
_EnvVar (EnvVar -> Text) -> EnvVar -> Text
forall a b. (a -> b) -> a -> b
$ s -> EnvVar
forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s,Text
"=",Text
sec]

    ic' :: REFORMAT h s k
ic' = SECTIONS h s k -> IC -> REFORMAT h s k
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 :: IC -> SECTIONS h s k -> String -> IO Text
publicKeySummary IC
ic SECTIONS h s k
scn String
fp = REFORMAT h s k -> IO Text -> IO Text
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
f (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> Bool -> Name -> IO ByteString
showPublic IC
ic Bool
True (s -> Name
forall h s k. Sections h s k => s -> Name
sgn_nme (s -> Name) -> s -> Name
forall a b. (a -> b) -> a -> b
$ SECTIONS h s k -> s
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 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"echo '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
B.unpack ByteString
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' >" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

    ic' :: REFORMAT h s k
ic' = SECTIONS h s k -> IC -> REFORMAT h s k
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 :: IC -> SECTIONS h s k -> Name -> IO [Key]
locateKeys IC
ic SECTIONS h s k
scn Name
nm = REFORMAT h s k -> Name -> IO [Key]
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' = SECTIONS h s k -> IC -> REFORMAT h s k
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 :: REFORMAT h s k -> Name -> IO [Key]
locate_keys REFORMAT h s k
ic' Name
nm = REFORMAT h s k -> IO [Key] -> IO [Key]
forall h s k a. Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat REFORMAT h s k
ic' (IO [Key] -> IO [Key]) -> IO [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key -> Ordering) -> [Key] -> [Key]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Key -> Key -> Ordering) -> Key -> Key -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Key -> Key -> Ordering) -> Key -> Key -> Ordering)
-> (Key -> Key -> Ordering) -> Key -> Key -> Ordering
forall a b. (a -> b) -> a -> b
$ (Key -> Name) -> Key -> Key -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Key -> Name
_key_name) ([Key] -> [Key]) -> ([Key] -> [Key]) -> [Key] -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter Key -> Bool
yup ([Key] -> [Key]) -> IO [Key] -> IO [Key]
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 (Name -> Bool) -> (Key -> Name) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Name
_key_name
    isp :: Name -> Bool
isp Name
nm' = String
nm_s String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Name -> String
_name Name
nm'
    nm_s :: String
nm_s    = Name -> String
_name Name
nm
    ic :: IC
ic      = REFORMAT h s k -> 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 :: h -> k -> Either RetrieveDg Name
keyName h
h k
k = do
  Maybe h
mb_h <- case k -> Maybe (h -> Bool)
forall h s k. Sections h s k => k -> Maybe (h -> Bool)
keyIsHostIndexed k
k of
            Maybe (h -> Bool)
Nothing             -> Maybe h -> Either RetrieveDg (Maybe h)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe h
forall a. Maybe a
Nothing
            Just h -> Bool
hp | h -> Bool
hp h
h      -> Maybe h -> Either RetrieveDg (Maybe h)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe h -> Either RetrieveDg (Maybe h))
-> Maybe h -> Either RetrieveDg (Maybe h)
forall a b. (a -> b) -> a -> b
$ h -> Maybe h
forall a. a -> Maybe a
Just h
h
                    | Bool
otherwise -> RetrieveDg -> Either RetrieveDg (Maybe h)
forall a b. a -> Either a b
Left RetrieveDg
RDG_no_such_host_key
  s
s <- h -> k -> Retrieve s
forall h s k. Sections h s k => h -> k -> Retrieve s
keySection h
h k
k
  Name -> Either RetrieveDg Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Either RetrieveDg Name) -> Name -> Either RetrieveDg Name
forall a b. (a -> b) -> a -> b
$ Maybe h -> s -> k -> Name
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_ :: Maybe h -> s -> k -> Name
keyName_ Maybe h
mb_h s
s k
k = String -> Name
name' (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ s -> String
forall a. Code a => a -> String
encode s
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Code a => a -> String
encode k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hst_sfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
  where
    hst_sfx :: String
hst_sfx = String -> (h -> String) -> Maybe h -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\h
h -> String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ h -> String
forall a. Code a => a -> String
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 :: h -> k -> s
key_section h
h k
k = (RetrieveDg -> s) -> (s -> s) -> Either RetrieveDg s -> s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RetrieveDg -> s
forall a a. Show a => a -> a
oops s -> s
forall a. a -> a
id (Either RetrieveDg s -> s) -> Either RetrieveDg s -> s
forall a b. (a -> b) -> a -> b
$ h -> k -> Either RetrieveDg s
forall h s k. Sections h s k => h -> k -> Retrieve s
keySection h
h k
k
  where
    oops :: a -> a
oops a
dg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"key_section: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ h -> String
forall a. Code a => a -> String
encode h
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Code a => a -> String
encode k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
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 :: h -> k -> Retrieve s
keySection h
h k
k = Retrieve s -> (s -> Retrieve s) -> Maybe s -> Retrieve s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RetrieveDg -> Retrieve s
forall a b. a -> Either a b
Left RetrieveDg
RDG_key_not_reachable) s -> Retrieve s
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe s -> Retrieve s) -> Maybe s -> Retrieve s
forall a b. (a -> b) -> a -> b
$ [s] -> Maybe s
forall a. [a] -> Maybe a
listToMaybe ([s] -> Maybe s) -> [s] -> Maybe s
forall a b. (a -> b) -> a -> b
$
  (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (k -> s -> Bool
forall h s k. Sections h s k => k -> s -> Bool
keyIsInSection k
k) ([s] -> [s]) -> [s] -> [s]
forall a b. (a -> b) -> a -> b
$ s -> [s]
forall h s k. Sections h s k => s -> [s]
lower_sections (s -> [s]) -> s -> [s]
forall a b. (a -> b) -> a -> b
$ h -> s
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 :: s -> Name
passwordName s
s = String -> Name
name' (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"/pw/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall a. Code a => a -> String
encode s
s

fmt :: Code a => (a->Bool) -> String
fmt :: (a -> Bool) -> String
fmt a -> Bool
p  = [String] -> String
unwords [ a -> String
forall a. Code a => a -> String
encode a
h | a
h<-[a
forall a. Bounded a => a
minBound..a
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' :: 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
..}) <- Maybe h -> s -> k -> IO (KeyDataMode, KeyData)
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 Bool -> (KeyDataMode -> Bool) -> Maybe KeyDataMode -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (KeyDataMode -> KeyDataMode -> Bool
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 <- (Key -> Maybe KeyData) -> [Key] -> [Maybe KeyData]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe KeyData
key2KeyData ([Key] -> [Maybe KeyData]) -> IO [Key] -> IO [Maybe KeyData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IC -> SECTIONS h s k -> Name -> IO [Key]
forall h s k.
Sections h s k =>
IC -> SECTIONS h s k -> Name -> IO [Key]
locateKeys IC
ic (k -> SECTIONS h s k
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
kdKeyData -> KeyData -> Bool
forall a. Eq a => a -> a -> Bool
==KeyData
kd' -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False    -- the key has not changes
              Maybe KeyData
Nothing :[Maybe KeyData]
_           -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False    -- secret not accessible to compare
              [Maybe KeyData]
_                    -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Bool
False ->
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Name
n_nm <- IC -> Name -> IO Name
unique_nme IC
ic Name
g_nm
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"rotating: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
_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 Maybe EnvVar
forall a. Maybe a
Nothing (Maybe ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
kd_secret
      Bool
False ->
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    g_nm :: Name
g_nm = Maybe h -> s -> k -> Name
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 :: k -> SECTIONS h s k
mks = SECTIONS h s k -> k -> SECTIONS h s k
forall a b. a -> b -> a
const SECTIONS h s k
forall h s k. SECTIONS h s k
SECTIONS

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

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

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

add_signing :: Sections h s k => IC -> s -> IO ()
add_signing :: IC -> s -> IO ()
add_signing IC
ic s
s = IC -> Name -> Comment -> Identity -> [Safeguard] -> IO ()
createRSAKeyPair IC
ic (s -> Name
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  (Text -> Comment) -> Text -> Comment
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"signing key"
    pw_sg :: Safeguard
pw_sg = [Name] -> Safeguard
safeguard [s -> Name
forall h s k. Sections h s k => s -> Name
passwordName s
s]

add_password :: Sections h s k => IC -> s -> IO ()
add_password :: 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 (EnvVar -> Maybe EnvVar
forall a. a -> Maybe a
Just EnvVar
ev) Maybe ByteString
forall a. Maybe a
Nothing
  where
    cmt :: Comment
cmt = Text -> Comment
Comment  (Text -> Comment) -> Text -> Comment
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"password for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall a. Code a => a -> String
encode s
s
    ide :: Identity
ide = Identity
""
    ev :: EnvVar
ev  = s -> EnvVar
forall h s k. Sections h s k => s -> EnvVar
sectionPWEnvVar s
s

    nm :: Name
nm  = s -> Name
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 :: 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    = s -> Name
forall h s k. Sections h s k => s -> Name
sve_nme s
s
    cmt :: Comment
cmt   = Text -> Comment
Comment  (Text -> Comment) -> Text -> Comment
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"save key for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall a. Code a => a -> String
encode s
s
    ide :: Identity
ide   = Identity
""
    pw_sg :: Safeguard
pw_sg = [Name] -> Safeguard
safeguard [s -> Name
forall h s k. Sections h s k => s -> Name
passwordName s
s]

add_trigger :: Sections h s k => IC -> s -> IO ()
add_trigger :: IC -> s -> IO ()
add_trigger IC
ic s
s = do
    Settings
stgs <- (s -> Settings
forall h s k. Sections h s k => s -> Settings
bu_settings s
s Settings -> Settings -> Settings
forall a. Semigroup a => a -> a -> a
<>) (Settings -> Settings) -> IO Settings -> IO Settings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe s -> IO Settings
forall h s k. Sections h s k => Maybe s -> IO Settings
sectionSettings (s -> Maybe s
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 (Text -> TriggerID) -> Text -> TriggerID
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ s -> String
forall a. Code a => a -> String
encode s
s
    pat :: Pattern
pat    = s -> Pattern
forall h s k. Sections h s k => s -> Pattern
scn_pattern s
s

bu_settings :: Sections h s k => s -> Settings
bu_settings :: s -> Settings
bu_settings s
s = HashMap Text Value -> Settings
Settings (HashMap Text Value -> Settings) -> HashMap Text Value -> Settings
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ (Text
"backup.keys"
      , Array -> Value
A.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Array
forall a. a -> Vector a
V.singleton (Value -> Array) -> Value -> Array
forall a b. (a -> b) -> a -> b
$ Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
_name (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ s -> Name
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 :: SECTIONS h s k -> s
signing_key SECTIONS h s k
_ = s -> (s -> s) -> Maybe s -> s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe s
forall a. a
oops s -> s
forall a. a -> a
id (Maybe s -> s) -> Maybe s -> s
forall a b. (a -> b) -> a -> b
$ [s] -> Maybe s
forall a. [a] -> Maybe a
listToMaybe [ s
s_ | s
s_<-[s
forall a. Bounded a => a
minBound..s
forall a. Bounded a => a
maxBound], s -> SectionType
forall h s k. Sections h s k => s -> SectionType
sectionType s
s_ SectionType -> SectionType -> Bool
forall a. Eq a => a -> a -> Bool
== SectionType
ST_signing ]
  where
    oops :: a
oops = String -> a
forall a. HasCallStack => String -> a
error String
"signing_key: there is no signing key!"

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

backup_password :: Sections h s k => IC -> s -> s -> IO ()
backup_password :: IC -> s -> s -> IO ()
backup_password IC
ic s
s s
sv_s = IC -> Name -> Safeguard -> IO ()
secureKey IC
ic (s -> Name
forall h s k. Sections h s k => s -> Name
passwordName s
s) (Safeguard -> IO ()) -> Safeguard -> IO ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Safeguard
safeguard [s -> Name
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 :: s -> Name
sgn_nme s
s = String -> Name
name' (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ s -> String
forall a. Code a => a -> String
encode s
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/keystore_signing_key"

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

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

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

unique_nme' :: [Name] -> Name -> Name
unique_nme' :: [Name] -> Name -> Name
unique_nme' [Name]
nms Name
nm0 = String -> [Name] -> Name
forall a. HasCallStack => String -> [a] -> a
headNote String
"unique_name'" [Name]
c_nms
  where
    c_nms :: [Name]
c_nms = [ Name
nm | Int
i<-[[Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
nmsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..], let nm :: Name
nm=Int -> Name -> Name
nname Int
i Name
nm0, Name
nm Name -> [Name] -> Bool
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_ = String -> Name
name' (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
_name Name
nm_ String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%03d" Int
i

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

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


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


reformat :: Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat :: 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 (REFORMAT h s k -> Encoding
forall h s k. Sections h s k => REFORMAT h s k -> Encoding
encoding REFORMAT h s k
rft) IC
ic IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
p

-- Proxy city!

data REFORMAT h s k = REFORMAT { 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 :: SECTIONS h s k -> IC -> REFORMAT h s k
scn_RFT SECTIONS h s k
_ IC
ic = IC -> REFORMAT h s k
forall h s k. IC -> REFORMAT h s k
REFORMAT IC
ic
kp_RFT :: KeyPredicate h s k -> IC -> REFORMAT h s k
kp_RFT  KeyPredicate h s k
_ IC
ic = IC -> REFORMAT h s k
forall h s k. IC -> REFORMAT h s k
REFORMAT IC
ic
h_RFT :: h -> IC -> REFORMAT h s k
h_RFT   h
_ IC
ic = IC -> REFORMAT h s k
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 (State -> IO ()) -> State -> IO ()
forall a b. (a -> b) -> a -> b
$
    State
st { st_keystore :: KeyStore
st_keystore = Encoding -> KeyStore -> KeyStore
reformat_keystore Encoding
enc (KeyStore -> KeyStore) -> KeyStore -> KeyStore
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 Opt Bool -> Settings -> Bool
forall a. Opt a -> Settings -> a
getSettingsOpt Opt Bool
opt__sections_fix (Settings -> Bool) -> Settings -> Bool
forall a b. (a -> b) -> a -> b
$ Configuration -> Settings
_cfg_settings (Configuration -> Settings) -> Configuration -> Settings
forall a b. (a -> b) -> a -> b
$ KeyStore -> Configuration
_ks_config KeyStore
ks of
    Bool
True  -> KeyStore
ks
    Bool
False -> ASetter KeyStore KeyStore Configuration Configuration
-> (Configuration -> Configuration) -> KeyStore -> KeyStore
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter KeyStore KeyStore Configuration Configuration
Lens' KeyStore Configuration
ks_config (Encoding -> Configuration -> Configuration
reformat_config  Encoding
enc) (KeyStore -> KeyStore) -> KeyStore -> KeyStore
forall a b. (a -> b) -> a -> b
$
             ASetter KeyStore KeyStore KeyMap KeyMap
-> (KeyMap -> KeyMap) -> KeyStore -> KeyStore
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter KeyStore KeyStore KeyMap KeyMap
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 =
  ASetter Configuration Configuration Settings Settings
-> (Settings -> Settings) -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Configuration Configuration Settings Settings
Lens' Configuration Settings
cfg_settings (Opt Bool -> Bool -> Settings -> Settings
forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt Bool
opt__sections_fix Bool
True) (Configuration -> Configuration)
-> (Configuration -> Configuration)
-> Configuration
-> Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ASetter Configuration Configuration Settings Settings
-> (Settings -> Settings) -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Configuration Configuration Settings Settings
Lens' Configuration Settings
cfg_settings (Encoding -> Settings -> Settings
reformat_settings Encoding
enc) (Configuration -> Configuration)
-> (Configuration -> Configuration)
-> Configuration
-> Configuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ASetter Configuration Configuration TriggerMap TriggerMap
-> (TriggerMap -> TriggerMap) -> Configuration -> Configuration
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Configuration Configuration TriggerMap TriggerMap
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 = (Trigger -> Trigger) -> TriggerMap -> TriggerMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Trigger -> Trigger) -> TriggerMap -> TriggerMap)
-> (Trigger -> Trigger) -> TriggerMap -> TriggerMap
forall a b. (a -> b) -> a -> b
$
  ASetter Trigger Trigger Pattern Pattern
-> (Pattern -> Pattern) -> Trigger -> Trigger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Trigger Trigger Pattern Pattern
Lens' Trigger Pattern
trg_pattern  (Encoding -> Pattern -> Pattern
reformat_pattern  Encoding
enc) (Trigger -> Trigger) -> (Trigger -> Trigger) -> Trigger -> Trigger
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ASetter Trigger Trigger Settings Settings
-> (Settings -> Settings) -> Trigger -> Trigger
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Trigger Trigger Settings Settings
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 Opt [Name] -> Settings -> Maybe [Name]
forall a. Opt a -> Settings -> Maybe a
getSettingsOpt' Opt [Name]
opt__backup_keys Settings
stgs of
    Maybe [Name]
Nothing  -> Settings
stgs
    Just [Name]
nms -> Opt [Name] -> [Name] -> Settings -> Settings
forall a. Opt a -> a -> Settings -> Settings
setSettingsOpt Opt [Name]
opt__backup_keys ((Name -> Name) -> [Name] -> [Name]
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 = Pattern -> (Pattern -> Pattern) -> Maybe Pattern -> Pattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pattern
forall a. a
oops Pattern -> Pattern
forall a. a -> a
id (Maybe Pattern -> Pattern) -> Maybe Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ Munch Pattern -> String -> Maybe Pattern
forall a. Munch a -> String -> Maybe a
run_munch (Encoding -> Munch Pattern
m_pattern Encoding
enc) (String -> Maybe Pattern) -> String -> Maybe Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> String
_pat_string Pattern
pat
  where
    oops :: a
oops = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"reformat_pattern: bad pattern format: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
_pat_string Pattern
pat

reformat_key_map :: Encoding -> KeyMap -> KeyMap
reformat_key_map :: Encoding -> KeyMap -> KeyMap
reformat_key_map Encoding
enc KeyMap
km = [(Name, Key)] -> KeyMap
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)<-KeyMap -> [(Name, Key)]
forall k a. Map k a -> [(k, a)]
Map.toList KeyMap
km ]
  where
    r_ky :: Key -> Key
r_ky =
      ASetter Key Key Name Name -> (Name -> Name) -> Key -> Key
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Key Key Name Name
Lens' Key Name
key_name          (Encoding -> Name -> Name
reformat_name Encoding
enc) (Key -> Key) -> (Key -> Key) -> Key -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ASetter Key Key EncrypedCopyMap EncrypedCopyMap
-> (EncrypedCopyMap -> EncrypedCopyMap) -> Key -> Key
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Key Key EncrypedCopyMap EncrypedCopyMap
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 = [(Safeguard, EncrypedCopy)] -> EncrypedCopyMap
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)<-EncrypedCopyMap -> [(Safeguard, EncrypedCopy)]
forall k a. Map k a -> [(k, a)]
Map.toList EncrypedCopyMap
ecm ]
  where
    r_ec :: EncrypedCopy -> EncrypedCopy
r_ec = ASetter EncrypedCopy EncrypedCopy Safeguard Safeguard
-> (Safeguard -> Safeguard) -> EncrypedCopy -> EncrypedCopy
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter EncrypedCopy EncrypedCopy Safeguard Safeguard
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 ([Name] -> Safeguard)
-> (Safeguard -> [Name]) -> Safeguard -> Safeguard
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Encoding -> Name -> Name
reformat_name Encoding
enc) ([Name] -> [Name]) -> (Safeguard -> [Name]) -> Safeguard -> [Name]
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 = Name -> (Name -> Name) -> Maybe Name -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
forall a. a
oops Name -> Name
forall a. a -> a
id (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ Munch Name -> String -> Maybe Name
forall a. Munch a -> String -> Maybe a
run_munch (Encoding -> Munch Name
m_name Encoding
enc) (String -> Maybe Name) -> String -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Name -> String
_name Name
nm
  where
    oops :: a
oops = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"reformat_name: bad name format: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
_name Name
nm

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

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 Munch Name -> Munch Name -> Munch Name
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Encoding -> Munch Name
m_pw Encoding
enc Munch Name -> Munch Name -> Munch Name
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
  String -> Munch ()
munch_ String
"save_"
  String
s <- Encoding -> Munch String
enc_s Encoding
enc
  Name -> Munch Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Munch Name) -> Name -> Munch Name
forall a b. (a -> b) -> a -> b
$ String -> Name
name' (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"/save/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

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

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

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

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

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

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

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

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

munch_vrn :: Munch String
munch_vrn :: Munch String
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
  String -> Munch String
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 String
enc_h, Encoding -> Munch String
enc_s, Encoding -> Munch String
enc_k :: Munch String
    }

encoding :: Sections h s k => REFORMAT h s k -> Encoding
encoding :: REFORMAT h s k -> Encoding
encoding REFORMAT h s k
rft =
  Encoding :: Munch String -> Munch String -> Munch String -> Encoding
Encoding
    { enc_h :: Munch String
enc_h = CODE h -> Munch String
forall a. Code a => CODE a -> Munch String
code_m (CODE h -> Munch String) -> CODE h -> Munch String
forall a b. (a -> b) -> a -> b
$ REFORMAT h s k -> CODE h
forall h s k. Sections h s k => REFORMAT h s k -> CODE h
host_c    REFORMAT h s k
rft
    , enc_s :: Munch String
enc_s = CODE s -> Munch String
forall a. Code a => CODE a -> Munch String
code_m (CODE s -> Munch String) -> CODE s -> Munch String
forall a b. (a -> b) -> a -> b
$ REFORMAT h s k -> CODE s
forall h s k. Sections h s k => REFORMAT h s k -> CODE s
section_c REFORMAT h s k
rft
    , enc_k :: Munch String
enc_k = CODE k -> Munch String
forall a. Code a => CODE a -> Munch String
code_m (CODE k -> Munch String) -> CODE k -> Munch String
forall a b. (a -> b) -> a -> b
$ REFORMAT h s k -> CODE k
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 :: REFORMAT h s k -> CODE h
host_c    REFORMAT h s k
_ = CODE h
forall a. CODE a
CODE

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

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

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

-- our Munch Monad

newtype Munch a = Munch { Munch a -> String -> Maybe (a, String)
_Munch :: String -> Maybe (a,String) }

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

instance Applicative Munch where
  pure :: a -> Munch a
pure a
x  = (String -> Maybe (a, String)) -> Munch a
forall a. (String -> Maybe (a, String)) -> Munch a
Munch ((String -> Maybe (a, String)) -> Munch a)
-> (String -> Maybe (a, String)) -> Munch a
forall a b. (a -> b) -> a -> b
$ \String
s -> (a, String) -> Maybe (a, String)
forall a. a -> Maybe a
Just (a
x,String
s)
  <*> :: Munch (a -> b) -> Munch a -> Munch 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 :: Munch a
empty     = (String -> Maybe (a, String)) -> Munch a
forall a. (String -> Maybe (a, String)) -> Munch a
Munch ((String -> Maybe (a, String)) -> Munch a)
-> (String -> Maybe (a, String)) -> Munch a
forall a b. (a -> b) -> a -> b
$ Maybe (a, String) -> String -> Maybe (a, String)
forall a b. a -> b -> a
const Maybe (a, String)
forall a. Maybe a
Nothing
  <|> :: Munch a -> Munch a -> Munch a
(<|>) Munch a
x Munch a
y = (String -> Maybe (a, String)) -> Munch a
forall a. (String -> Maybe (a, String)) -> Munch a
Munch ((String -> Maybe (a, String)) -> Munch a)
-> (String -> Maybe (a, String)) -> Munch a
forall a b. (a -> b) -> a -> b
$ \String
s -> Munch a -> String -> Maybe (a, String)
forall a. Munch a -> String -> Maybe (a, String)
_Munch Munch a
x String
s Maybe (a, String) -> Maybe (a, String) -> Maybe (a, String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Munch a -> String -> Maybe (a, String)
forall a. Munch a -> String -> Maybe (a, String)
_Munch Munch a
y String
s

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

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

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

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

munch :: String -> Munch String
munch :: String -> Munch String
munch String
str_p = (String -> Maybe (String, String)) -> Munch String
forall a. (String -> Maybe (a, String)) -> Munch a
Munch ((String -> Maybe (String, String)) -> Munch String)
-> (String -> Maybe (String, String)) -> Munch String
forall a b. (a -> b) -> a -> b
$ \String
str -> case String
str_p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str of
  Bool
True  -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
str_p,Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str_p) String
str)
  Bool
False -> Maybe (String, String)
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 (ClearText -> KeyData) -> Maybe ClearText -> Maybe KeyData
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 :: Identity -> Comment -> ByteString -> KeyData
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' :: String -> Name
name' = (Reason -> Name) -> (Name -> Name) -> Either Reason Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Name
forall a. HasCallStack => String -> a
error(String -> Name) -> (Reason -> String) -> Reason -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Reason -> String
forall a. Show a => a -> String
show) Name -> Name
forall a. a -> a
id (Either Reason Name -> Name)
-> (String -> Either Reason Name) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either Reason Name
name