Created
August 23, 2017 13:24
-
-
Save smatthewenglish/41e18c23d34009bd7b69ed925b4ed2d8 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE NoImplicitPrelude #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE RecordWildCards #-} | |
{-# LANGUAGE StrictData #-} | |
module Constellation.Node.Main where | |
import ClassyPrelude hiding (getArgs, log) | |
import Control.Concurrent (forkIO) | |
import Control.Logging | |
( LogLevel(LevelDebug, LevelInfo, LevelWarn, LevelError) | |
, setLogLevel, withStderrLogging, log', errorL' | |
) | |
import Data.Text.Format (Shown(Shown)) | |
import GHC.Conc (getNumProcessors) | |
import Network.Socket | |
( Family(AF_UNIX), SocketType(Stream), SockAddr(SockAddrUnix) | |
, socket, bind, listen, maxListenQueue, close | |
) | |
import System.Directory (doesFileExist, removeFile) | |
import System.Environment (getArgs) | |
import qualified Data.Text as T | |
import qualified Network.Wai.Handler.Warp as Warp | |
import Constellation.Enclave | |
(newEnclave', enclaveEncryptPayload, enclaveDecryptPayload) | |
import Constellation.Enclave.Key (mustLoadKeyPairs, mustLoadPublicKeys) | |
import Constellation.Enclave.Keygen.Main (generateKeyPair) | |
import Constellation.Node (newNode, runNode) | |
import Constellation.Node.Storage.BerkeleyDb (berkeleyDbStorage) | |
import Constellation.Node.Storage.Directory (directoryStorage) | |
import Constellation.Node.Storage.LevelDb (levelDbStorage) | |
import Constellation.Node.Storage.Memory (memoryStorage) | |
import Constellation.Node.Storage.Sqlite (sqliteStorage) | |
import Constellation.Node.Types | |
( Node(nodeStorage) | |
, Crypt(Crypt, encryptPayload, decryptPayload) | |
, Storage(closeStorage) | |
) | |
import Constellation.Node.Config (Config(..), extractConfig) | |
import Constellation.Util.AtExit (registerAtExit, withAtExit) | |
import Constellation.Util.Logging (debugf', logf', warnf) | |
import qualified Constellation.Node.Api as NodeApi | |
version :: Text | |
version = "0.1.0" | |
defaultMain :: IO () | |
defaultMain = do | |
args <- getArgs | |
(cfg, _) <- extractConfig args | |
if cfgJustShowVersion cfg | |
then putStrLn ("Constellation Node " ++ version) | |
else case cfgJustGenerateKeys cfg of | |
[] -> withStderrLogging $ run cfg | |
ks -> mapM_ generateKeyPair ks | |
run :: Config -> IO () | |
run cfg@Config{..} = do | |
let logLevel = case cfgVerbosity of | |
0 -> LevelError | |
1 -> LevelWarn | |
2 -> LevelInfo | |
3 -> LevelDebug | |
_ -> LevelDebug | |
logf' "Log level is {}" [show logLevel] | |
setLogLevel logLevel | |
debugf' "Configuration: {}" [show cfg] | |
ncpus <- getNumProcessors | |
logf' "Utilizing {} core(s)" [ncpus] | |
setNumCapabilities ncpus | |
-- validating passwords file | |
checkForAFile pwds | |
pwds <- case cfgPasswords of | |
Just passPath -> (map (Just . T.unpack) . lines) <$> | |
readFileUtf8 passPath | |
Nothing -> return $ replicate (length cfgPublicKeys) Nothing | |
when (length cfgPublicKeys /= length cfgPrivateKeys) $ | |
errorL' "The same amount of public keys and private keys must be specified" | |
when (length cfgPublicKeys /= length pwds) $ | |
errorL' "The same amount of passwords must be included in the passwords file as the number of private keys. (If a private key has no password, include a blank line.)" | |
when (cfgPort == 0) $ | |
errorL' "A listening port must be specified with 'port' in the configuration file or --port at runtime" | |
let kps = zip3 cfgPublicKeys cfgPrivateKeys pwds | |
logf' "Constructing Enclave using keypairs {}" | |
[show $ zip cfgPublicKeys cfgPrivateKeys] | |
ks <- mustLoadKeyPairs kps | |
e <- newEnclave' ks | |
let crypt = Crypt | |
{ encryptPayload = enclaveEncryptPayload e | |
, decryptPayload = enclaveDecryptPayload e | |
} | |
ast <- mustLoadPublicKeys cfgAlwaysSendTo | |
logf' "Initializing storage {}" [cfgStorage] | |
let experimentalStorageCaveat s = warnf "The {} storage engine is experimental. It may be removed or changed at any time. Please see the discussion at https://github.com/jpmorganchase/constellation/issues/37" [s :: Text] | |
storage <- case break (== ':') cfgStorage of | |
("bdb", ':':path) -> berkeleyDbStorage path | |
("dir", ':':path) -> directoryStorage path | |
("leveldb", ':':path) -> experimentalStorageCaveat "LevelDB" | |
>> levelDbStorage path | |
("memory", _ ) -> memoryStorage | |
("sqlite", ':':path) -> experimentalStorageCaveat "SQLite" | |
>> sqliteStorage path | |
_ -> berkeleyDbStorage cfgStorage -- Default | |
nvar <- newTVarIO =<< | |
newNode crypt storage cfgUrl (map fst ks) ast cfgOtherNodes | |
_ <- forkIO $ do | |
let mwl = if null cfgIpWhitelist | |
then Nothing | |
else Just $ NodeApi.whitelist cfgIpWhitelist | |
logf' "Public API listening on 0.0.0.0 port {} with whitelist: {}" | |
( cfgPort | |
, Shown $ if isNothing mwl then ["Disabled"] else cfgIpWhitelist | |
) | |
Warp.run cfgPort $ NodeApi.app mwl NodeApi.Public nvar | |
_ <- case cfgSocket of | |
Just sockPath -> void $ forkIO $ do | |
logf' "Internal API listening on {}" [sockPath] | |
resetSocket sockPath | |
sock <- socket AF_UNIX Stream 0 | |
bind sock $ SockAddrUnix sockPath | |
listen sock maxListenQueue | |
Warp.runSettingsSocket Warp.defaultSettings sock $ | |
NodeApi.app Nothing NodeApi.Private nvar | |
close sock | |
Nothing -> return () | |
registerAtExit $ do | |
log' "Shutting down... (Interrupting this will cause the next startup to take longer)" | |
case cfgSocket of | |
Just sockPath -> resetSocket sockPath | |
Nothing -> return () | |
readTVarIO nvar >>= closeStorage . nodeStorage | |
log' "Node started" | |
withAtExit $ runNode nvar | |
resetSocket :: FilePath -> IO () | |
resetSocket sockPath = doesFileExist sockPath >>= \exists -> | |
when exists $ removeFile sockPath | |
checkForAFile :: FilePath -> IO () | |
checkForAFile path | |
validFile <- doesFileExist filePath | |
if validFile | |
then putStrLn $ filePath ++ " is a file that exists" | |
else putStrLn $ filePath ++ " is not a file that exists" |
For some reason, although I implemented the those specified changes, I'm not able to build the project on my machine.
The error I got was Couldn't match type ‘[Char]’ with ‘Text’
, and it pointed me to the following line:
errorL' ("Failed to access file at : " ++ passPath)
It seems there's a question about StackOverflow that tries to address a similar issue, this one. In an attempt to follow that advice I adapted the line like so errorL' ("Failed to access file at : " ++ (passPath :: Text))
, but still I wan't able to build the project.
The exact console output I received after implementing the changes you recommend in your last post looks like this:
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
After some research into the core purpose of this module, it becomes apparent that, should an invalid path be specified, the sane action should be to abort immediately.
In that case, I'd suggest the following:
Import getPermissions from System.Directory...
Retool our file validator to be a bit more sane...
and then...
This calls
errorL'
instead, which interrupts control flow and logs to the same error buffer as the rest of the calls to errorL', which in this case, appears to be stderr.I am, frankly, a little baffled at that particular design choice, as it seems that there is no real difference between just using
error
from prelude, rather than choosing to useControl.Logging
anderrorL'
to log an error message to stderr, and then, apparently also callerror
from Prelude?I believe the normal usecase there would be to use the
withFileLogging
function fromControl.Logging
so that your error message is output both to a file -and- to stderr, but perhaps they've chosen to do it this way for the sake of consistency with other logging used throughout the module.Anyway, I'm pretty sure that will get you the behavior you want.