Initial release

.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+h
+*.key
+*.pub

Constellation/Configure/Main.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Constellation.Configure.Main where
+
+import ClassyPrelude
+import System.Console.Haskeline
+    (InputT, runInputT, defaultSettings, getPassword)
+import System.Environment (getArgs, getProgName)
+import Text.Printf (printf)
+
+defaultMain :: IO ()
+defaultMain = runInputT defaultSettings configure
+
+configure :: MonadIO m => InputT m ()
+configure = do
+    putStrLn "hi"

Constellation/Enclave.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+module Constellation.Enclave where
+
+import ClassyPrelude
+import qualified Crypto.Saltine.Core.Box as Box
+import qualified Data.HashMap.Strict as HM
+
+import Constellation.Enclave.Key (loadKeyPairs)
+import Constellation.Enclave.Payload
+    ( EncryptedPayload(EncryptedPayload, eplSender, eplCt, eplNonce
+                      , eplRcptBoxes, eplRcptNonce)
+    , safeBeforeNM, encrypt', decrypt'
+    )
+import Constellation.Enclave.Types (PublicKey(PublicKey), unPublicKey)
+import Constellation.Util.Exception (trys)
+
+data Enclave = Enclave
+    { enclaveKeys       :: HM.HashMap PublicKey Box.SecretKey
+    , enclaveComboCache :: TVar (HM.HashMap (PublicKey, PublicKey) Box.CombinedKey)
+    }
+
+newEnclave :: [(FilePath, FilePath)] -> IO (Either String Enclave)
+newEnclave keyPaths = loadKeyPairs keyPaths >>= \case
+    Left err  -> return $ Left err
+    Right kps -> Right <$> newEnclave' kps
+
+newEnclave' :: [(PublicKey, Box.SecretKey)] -> IO Enclave
+newEnclave' keyPairs = do
+    cvar <- newTVarIO HM.empty
+    return Enclave
+        { enclaveKeys       = HM.fromList keyPairs
+        , enclaveComboCache = cvar
+        }
+
+enclaveEncryptPayload :: Enclave
+                      -> ByteString
+                      -> PublicKey
+                      -> [PublicKey]
+                      -> IO (Either String EncryptedPayload)
+enclaveEncryptPayload e pl sender rcpts = do
+    ecks <- trys $ atomically $ getCombinedKeys e sender rcpts
+    case ecks of
+        Left err  -> return $ Left err
+        Right cks -> Right <$> encrypt' pl (unPublicKey sender) cks
+
+getCombinedKeys :: Enclave
+                -> PublicKey
+                -> [PublicKey]
+                -> STM [Box.CombinedKey]
+getCombinedKeys Enclave{..} sender rcpts = do
+    curCache <- readTVar enclaveComboCache
+    let (cks, finalCc, ccChanged) = foldr get ([], curCache, False) rcpts
+        get rcpt (ks, cc, chd)    = case HM.lookup (sender, rcpt) cc of
+            Nothing -> case HM.lookup sender enclaveKeys of
+                Nothing -> error "getCombinedKeys: Matching private key not found"
+                Just pk -> (k:ks, ncc, True)
+                  where
+                    k   = safeBeforeNM (unPublicKey sender) pk (unPublicKey rcpt)
+                    ncc = HM.insert (sender, rcpt) k cc
+            Just k  -> (k:ks, cc, chd)
+    when ccChanged $ writeTVar enclaveComboCache finalCc
+    return cks
+
+enclaveDecryptPayload :: Enclave
+                      -> EncryptedPayload
+                      -> PublicKey
+                      -> IO (Either String ByteString)
+enclaveDecryptPayload e EncryptedPayload{..} rcptPub = do
+    ecks <- trys $ atomically $ getCombinedKeys e rcptPub [PublicKey eplSender]
+    case ecks of
+        Left err   -> return $ Left err
+        Right []   -> return $ Left "enclaveDecrypt: No CombinedKey found"
+        Right [ck] -> case eplRcptBoxes of
+            (rcptBox:_) -> case decrypt' eplCt eplNonce rcptBox eplRcptNonce ck of
+                Nothing -> return $ Left "enclaveDecrypt: Decryption failed"
+                Just pt -> return $ Right pt
+            _           -> return $ Left "enclaveDecrypt: No rcptBox found"
+        _          -> return $ Left "enclaveDecrypt: More than one CombinedKey found"

