Main.hs

{-# 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"

Tried to add the file validation code on lines 72 and 73, in addition to the function at the bottom, 141-146, but I ran into the following error on stack install:

Sorry!

I was a bit lazy with my example code on S/O.

Here's a few suggested edits, and some explanation:

checkForAFile :: FilePath -> IO ()
checkForAFile path = do
    validFile <- doesFileExist path
    if validFile
       then putStrLn $ path ++ " is a file that exists"
       else putStrLn $ path ++ " is not a file that exists"

I forgot the = do bit, to complete the function declaration and enter a do block.
I also messed up the argument declaration, accidentally referring to the file path argument as both path and filePath.
I fixed both errors and double-checked that it actually works.

When you're attempting to call the function on pwds, you're actually trying to call the file check on the result of the following statement:

    pwds <- case cfgPasswords of
        Just passPath -> (map (Just . T.unpack) . lines) <$>
            readFileUtf8 passPath
        Nothing       -> return $ replicate (length cfgPublicKeys) Nothing

That won't work for two reasons.

1. The value pwds doesn't exist 'yet'
2. The type of pwds in this expression is actually [Maybe String] , (Or possibly [Maybe Text] , difficult to tell because there is some weird type conversion stuff going on with OverloadedStrings), representing a list of passwords that may or may not exist.

The value that is representing the filepath is cfgPasswords, which is of type Maybe FilePath, or Maybe String (FilePath is a type synonym for String).

This value is being called into scope implicitly by the enclosing function, run, and it's first argument, cfg@Config{..}

That value is kind of a lot to unpack, but the short and sweet explanation is that Config{..} is using the RecordWildCards extension to pull the fields into scope as named field values from the Config type, which seems to be imported from the Constellation.Node.Config module above.

The type signature for our little checkForAFile function says that it operates on FilePath, and not Maybe Filepath. so that means we have a type mismatch with cfgPasswords.

There are many ways we can address this, but the most basic is to use pattern matching.

Maybe is a type available from Prelude - It looks like this (basically):

data Maybe a = Just a | Nothing

What that means in English is:
"I am a type that wraps type a, which may be any one type. Instances of me may either be a value of that type a, wrapped in my constructor Just, or they may be nothing at all, represented by the nullary constructor Nothing"

When this code is 'binding' a value to pwds, above, you can see that they are using a case statement referencing cfgPasswords -
The case statement has two branches, one for each of the constructors of Maybe.
You could replicate that pattern to log your message to console, like follows:

case cfgPassword of
     Just aPath -> checkForAFile aPath
     Nothing -> return ()

Which would invoke our function and log a message to console about whether or not our file exists.

But, someone is already going through the trouble of making a case statement for us, so it seems a little silly to make a fresh one. We could just piggy-back on the one they've already got.

    pwds <- case cfgPasswords of
        Just passPath -> do
               checkForAFile passPath
                (map (Just . T.unpack) . lines) <$> readFileUtf8 passPath
        Nothing       -> return $ replicate (length cfgPublicKeys) Nothing

We need to enter a 'do' block here, because expressions (like the case expression) have to evaluate to a single value - If we just put in our check for a file, it would evaluate to IO (), which is kind of like evaluating to void. do lets us to multiple IO things in a single function/expression, and return the last one as our result.

That's a pretty terse explanation - There is an awful lot going on in this code at once, so it's a bit much to deal with as someone new to Haskell. Please let me know if you have any questions, and I'll do my best to help out.

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...

import System.Directory (doesFileExist, removeFile,getPermissions)

Retool our file validator to be a bit more sane...

validFile :: FilePath -> IO Bool
validFile path = do
    exists <- (doesFileExist path)
    if exists
    then (readable <$> getPermissions path)
    else return False

and then...

pwds <- case cfgPasswords of
    Just passPath -> do
         pathChecksOut <- validFile passPath
         when (not pathChecksOut) $ 
             errorL' ("Failed to access file at : " ++ passPath)
         (map (Just . T.unpack) . lines) <$> readFileUtf8 passPath
    Nothing       -> return $ replicate (length cfgPublicKeys) Nothing

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 use Control.Logging and errorL' to log an error message to stderr, and then, apparently also call error from Prelude?
I believe the normal usecase there would be to use the withFileLogging function from Control.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.

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: