keystore-0.8.1.1: src/Data/KeyStore/Sections.hs
{-# 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.Text as T
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Aeson as A
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 s = listToMaybe [ k | k<-[minBound..maxBound], encode k==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 = const ST_keys
superSections = const []
keyIsHostIndexed = const Nothing
keyIsInSection = const $ const True
getKeyData mb s k = snd <$> getKeyDataWithMode mb s k
getKeyDataWithMode Nothing s = get_kd $ encode s
getKeyDataWithMode (Just h) _ = get_kd $ encode h
sectionSettings = const $ return mempty
describeKey k = "The '" ++ encode k ++ "' key."
describeSection s = "The '" ++ encode s ++ "' Section."
sectionPWEnvVar = EnvVar . T.pack . ("KEY_pw_" ++) . 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 (Show,Eq,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
{ kd_identity :: Identity
, kd_comment :: Comment
, kd_secret :: B.ByteString
}
deriving (Show,Eq)
data KeyDataMode
= KDM_static
| KDM_random
deriving (Bounded,Enum,Eq,Ord,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 (Show,Eq,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 cp kp = do
stgs <- setSettingsOpt opt__sections_fix True <$> scs kp Nothing
newKeyStore (the_keystore cp) stgs
ic <- instanceCtx cp
mapM_ (mks kp ic) [minBound..maxBound]
rotate ic kp
map _key_name <$> keys ic >>= mapM_ (keyInfo ic)
where
scs :: Sections h s k => KeyPredicate h s k -> Maybe s -> IO Settings
scs = const sectionSettings
mks :: Sections h s k => KeyPredicate h s k -> IC -> s -> IO ()
mks = const mkSection
-- | Rotate in a set of keys specified by the predicate.
rotate :: Sections h s k => IC -> KeyPredicate h s k -> IO ()
rotate ic = rotate_ ic Nothing 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 = rotate_ ic Nothing 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 mb ch kp = reformat ic' $ sequence_ [ rotate' mb ch ic mb_h s k | (mb_h,s,k)<-listKeys kp ]
where
ic' = kp_RFT kp 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 = reformat ic' $ either (return . Left) (\nm->Right <$> locate_keys ic' nm) $ keyName h k
where
ic' = h_RFT h 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 scn = reformat ic' $ B.readFile (the_keystore $ ic_ctx_params ic) >>= sign_ ic (sgn_nme $ signing_key scn)
where
ic' = scn_RFT scn 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 scn sig = reformat ic' $ B.readFile (the_keystore $ ic_ctx_params ic) >>= flip (verify_ ic) sig
where
ic' = scn_RFT scn ic
-- | A predicate specifying all of the keys in the store.
noKeys :: KeyPredicate h s k
noKeys _ _ _ = False
-- | A predicate specifying none of the keys in the keystore.
allKeys :: KeyPredicate h s k
allKeys _ _ _ = True
-- | List all of the keys specified by a KeyPredicate
listKeys :: Sections h s k => KeyPredicate h s k -> [(Maybe h,s,k)]
listKeys kp = [ trp | trp@(mb_h,s,k)<-host_keys++non_host_keys, kp mb_h s k ]
where
host_keys = [ (Just h ,s,k) | k<-[minBound..maxBound], Just isp<-[keyIsHostIndexed k], h<-[minBound..maxBound], isp h, let s = key_section h k ]
non_host_keys = [ (Nothing,s,k) | k<-[minBound..maxBound], Nothing <-[keyIsHostIndexed k], s<-[minBound..maxBound], keyIsInSection k 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 mbh mbs mbk mbh_ s k = h_ok && s_ok && k_ok
where
h_ok = maybe True (\h->maybe False (h==) mbh_) mbh
s_ok = maybe True (s==) mbs
k_ok = maybe True (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 x@Nothing = T.unlines $ map (T.pack . encode) [minBound..maxBound `asTypeOf` fromJust x ]
keyHelp (Just k) = T.unlines $ map T.pack $ (map f $ concat
[ [ (,) (encode k) "" ]
, [ (,) " hosts:" hln | Just hln <- [mb_hln] ]
, [ (,) " sections:" sln | Nothing <- [mb_hln] ]
]) ++ "" : map (" "++) (lines $ describeKey k) ++ [""]
where
mb_hln = fmt <$> keyIsHostIndexed k
sln = fmt $ keyIsInSection k
f = uncurry $ printf "%-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 x@Nothing = return $ T.unlines $ map (T.pack . encode) [minBound..maxBound `asTypeOf` fromJust x ]
sectionHelp (Just s) = do
stgs <- sectionSettings $ Just s
return $ T.unlines $ map T.pack $ (map f $ concat
[ [ (,) (encode s) typ ]
, [ (,) " p/w env var:" env ]
, [ (,) " hosts:" hln ]
, [ (,) " super sections:" sln ]
, [ (,) " under sections:" uln ]
, [ (,) " keys:" kln ]
, [ (,) " settings" "" ]
]) ++ fmt_s stgs ++ "" : map (" "++) (lines $ describeSection s) ++ [""]
where
typ = case sectionType s of
ST_top -> "(top)"
ST_signing -> "(signing)"
ST_keys -> "(keys)"
env = "$" ++ T.unpack (_EnvVar $ sectionPWEnvVar s)
hln = unwords $ nub [ encode h | h<-[minBound..maxBound], hostDeploySection h==s ]
sln = unwords $ map encode $ superSections s
uln = unwords $ map encode $ [ s_ | s_<-[minBound..maxBound], s `elem` superSections s_ ]
kln = fmt $ flip keyIsInSection s
f = uncurry $ printf "%-20s %s"
fmt_s stgs = map (" "++) $ lines $ LBS.unpack $ A.encode $ A.Object $ _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 scn = reformat ic' $ T.unlines <$> mapM f (sections scn)
where
f s = do
sec <- T.pack . B.unpack <$> (showSecret ic False $ passwordName s)
return $ T.concat ["export ",_EnvVar $ sectionPWEnvVar s,"=",sec]
ic' = scn_RFT scn 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 scn fp = reformat ic' $ f <$> showPublic ic True (sgn_nme $ signing_key scn)
where
f b = T.pack $ "echo '" ++ B.unpack b ++ "' >" ++ fp ++ "\n"
ic' = scn_RFT scn 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 scn nm = locate_keys ic' nm
where
ic' = scn_RFT scn ic
locate_keys :: Sections h s k => REFORMAT h s k -> Name -> IO [Key]
locate_keys ic' nm = reformat ic' $ sortBy (flip $ comparing _key_name) . filter yup <$> keys ic
where
yup = isp . _key_name
isp nm' = nm_s `isPrefixOf` _name nm'
nm_s = _name nm
ic = _REFORMAT 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 = do
mb_h <- case keyIsHostIndexed k of
Nothing -> return Nothing
Just hp | hp h -> return $ Just h
| otherwise -> Left RDG_no_such_host_key
s <- keySection h k
return $ keyName_ mb_h s 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_ mb_h s k = name' $ encode s ++ "/" ++ encode k ++ hst_sfx ++ "/"
where
hst_sfx = maybe "" (\h -> "/" ++ encode 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 = either oops id $ keySection h k
where
oops dg = error $ "key_section: " ++ encode h ++ ": " ++ encode k ++ ": " ++ show 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 = maybe (Left RDG_key_not_reachable) return $ listToMaybe $
filter (keyIsInSection k) $ lower_sections $ hostDeploySection h
-- | The name of the key that stores the password for a given sections.
passwordName :: Sections h s k => s -> Name
passwordName s = name' $ "/pw/" ++ encode s
fmt :: Code a => (a->Bool) -> String
fmt p = unwords [ encode h | h<-[minBound..maxBound], p h ]
rotate' :: Sections h s k => Maybe KeyDataMode -> Bool -> IC -> Maybe h -> s -> k -> IO ()
rotate' mb ch ic mb_h s k = do
(kdm,kd@KeyData{..}) <- getKeyDataWithMode mb_h s k
-- if the KeyDataMode is specified but does not match the key's mode then squash the rotation
case maybe True (==kdm) mb of
True -> do
-- iff ch then compare the new value with the old
ok <- case ch of
True -> do
-- if key has not changed, or the secret text is not available
-- then squash the rotation
mbkds <- map key2KeyData <$> locateKeys ic (mks k) g_nm
case mbkds of
Just kd':_ | kd==kd' -> return False -- the key has not changes
Nothing :_ -> return False -- secret not accessible to compare
_ -> return True
False ->
return True
when ok $ do
n_nm <- unique_nme ic g_nm
putStrLn $ "rotating: " ++ _name n_nm
createKey ic n_nm kd_comment kd_identity Nothing $ Just kd_secret
False ->
return ()
where
g_nm = keyName_ mb_h s k
mks :: k -> SECTIONS h s k
mks = const SECTIONS
lower_sections :: Sections h s k => s -> [s]
lower_sections s0 =
s0 : concat
[ s:lower_sections s | s<-[minBound..maxBound], s0 `elem` superSections s ]
mkSection :: Sections h s k => IC -> s -> IO ()
mkSection ic s = do
mk_section ic s
case sectionType s of
ST_top -> return ()
ST_signing -> add_signing ic s
ST_keys -> return ()
mk_section :: Sections h s k => IC -> s -> IO ()
mk_section ic s =
do add_password ic s
add_save_key ic s
add_trigger ic s
mapM_ (backup_password ic s) $ superSections s
add_signing :: Sections h s k => IC -> s -> IO ()
add_signing ic s = createRSAKeyPair ic (sgn_nme s) cmt "" [pw_sg]
where
cmt = Comment $ T.pack $ "signing key"
pw_sg = safeguard [passwordName s]
add_password :: Sections h s k => IC -> s -> IO ()
add_password ic s = createKey ic nm cmt ide (Just ev) Nothing
where
cmt = Comment $ T.pack $ "password for " ++ encode s
ide = ""
ev = sectionPWEnvVar s
nm = passwordName s
add_save_key :: Sections h s k => IC -> s -> IO ()
add_save_key ic s = createRSAKeyPair ic nm cmt ide [pw_sg]
where
nm = sve_nme s
cmt = Comment $ T.pack $ "save key for " ++ encode s
ide = ""
pw_sg = safeguard [passwordName s]
add_trigger :: Sections h s k => IC -> s -> IO ()
add_trigger ic s = do
stgs <- (bu_settings s <>) <$> sectionSettings (Just s)
addTrigger' ic tid pat stgs
where
tid = TriggerID $ T.pack $ encode s
pat = scn_pattern s
bu_settings :: Sections h s k => s -> Settings
bu_settings s = Settings $ HM.fromList
[ ("backup.keys"
, A.Array $ V.singleton $ A.String $ T.pack $ _name $ sve_nme s
)
]
signing_key :: Sections h s k => SECTIONS h s k -> s
signing_key _ = maybe oops id $ listToMaybe [ s_ | s_<-[minBound..maxBound], sectionType s_ == ST_signing ]
where
oops = error "signing_key: there is no signing key!"
sections :: Sections h s k => SECTIONS h s k -> [s]
sections _ = [minBound..maxBound]
backup_password :: Sections h s k => IC -> s -> s -> IO ()
backup_password ic s sv_s = secureKey ic (passwordName s) $ safeguard [sve_nme sv_s]
sgn_nme :: Sections h s k => s -> Name
sgn_nme s = name' $ encode s ++ "/keystore_signing_key"
sve_nme :: Sections h s k => s -> Name
sve_nme s = name' $ "/save/" ++ encode s
scn_pattern :: Sections h s k => s -> Pattern
scn_pattern s = pattern $ "^" ++ encode s ++ "/.*"
unique_nme :: IC -> Name -> IO Name
unique_nme ic nm =
do nms <- filter isp . map _key_name <$> keys ic
return $ unique_nme' nms nm
where
isp nm' = _name nm `isPrefixOf` _name nm'
unique_nme' :: [Name] -> Name -> Name
unique_nme' nms nm0 = headNote "unique_name'" c_nms
where
c_nms = [ nm | i<-[length nms+1..], let nm=nname i nm0, nm `notElem` nms ]
nname :: Int -> Name -> Name
nname i nm_ = name' $ _name nm_ ++ printf "%03d" i
the_keystore :: CtxParams -> FilePath
the_keystore = maybe "keystore.json" id . cp_store
get_kd :: Sections h s k => String -> k -> IO (KeyDataMode,KeyData)
get_kd sd k = do
ide <- B.readFile $ fp "_id"
cmt <- B.readFile $ fp "_cmt"
sec <- B.readFile $ fp ""
return
( KDM_static
, KeyData
{ kd_identity = Identity $ T.pack $ B.unpack ide
, kd_comment = Comment $ T.pack $ B.unpack cmt
, kd_secret = sec
}
)
where
fp sfx = sd </> encode k ++ sfx
--------------------------------------------------------------------------------
--
-- Reformating the KeyStore Names to Allow Prefixes (#3)
--
--------------------------------------------------------------------------------
reformat :: Sections h s k => REFORMAT h s k -> IO a -> IO a
reformat rft@(REFORMAT ic) p = reformat_ic (encoding rft) ic >> p
-- Proxy city!
data REFORMAT h s k = REFORMAT { _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 _ ic = REFORMAT ic
kp_RFT _ ic = REFORMAT ic
h_RFT _ ic = REFORMAT ic
reformat_ic :: Encoding -> IC -> IO ()
reformat_ic enc ic = do
(ctx,st) <- getCtxState ic
putCtxState ic ctx $
st { st_keystore = reformat_keystore enc $ st_keystore st }
reformat_keystore :: Encoding -> KeyStore -> KeyStore
reformat_keystore enc ks =
case getSettingsOpt opt__sections_fix $ _cfg_settings $ _ks_config ks of
True -> ks
False -> over ks_config (reformat_config enc) $
over ks_keymap (reformat_key_map enc) ks
reformat_config :: Encoding -> Configuration -> Configuration
reformat_config enc =
over cfg_settings (setSettingsOpt opt__sections_fix True) .
over cfg_settings (reformat_settings enc) .
over cfg_triggers (reformat_triggers enc)
reformat_triggers :: Encoding -> TriggerMap -> TriggerMap
reformat_triggers enc = Map.map $
over trg_pattern (reformat_pattern enc) .
over trg_settings (reformat_settings enc)
reformat_settings :: Encoding -> Settings -> Settings
reformat_settings enc stgs =
case getSettingsOpt' opt__backup_keys stgs of
Nothing -> stgs
Just nms -> setSettingsOpt opt__backup_keys (map (reformat_name enc) nms) stgs
reformat_pattern :: Encoding -> Pattern -> Pattern
reformat_pattern enc pat = maybe oops id $ run_munch (m_pattern enc) $ _pat_string pat
where
oops = error $ "reformat_pattern: bad pattern format: " ++ _pat_string pat
reformat_key_map :: Encoding -> KeyMap -> KeyMap
reformat_key_map enc km = Map.fromList [ (reformat_name enc nm,r_ky ky) | (nm,ky)<-Map.toList km ]
where
r_ky =
over key_name (reformat_name enc) .
over key_secret_copies (reformat_ecm enc)
reformat_ecm :: Encoding -> EncrypedCopyMap -> EncrypedCopyMap
reformat_ecm enc ecm = Map.fromList [ (reformat_sg enc sg,r_ec ec) | (sg,ec)<-Map.toList ecm ]
where
r_ec = over ec_safeguard (reformat_sg enc)
reformat_sg :: Encoding -> Safeguard -> Safeguard
reformat_sg enc = safeguard . map (reformat_name enc) . safeguardKeys
reformat_name :: Encoding -> Name -> Name
reformat_name enc nm = maybe oops id $ run_munch (m_name enc) $ _name nm
where
oops = error $ "reformat_name: bad name format: " ++ _name nm
m_pattern :: Encoding -> Munch Pattern
m_pattern enc = do
munch_ "^"
s <- enc_s enc
munch_ "_.*"
return $ fromString $ "^" ++ s ++ "/.*"
m_name, m_save, m_pw, m_section :: Encoding -> Munch Name
m_name enc = m_save enc <|> m_pw enc <|> m_section enc
m_save enc = do
munch_ "save_"
s <- enc_s enc
return $ name' $ "/save/" ++ s
m_pw enc = do
munch_ "pw_"
s <- enc_s enc
return $ name' $ "/pw/" ++ s
m_section enc = do
s <- enc_s enc
m_section_signing enc s <|> m_section_key enc s
m_section_key, m_section_signing :: Encoding -> String -> Munch Name
m_section_signing _ s = do
munch_ "_keystore_signing_key"
return $ name' $ s ++ "/keystore_signing_key"
m_section_key enc s = do
munch_ "_"
k <- enc_k enc
m_section_key_host enc s k <|> m_section_key_vrn enc s k
m_section_key_vrn, m_section_key_host :: Encoding -> String -> String -> Munch Name
m_section_key_vrn _ s k = do
munch_ "_"
v <- munch_vrn
return $ name' $ s ++"/" ++ k ++ "/" ++ v
m_section_key_host enc s k = do
munch_ "_"
h <- enc_h enc
munch_ "_"
v <- munch_vrn
return $ name' $ s ++"/" ++ k ++ "/" ++ h ++ "/" ++ v
munch_vrn :: Munch String
munch_vrn = do
c1 <- munch1 isDigit
c2 <- munch1 isDigit
c3 <- munch1 isDigit
return [c1,c2,c3]
-- Capturing the host, section and key encodings in a nice convenient
-- monotype that we can pass around.
data Encoding =
Encoding
{ enc_h, enc_s, enc_k :: Munch String
}
encoding :: Sections h s k => REFORMAT h s k -> Encoding
encoding rft =
Encoding
{ enc_h = code_m $ host_c rft
, enc_s = code_m $ section_c rft
, enc_k = code_m $ key_c rft
}
where
host_c :: Sections h s k => REFORMAT h s k -> CODE h
host_c _ = CODE
section_c :: Sections h s k => REFORMAT h s k -> CODE s
section_c _ = CODE
key_c :: Sections h s k => REFORMAT h s k -> CODE k
key_c _ = CODE
code_m :: Code a => CODE a -> Munch String
code_m c = foldr (<|>) empty $ [ munch $ encode x | x<-bds c ]
where
bds :: Code a => CODE a -> [a]
bds _ = [minBound..maxBound]
-- our Munch Monad
newtype Munch a = Munch { _Munch :: String -> Maybe (a,String) }
instance Functor Munch where
fmap f m = m >>= \x -> return $ f x
instance Applicative Munch where
pure = return
(<*>) = ap
instance Alternative Munch where
empty = Munch $ const Nothing
(<|>) x y = Munch $ \s -> _Munch x s <|> _Munch y s
instance Monad Munch where
return x = Munch $ \s -> Just (x,s)
(>>=) m f = Munch $ \s -> _Munch m s >>= \(x,s') -> _Munch (f x) s'
run_munch :: Munch a -> String -> Maybe a
run_munch (Munch f) str = case f str of
Just (x,"") -> Just x
_ -> Nothing
munch1 :: (Char->Bool) -> Munch Char
munch1 p = Munch $ \str -> case str of
c:t | p c -> Just (c,t)
_ -> Nothing
munch_ :: String -> Munch ()
munch_ s = const () <$> munch s
munch :: String -> Munch String
munch str_p = Munch $ \str -> case str_p `isPrefixOf` str of
True -> Just (str_p,drop (length str_p) str)
False -> Nothing
--------------------------------------------------------------------------------
key2KeyData :: Key -> Maybe KeyData
key2KeyData Key{..} = f <$> _key_clear_text
where
f (ClearText(Binary bs)) =
KeyData
{ kd_identity = _key_identity
, kd_comment = _key_comment
, kd_secret = bs
}
name' :: String -> Name
name' = either (error.show) id . name