Constellation/Enclave/Key.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Constellation.Enclave.Key where
+
+import Prelude (putStrLn)
+import ClassyPrelude hiding (hash, putStrLn)
+import qualified Data.Aeson as AE
+import qualified Crypto.Saltine.Class as S
+import qualified Crypto.Saltine.Core.Box as Box
+
+import Constellation.Enclave.Types (PublicKey(PublicKey), mkPublicKey)
+import Constellation.Util.ByteString (b64TextDecodeBs)
+import Constellation.Util.Either (fromShowRight, flattenEithers)
+import Constellation.Util.Lockable (promptingUnlock)
+
+newKeyPair :: IO (PublicKey, Box.SecretKey)
+newKeyPair = do
+    (priv, pub) <- Box.newKeypair
+    return (PublicKey pub, priv)
+
+loadKeyPair :: (FilePath, FilePath)
+            -> IO (Either String (PublicKey, Box.SecretKey))
+loadKeyPair (pubPath, privPath) = b64TextDecodeBs <$> readFile pubPath >>= \case
+    Left err    -> return $ Left err
+    Right pubBs -> case mkPublicKey pubBs of
+        Nothing  -> return $ Left "loadKeyPair: Failed to mkPublicKey"
+        Just pub -> AE.eitherDecode' <$> readFile privPath >>= \case
+            Left err     -> return $ Left err
+            Right locked -> do
+                putStrLn ("Unlocking " ++ privPath)
+                promptingUnlock locked >>= \case
+                    Left err     -> return $ Left err
+                    Right privBs -> case S.decode privBs of
+                        Nothing   -> return $ Left "Failed to S.encode privBs"
+                        Just priv -> return $ Right (pub, priv)
+
+loadKeyPairs :: [(FilePath, FilePath)]
+             -> IO (Either String [(PublicKey, Box.SecretKey)])
+loadKeyPairs kpaths = flattenEithers "; " <$> mapM loadKeyPair kpaths
+
+mustLoadKeyPairs :: [(FilePath, FilePath)] -> IO [(PublicKey, Box.SecretKey)]
+mustLoadKeyPairs kpaths = fromShowRight <$> loadKeyPairs kpaths

Constellation/Enclave/Keygen/Main.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Constellation.Enclave.Keygen.Main where
+
+import ClassyPrelude hiding (getArgs, writeFile)
+import System.Console.Haskeline (runInputT, defaultSettings, getPassword)
+import System.Environment (getArgs, getProgName)
+import Text.Printf (printf)
+import qualified Crypto.Saltine.Class as S
+import qualified Data.Aeson as AE
+import qualified Data.ByteString.Base64.Lazy as B64L
+import qualified Data.ByteString.Lazy as BL
+
+import Constellation.Enclave.Key (newKeyPair)
+import Constellation.Enclave.Types (PublicKey(unPublicKey))
+import Constellation.Util.Lockable (Lockable(Unlocked), lock)
+import Constellation.Util.Text (tformat)
+
+defaultMain :: IO ()
+defaultMain = getArgs >>= \case
+    [] -> usage
+    xs -> mapM_ generateKeyPair xs
+
+generateKeyPair :: String -> IO ()
+generateKeyPair name = do
+    mpwd <- runInputT defaultSettings $
+        getPassword (Just '*') (printf "Lock key pair %s with password [none]: " name)
+    (pub, priv) <- newKeyPair
+    BL.writeFile (name ++ ".pub") $ B64L.encode $ BL.fromStrict $ S.encode $
+        unPublicKey pub
+    k <- case mpwd of
+        Nothing  -> return $ Unlocked (S.encode priv)
+        Just ""  -> return $ Unlocked (S.encode priv)
+        Just pwd -> lock pwd (S.encode priv)
+    BL.writeFile (name ++ ".key") $ AE.encode k
+
+usage :: IO ()
+usage = getProgName >>= \progName ->
+    putStrLn $ tformat "Usage: {} <keypair name> <keypair name>..." progName

Constellation/Enclave/Main.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Constellation.Enclave.Main where
+
+import ClassyPrelude
+
+defaultMain :: IO ()
+defaultMain = putStrLn "The remote Enclave is not yet supported"

Constellation/Enclave/Payload.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Constellation.Enclave.Payload where
+
+import ClassyPrelude
+import Data.Binary (Binary(put, get))
+import Data.Maybe (fromJust)
+import qualified Crypto.Saltine.Class as S
+import qualified Crypto.Saltine.Core.Box as Box
+import qualified Crypto.Saltine.Core.SecretBox as SBox
+
+data EncryptedPayload = EncryptedPayload
+    { eplSender    :: !Box.PublicKey
+    , eplCt        :: !ByteString
+    , eplNonce     :: !SBox.Nonce
+    , eplRcptBoxes :: ![ByteString]
+    , eplRcptNonce :: !Box.Nonce
+    }
+
+instance Show EncryptedPayload where
+    show = show . encodeable
+
+encodeable :: EncryptedPayload
+           -> (ByteString, ByteString, ByteString, [ByteString], ByteString)
+encodeable EncryptedPayload{..} =
+    ( S.encode eplSender
+    , eplCt
+    , S.encode eplNonce
+    , eplRcptBoxes
+    , S.encode eplRcptNonce
+    )
+
+instance Binary EncryptedPayload where
+    put = put . encodeable
+    get = get >>= \(sender, ct, nonce, rcptBoxes, rcptNonce) -> return EncryptedPayload
+        { eplSender    = fromJust $ S.decode sender
+        , eplCt        = ct
+        , eplNonce     = fromJust $ S.decode nonce
+        , eplRcptBoxes = rcptBoxes
+        , eplRcptNonce = fromJust $ S.decode rcptNonce
+        }
+
+encrypt :: ByteString
+        -> Box.PublicKey
+        -> Box.SecretKey
+        -> [Box.PublicKey]
+        -> IO EncryptedPayload
+encrypt pl sender pk rcpts = encrypt' pl sender cks
+  where
+    cks = map (safeBeforeNM sender pk) rcpts
+
+safeBeforeNM :: Box.PublicKey -> Box.SecretKey -> Box.PublicKey -> Box.CombinedKey
+safeBeforeNM sender pk rcpt
+    | sender == rcpt = error "encrypt: Sender cannot be a recipient"
+    | otherwise      = Box.beforeNM pk rcpt
+
+encrypt' :: ByteString
+         -> Box.PublicKey
+         -> [Box.CombinedKey]
+         -> IO EncryptedPayload
+encrypt' pl sender cks = do
+    (mk, nonce, ct) <- sboxSeal pl
+    rcptNonce       <- Box.newNonce
+    let rcptBoxes = map (\ck -> Box.boxAfterNM ck rcptNonce emk) cks
+        emk       = S.encode mk
+    return EncryptedPayload
+        { eplSender    = sender
+        , eplCt        = ct
+        , eplNonce     = nonce
+        , eplRcptBoxes = rcptBoxes
+        , eplRcptNonce = rcptNonce
+        }
+
+sboxSeal :: ByteString -> IO (SBox.Key, SBox.Nonce, ByteString)
+sboxSeal pt = do
+    nonce <- SBox.newNonce
+    mk    <- SBox.newKey
+    let ct = SBox.secretbox mk nonce pt
+    return (mk, nonce, ct)
+
+decrypt :: ByteString
+        -> SBox.Nonce
+        -> ByteString
+        -> Box.Nonce
+        -> Box.PublicKey
+        -> Box.SecretKey
+        -> Maybe ByteString
+decrypt ct nonce rcptBox rcptNonce senderPub pk =
+    decrypt' ct nonce rcptBox rcptNonce ck
+  where
+    ck = Box.beforeNM pk senderPub
+
+decrypt' :: ByteString
+         -> SBox.Nonce
+         -> ByteString
+         -> Box.Nonce
+         -> Box.CombinedKey
+         -> Maybe ByteString
+decrypt' ct nonce rcptBox rcptNonce ck =
+    case Box.boxOpenAfterNM ck rcptNonce rcptBox of
+        Nothing -> Nothing
+        Just emk -> case S.decode emk of
+            Nothing -> Nothing
+            Just mk -> SBox.secretboxOpen mk nonce ct

Constellation/Enclave/Types.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Constellation.Enclave.Types where
+
+import ClassyPrelude
+import Data.Aeson (FromJSON(parseJSON))
+import Data.Binary (Binary(put, get))
+import Data.Hashable (Hashable(hashWithSalt))
+import Data.Maybe (fromJust)
+import qualified Crypto.Saltine.Class as S
+import qualified Crypto.Saltine.Core.Box as Box
+import qualified Data.Aeson as AE
+import qualified Data.ByteString.Base64 as B64
+
+import Constellation.Util.ByteString (b64TextDecodeBs)
+
+newtype PublicKey = PublicKey { unPublicKey :: Box.PublicKey }
+                  deriving (Eq)
+
+instance Show PublicKey where
+    show (PublicKey pub) = show $ B64.encode $ S.encode pub
+
+instance Binary PublicKey where
+    put = put . S.encode . unPublicKey
+    get = (PublicKey . fromJust . S.decode) <$> get
+
+instance Hashable PublicKey where
+    hashWithSalt salt (PublicKey pub) = hashWithSalt salt (S.encode pub)
+
+instance FromJSON PublicKey where
+    parseJSON (AE.String s) = case b64TextDecodeBs s of
+        Left err -> fail err
+        Right bs -> case mkPublicKey bs of
+            Nothing  -> fail "Failed to mkPublicKey"
+            Just pub -> return pub
+    parseJSON _             = fail "PublicKey must be an Aeson String"
+
+mkPublicKey :: ByteString -> Maybe PublicKey
+mkPublicKey bs = PublicKey <$> S.decode bs