diff --git a/.travis.yml b/.travis.yml index 2e95c2f0..c5f4c355 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,7 +10,7 @@ stages: - "Build" - name: "Deploy" if: branch = master AND type = push - + jobs: include: - name: "Web" diff --git a/projects/br_scs/src/Mirza/BusinessRegistry/Main.hs b/projects/br_scs/src/Mirza/BusinessRegistry/Main.hs index 82080b19..7d092f13 100644 --- a/projects/br_scs/src/Mirza/BusinessRegistry/Main.hs +++ b/projects/br_scs/src/Mirza/BusinessRegistry/Main.hs @@ -20,17 +20,17 @@ import Mirza.Common.Types as CT import Data.GS1.EPC (GS1CompanyPrefix (..)) import Servant -import Servant.Swagger.UI import Servant.Auth.Server +import Servant.Swagger.UI import Crypto.JWT (Audience (..), string) import qualified Data.Pool as Pool import Database.PostgreSQL.Simple +import Network.URI (nullURI) import Network.Wai (Middleware) import qualified Network.Wai.Handler.Warp as Warp -import Network.URI (nullURI) import Data.Aeson (eitherDecodeFileStrict) @@ -39,13 +39,15 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Semigroup ((<>)) import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (decodeUtf8, + encodeUtf8) import Options.Applicative hiding (action) import Text.Email.Parser (addrSpec) -import Text.Email.Validate (validate, toByteString) +import Text.Email.Validate (toByteString, + validate) -import Control.Lens (review) import Control.Exception (finally) +import Control.Lens (review) import Data.Maybe (fromMaybe) import Katip as K import System.IO (IOMode (AppendMode), @@ -82,14 +84,14 @@ data ExecMode | Bootstrap EmailAddress GS1CompanyPrefix data ServerOptionsBR = ServerOptionsBR - { sobDbConnStr :: ByteString - , sobLoggingLevel :: K.Severity - , sobLogLocation :: Maybe FilePath - , sobEnvType :: CT.EnvType + { sobDbConnStr :: ByteString + , sobLoggingLevel :: K.Severity + , sobLogLocation :: Maybe FilePath + , sobEnvType :: CT.EnvType } data RunServerOptions = RunServerOptions - { rsoPortNumber :: Int + { rsoPortNumber :: Int , sobOAuthAudience :: Text } @@ -118,12 +120,12 @@ main = multiplexInitOptions =<< execParser opts where -- where the single binary could be split into multiple binaries. multiplexInitOptions :: InitOptionsBR -> IO () multiplexInitOptions (InitOptionsBR opts mode) = case mode of - RunServer rsOpts -> launchServer opts rsOpts - InitDb -> runMigration opts - UserAction uc -> runUserCommand opts uc - BusinessAction bc -> runBusinessCommand opts bc - PopulateDatabase -> runPopulateDatabase opts - Bootstrap email companyPrefix -> runBootstrap opts email companyPrefix + RunServer rsOpts -> launchServer opts rsOpts + InitDb -> runMigration opts + UserAction uc -> runUserCommand opts uc + BusinessAction bc -> runBusinessCommand opts bc + PopulateDatabase -> runPopulateDatabase opts + Bootstrap email companyPrefix -> runBootstrap opts email companyPrefix -------------------------------------------------------------------------------- @@ -354,19 +356,6 @@ runBootstrap opts email companyPrefix = do let newUserPhoneNumber = "" NewUser{..} - --------------------------------------------------------------------------------- --- Debug Command --------------------------------------------------------------------------------- - --- This is a debug function for activating development test stub functions. --- TODO: Remove this stub before release. -debugFunc :: IO() -debugFunc = do - putStrLn "Running Debug Option" - -- Debug test code goes here... - - -------------------------------------------------------------------------------- -- Command Line Options Argument Parsers -------------------------------------------------------------------------------- diff --git a/projects/br_scs/src/Mirza/BusinessRegistry/Service.hs b/projects/br_scs/src/Mirza/BusinessRegistry/Service.hs index 22406c3e..88fe5512 100644 --- a/projects/br_scs/src/Mirza/BusinessRegistry/Service.hs +++ b/projects/br_scs/src/Mirza/BusinessRegistry/Service.hs @@ -15,14 +15,13 @@ -- | Endpoint definitions go here. Most of the endpoint definitions are -- light wrappers around functions in BeamQueries module Mirza.BusinessRegistry.Service - ( - appHandlers + ( appHandlers , publicServer , privateServer , appMToHandler , serveSwaggerAPI , module Handlers - ) where + ) where import Mirza.Common.Utils diff --git a/projects/br_scs/src/Mirza/BusinessRegistry/Types.hs b/projects/br_scs/src/Mirza/BusinessRegistry/Types.hs index 739e6cbe..e2a25d2f 100644 --- a/projects/br_scs/src/Mirza/BusinessRegistry/Types.hs +++ b/projects/br_scs/src/Mirza/BusinessRegistry/Types.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mirza.BusinessRegistry.Types ( @@ -13,47 +14,47 @@ module Mirza.BusinessRegistry.Types ( , module CT ) where -import Mirza.Common.Time (CreationTime, - ExpirationTime, - RevocationTime) -import Mirza.Common.Types as CT +import Mirza.Common.Time (CreationTime, + ExpirationTime, + RevocationTime) +import Mirza.Common.Types as CT -import Data.GS1.EPC as EPC +import Data.GS1.EPC as EPC -import Data.Pool as Pool +import Data.Pool as Pool import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Syntax (PgDataTypeSyntax) -import Database.PostgreSQL.Simple (Connection, SqlError) +import qualified Database.Beam.Migrate as BMigrate +import qualified Database.Beam.Postgres as BPostgres +import Database.Beam.Postgres.Syntax (PgDataTypeSyntax) +import Database.PostgreSQL.Simple (Connection, SqlError) import Database.PostgreSQL.Simple.FromField (FromField, fromField) import Database.PostgreSQL.Simple.ToField (ToField, toField) -import qualified Database.Beam.Migrate as BMigrate -import qualified Database.Beam.Postgres as BPostgres -import Crypto.JOSE (JWK) -import Crypto.JWT (Audience, ClaimsSet, claimSub, string) +import Crypto.JOSE (JWK) +import Crypto.JWT (Audience, ClaimsSet, + claimSub, string) -import qualified Servant.Auth.Server as SAS +import qualified Servant.Auth.Server as SAS -import Katip as K +import Katip as K -import Network.URI (URI) - -import Control.Lens +import Network.URI (URI) import Data.Aeson -import Data.Aeson.Types import Data.Aeson.TH +import Data.Aeson.Types import Data.Swagger -import Data.Text (Text) -import Data.Time (LocalTime) +import Data.Text (Text) +import Data.Time (LocalTime) -import Data.Proxy (Proxy (..)) +import Control.Lens +import Data.Proxy (Proxy (..)) -import GHC.Generics (Generic) -import GHC.Stack (CallStack) +import GHC.Generics (Generic) +import GHC.Stack (CallStack) -- ***************************************************************************** -- Context Types @@ -258,12 +259,12 @@ longitudeType = BMigrate.DataType doubleType data LocationResponse = LocationResponse - { locationId :: PrimaryKeyType - , locationGLN :: EPC.LocationEPC - , locationBiz :: GS1CompanyPrefix - , geoLocId :: PrimaryKeyType - , geoLocCoord :: Maybe (Latitude, Longitude) - , geoLocAddress :: Maybe Text + { locationId :: PrimaryKeyType + , locationGLN :: EPC.LocationEPC + , locationBiz :: GS1CompanyPrefix + , geoLocId :: PrimaryKeyType + , geoLocCoord :: Maybe (Latitude, Longitude) + , geoLocAddress :: Maybe Text } deriving (Show, Generic, Eq) instance ToSchema LocationResponse instance ToJSON LocationResponse diff --git a/projects/br_scs/src/Mirza/SupplyChain/Main.hs b/projects/br_scs/src/Mirza/SupplyChain/Main.hs index a9599376..28532cba 100644 --- a/projects/br_scs/src/Mirza/SupplyChain/Main.hs +++ b/projects/br_scs/src/Mirza/SupplyChain/Main.hs @@ -8,11 +8,11 @@ import Mirza.SupplyChain.API import Mirza.SupplyChain.Auth import Mirza.SupplyChain.Database.Migrate import Mirza.SupplyChain.Service -import Mirza.SupplyChain.Types (AppError, EnvType (..), - SCSContext (..), User) +import Mirza.SupplyChain.Types (AppError, EnvType (..), + SCSContext (..), User) -import Mirza.SupplyChain.PopulateUtils (insertCitrusData) -import qualified Mirza.SupplyChain.Types as ST +import Mirza.SupplyChain.PopulateUtils (insertCitrusData) +import qualified Mirza.SupplyChain.Types as ST import Mirza.BusinessRegistry.Client.Servant @@ -20,32 +20,32 @@ import Servant import Servant.Client import Servant.Swagger.UI -import qualified Data.Pool as Pool +import qualified Data.Pool as Pool import Database.PostgreSQL.Simple -import Network.HTTP.Client (defaultManagerSettings, - newManager) -import Network.Wai (Middleware) -import qualified Network.Wai.Handler.Warp as Warp +import Network.HTTP.Client (defaultManagerSettings, + newManager) +import Network.Wai (Middleware) +import qualified Network.Wai.Handler.Warp as Warp -import Data.ByteString (ByteString) -import Data.Text (pack) +import Data.ByteString (ByteString) +import Data.Text (pack) -import Data.Semigroup ((<>)) +import Data.Semigroup ((<>)) import Options.Applicative import Control.Lens -import qualified Crypto.Scrypt as Scrypt +import qualified Crypto.Scrypt as Scrypt -import Control.Exception (finally) -import Data.Maybe (fromMaybe) -import Katip as K +import Control.Exception (finally) +import Data.Maybe (fromMaybe) +import Katip as K -import System.Exit (exitFailure) -import System.IO (IOMode (AppendMode), - hPutStrLn, openFile, - stderr, stdout) +import System.Exit (exitFailure) +import System.IO (IOMode (AppendMode), + hPutStrLn, openFile, + stderr, stdout) data ServerOptionsSCS = ServerOptionsSCS { env :: EnvType @@ -125,13 +125,12 @@ main = runProgram =<< execParser opts <> header "SupplyChainServer - A server for capturing GS1 events and recording them on a blockchain") runProgram :: ServerOptionsSCS -> IO () -runProgram so@ServerOptionsSCS{initDB = True, dbPopulateInfo =Just _, brServiceInfo =Just __} = do +runProgram so@ServerOptionsSCS{initDB = True, dbPopulateInfo =Just _, brServiceInfo =Just _} = do ctx <- initSCSContext so migrate ctx $ connectionStr so runDbPopulate so -runProgram so@ServerOptionsSCS{initDB =False, dbPopulateInfo =Just _, brServiceInfo =Just __} = do - runDbPopulate so -runProgram so@ServerOptionsSCS{initDB = False, scsServiceInfo=(scsHst, scsPort), brServiceInfo =Just __} = do +runProgram so@ServerOptionsSCS{initDB =False, dbPopulateInfo =Just _, brServiceInfo =Just _} = runDbPopulate so +runProgram so@ServerOptionsSCS{initDB = False, scsServiceInfo=(scsHst, scsPort), brServiceInfo =Just _} = do ctx <- initSCSContext so app <- initApplication so ctx mids <- initMiddleware so @@ -188,7 +187,7 @@ initSCSContext (ServerOptionsSCS envT _ _ dbConnStr _ n p r lev (Just (brHost, b mempty mempty (mkClientEnv manager baseUrl) -initSCSContext so@(ServerOptionsSCS{ brServiceInfo = Nothing}) = initSCSContext so{brServiceInfo = Just ("localhost", 8200)} +initSCSContext so@ServerOptionsSCS{brServiceInfo = Nothing} = initSCSContext so{brServiceInfo = Just ("localhost", 8200)} initApplication :: ServerOptionsSCS -> ST.SCSContext -> IO Application initApplication _so ev = diff --git a/projects/entity-data-api/EntityDataAPI.Dockerfile b/projects/entity-data-api/EntityDataAPI.Dockerfile index e1ff24dc..100dcf9c 100644 --- a/projects/entity-data-api/EntityDataAPI.Dockerfile +++ b/projects/entity-data-api/EntityDataAPI.Dockerfile @@ -1,15 +1,16 @@ ARG HS_BUILDER_IMAGE=hsbuilder:latest FROM $HS_BUILDER_IMAGE as BUILD -WORKDIR /edapi +RUN mkdir -p /src/edapi +WORKDIR /src/edapi -COPY stack.yaml entity-data-api.cabal LICENSE README.md /edapi/ -COPY src/ /edapi/src/ -COPY app/ /edapi/app/ +COPY stack.yaml entity-data-api.cabal LICENSE README.md /src/edapi/ +COPY src/ /src/edapi/src/ +COPY app/ /src/edapi/app/ RUN /usr/local/bin/stack install --test --dependencies-only --ghc-options='-O2 -j -fPIC' 2>&1 -RUN mkdir /edapi/dist/ && \ +RUN mkdir /src/edapi/dist/ && \ /usr/local/bin/stack install --ghc-options='-O2 -j -fPIC' 2>&1 @@ -18,6 +19,8 @@ FROM ubuntu:18.04 as PKG-EDAPI RUN apt update && \ apt install -y libpq-dev libffi-dev ca-certificates -COPY --from=0 /edapi/dist/entity-data-api /opt/Mirza/entity-data-api +RUN pwd; ls /; ls /src/edapi; ls /src + +COPY /src/edapi/dist/entity-data-api /opt/Mirza/entity-data-api ENTRYPOINT [ "/opt/Mirza/entity-data-api" ] diff --git a/projects/entity-data-api/database/init.sql b/projects/entity-data-api/database/init.sql new file mode 100644 index 00000000..875086ad --- /dev/null +++ b/projects/entity-data-api/database/init.sql @@ -0,0 +1,3 @@ +CREATE TABLE users ( + user_sub text NOT NULL PRIMARY KEY +); diff --git a/projects/entity-data-api/entity-data-api.cabal b/projects/entity-data-api/entity-data-api.cabal index 251b3182..91ab1108 100644 --- a/projects/entity-data-api/entity-data-api.cabal +++ b/projects/entity-data-api/entity-data-api.cabal @@ -63,6 +63,8 @@ library , Mirza.EntityDataAPI.AuthProxy , Mirza.EntityDataAPI.Utils , Mirza.EntityDataAPI.Main + , Mirza.EntityDataAPI.Database.Utils + , Mirza.EntityDataAPI.Errors -- Other library packages from which modules are imported. build-depends: base @@ -80,7 +82,9 @@ library , monad-time , optparse-applicative , jose + , postgresql-simple , req + , resource-pool , wai , warp , http-types @@ -94,13 +98,12 @@ library default-language: Haskell2010 -executable entity-data-api - default-extensions: OverloadedStrings - , FlexibleContexts - , FlexibleInstances +executable entity-data-api-proxy + default-extensions: OverloadedStrings + , FlexibleContexts + , FlexibleInstances -- .hs or .lhs file containing the Main module. main-is: EntityDataAPI.hs - -- Modules included in this executable, other than Main. -- other-modules: diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/AuthProxy.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/AuthProxy.hs index c6cfacdc..05e17878 100644 --- a/projects/entity-data-api/src/Mirza/EntityDataAPI/AuthProxy.hs +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/AuthProxy.hs @@ -1,31 +1,31 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Mirza.EntityDataAPI.AuthProxy where -import Network.HTTP.ReverseProxy (WaiProxyResponse (..), defaultOnExc, - waiProxyTo) +import Mirza.EntityDataAPI.Database.Utils (doesSubExist) + +import Network.HTTP.ReverseProxy (WaiProxyResponse (..), + defaultOnExc, waiProxyTo) import Network.HTTP.Types -import Network.Wai (Application, Request (..), - responseBuilder) +import Network.Wai (Application, Request (..), + responseBuilder) -import GHC.Exception (SomeException) +import GHC.Exception (SomeException) -import Control.Monad.Except (throwError) -import Control.Monad.Reader (asks) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (asks) -import Control.Lens (view) +import Control.Lens (view) +import Mirza.EntityDataAPI.Errors import Mirza.EntityDataAPI.Types import Mirza.EntityDataAPI.Utils -import qualified Crypto.JOSE as Jose -import qualified Crypto.JWT as JWT - - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import qualified Crypto.JWT as JWT -import Debug.Trace +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL handleRequest :: AuthContext -> Request -> IO WaiProxyResponse handleRequest ctx r = do @@ -43,8 +43,11 @@ handleToken (Just (_, authHdr)) = do (_mbearer, token) = BS.splitAt (BS.length bearer) authHdr (unverifiedJWT :: JWT.SignedJWT) <- JWT.decodeCompact $ BSL.fromStrict token claimSet <- JWT.verifyClaims (JWT.defaultJWTValidationSettings (== aud)) jwKey unverifiedJWT - traceM . show $ view JWT.claimSub claimSet - pure claimSet + case view JWT.claimSub claimSet of + Nothing -> throwError NoClaimSubject + Just sub -> doesSubExist sub >>= \case + False -> throwError UnauthClaimsSubject + True -> pure claimSet handleToken Nothing = throwError NoAuthHeader extractAuthHeader :: Request -> (Request, Maybe Header) diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/Database/Utils.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/Database/Utils.hs new file mode 100644 index 00000000..d6289828 --- /dev/null +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/Database/Utils.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Mirza.EntityDataAPI.Database.Utils where + +import Database.PostgreSQL.Simple as DB +import Database.PostgreSQL.Simple.FromField (FromField (..), + returnError) +import Database.PostgreSQL.Simple.ToField (ToField (..)) + +import Mirza.EntityDataAPI.Errors (AppError (..), + DBError (..)) +import Mirza.EntityDataAPI.Types + +import Crypto.JWT (StringOrURI) + +import qualified Control.Exception as E + +import Control.Monad.Except (throwError) +import Control.Monad.Reader (asks, liftIO) + +import Data.Pool (withResource) + +import Data.Aeson + +import qualified Data.Text as T + +doesSubExist :: StringOrURI -> AppM AuthContext AppError Bool +doesSubExist s = runDb $ \conn -> do + [Only cnt] <- query conn "SELECT COUNT(*) FROM users WHERE user_sub = ?" [s] :: IO [Only Integer] + case cnt of + 1 -> pure True + _ -> pure False + +runDb :: (Connection -> IO a) -> AppM AuthContext AppError a +runDb act = do + pool <- asks dbConnPool + res <- liftIO $ withResource pool $ \conn -> + E.try $ withTransaction conn $ act conn + case res of + Left (err :: SqlError) -> throwError . DatabaseError . SqlErr $ err + Right lol -> pure lol + + +instance ToField StringOrURI where + toField = toField . unpackStringOrURI + +instance FromField StringOrURI where + fromField f bs = fromField f bs >>= \case + Nothing -> returnError ConversionFailed f "Could not read value for StringOrURI" + Just val -> pure val + +unpackStringOrURI :: StringOrURI -> String +unpackStringOrURI sUri = + let (String str) = toJSON sUri + in T.unpack str + +addUserSub :: StringOrURI -> StringOrURI -> AppM AuthContext AppError () +addUserSub existingUser toAddUser = + doesSubExist existingUser >>= \case + False -> throwError . DatabaseError $ UnauthorisedInsertionAttempt existingUser + True -> addUser toAddUser + +addUser :: StringOrURI -> AppM AuthContext AppError () +addUser toAddUser = do + res <- runDb $ \conn -> DB.execute conn "INSERT INTO users (user_sub) values (?)" [toAddUser] + case res of + 1 -> pure () + _ -> throwError . DatabaseError $ InsertionFailed diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/Errors.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/Errors.hs new file mode 100644 index 00000000..087c8d85 --- /dev/null +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/Errors.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +module Mirza.EntityDataAPI.Errors where + +import Control.Lens (makeClassyPrisms, prism') + +import GHC.Generics (Generic) + +import Database.PostgreSQL.Simple (SqlError (..)) + +import Crypto.JWT (AsError, AsJWTError, + StringOrURI) +import qualified Crypto.JWT as Jose + +import Network.HTTP.Req (HttpException) + + +import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..)) + +data DBError + = SqlErr SqlError + | DBConstraintFailed ConstraintViolation + | InsertionFailed + | UnauthorisedInsertionAttempt StringOrURI + deriving (Eq, Show, Generic) + +data AppError + = JWKFetchFailed + | AuthFailed Jose.JWTError + | AppJoseError Jose.Error + | NoClaimSubject + | UnauthClaimsSubject + | NoAuthHeader + | UrlParseFailed + | ReqFailure HttpException + | JWKParseFailure String + | DatabaseError DBError + deriving (Show, Generic) +makeClassyPrisms ''AppError + +instance AsJWTError AppError where + _JWTError = prism' AuthFailed + (\case + (AuthFailed e) -> Just e + _ -> Nothing + ) +instance AsError AppError where + _Error = _AppJoseError + diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/Main.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/Main.hs index accfa431..c7dcf112 100644 --- a/projects/entity-data-api/src/Mirza/EntityDataAPI/Main.hs +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/Main.hs @@ -1,25 +1,33 @@ -{-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Mirza.EntityDataAPI.Main (main) where -import System.Envy (decodeEnv) +import System.Envy (decodeEnv) import Options.Applicative -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) -import Mirza.EntityDataAPI.AuthProxy (runAuthProxy) +import Mirza.EntityDataAPI.AuthProxy (runAuthProxy) +import Mirza.EntityDataAPI.Database.Utils (addUser, addUserSub) +import Mirza.EntityDataAPI.Errors import Mirza.EntityDataAPI.Types -import Mirza.EntityDataAPI.Utils (fetchJWKs) +import Mirza.EntityDataAPI.Utils (fetchJWKs) + +import Network.HTTP.ReverseProxy (ProxyDest (..)) +import qualified Network.Wai.Handler.Warp as Warp + +import qualified Data.ByteString.Char8 as B + +import Data.String (IsString (..)) -import Network.HTTP.ReverseProxy (ProxyDest (..)) -import qualified Network.Wai.Handler.Warp as Warp +import Crypto.JWT (StringOrURI) -import qualified Data.ByteString.Char8 as B +import Database.PostgreSQL.Simple (close, connectPostgreSQL) -import Data.String (IsString (..)) +import Data.Pool (createPool) main :: IO () -- main = launchProxy =<< execParser opts where @@ -31,35 +39,84 @@ main = (decodeEnv :: IO (Either String Opts)) >>= \case Left err -> fail $ "Failed to parse Opts: " <> err Right opts -> do print opts - launchProxy opts + multiplexInitOptions opts + +multiplexInitOptions :: Opts -> IO () +multiplexInitOptions opts = do + ctx <- initContext opts + putStrLn $ "Initialized context. Starting app on mode " <> (show . appMode $ opts) + case appMode opts of + Proxy -> launchProxy ctx + API -> launchUserManager ctx + Bootstrap -> do + res <- tryAddBootstrapUser ctx + print res + +promptLine :: String -> IO String +promptLine prompt = do + putStr prompt + getLine + + +tryAddUser :: AuthContext -> IO (Either AppError ()) +tryAddUser ctx = do + (authorisedUserStr :: String) <- promptLine "Enter thy creds: " + (toAddUserStr :: String) <- promptLine "User you want to add: " + let (authorisedUserSub :: StringOrURI) = fromString authorisedUserStr + let (toAddUserSub :: StringOrURI) = fromString toAddUserStr + res <- runAppM ctx $ addUserSub authorisedUserSub toAddUserSub + case res of + Right () -> putStrLn "Successfully added user" + Left err -> putStrLn $ "Failed with error : " <> show err + pure res + +tryAddBootstrapUser :: AuthContext -> IO (Either AppError ()) +tryAddBootstrapUser ctx = do + (toAddUserStr :: String) <- promptLine "User you want to add: " + let (toAddUserSub :: StringOrURI) = fromString toAddUserStr + res <- runAppM ctx $ addUser toAddUserSub + case res of + Right () -> putStrLn "Successfully added user" + Left err -> putStrLn $ "Failed with error : " <> show err + pure res + + +launchUserManager :: AuthContext -> IO () +launchUserManager ctx = do + _ <- tryAddUser ctx + launchUserManager ctx initContext :: Opts -> IO AuthContext -initContext (Opts myService (ServiceInfo (Hostname destHost) (Port destPort)) url clientId) = do +initContext (Opts myService (ServiceInfo (Hostname destHost) (Port destPort)) _mode url clientId dbConnStr) = do + putStrLn "Initializing context..." let proxyDest = ProxyDest (B.pack destHost) destPort mngr <- newManager tlsManagerSettings + connpool <- createPool (connectPostgreSQL dbConnStr) close + 1 -- Number of "sub-pools", + 60 -- How long in seconds to keep a connection open for reuse + 20 -- Max number of connections to have open at any one time fetchJWKs mngr url >>= \case Left err -> fail $ show err - Right jwkSet -> pure $ AuthContext myService proxyDest mngr jwkSet (fromString clientId) + Right jwkSet -> pure $ AuthContext myService proxyDest mngr jwkSet (fromString clientId) connpool -launchProxy :: Opts -> IO () -launchProxy opts = do - putStrLn "Initializing context..." - ctx <- initContext opts +launchProxy :: AuthContext -> IO () +launchProxy ctx = do putStrLn $ "Starting service on " <> (getHostname . serviceHost . myProxyServiceInfo $ ctx) <> ":" <> - (show . servicePort . myProxyServiceInfo $ ctx) + (show . getPort . servicePort . myProxyServiceInfo $ ctx) Warp.run (fromIntegral . getPort . servicePort . myProxyServiceInfo $ ctx) (runAuthProxy ctx) -_optsParser :: Parser Opts -_optsParser = Opts - <$> (ServiceInfo - <$> (Hostname <$> strOption (long "host" <> short 'h' <> value "localhost" <> showDefault <> help "The host to run this service on.")) - <*> (Port <$> option auto (long "port" <> short 'p' <> value 8000 <> showDefault <> help "The port to run this service on.")) - ) - <*> (ServiceInfo - <$> (Hostname <$> strOption (long "desthost" <> short 'd' <> value "localhost" <> showDefault <> help "The host to make requests to.")) - <*> (Port <$> option auto (long "destport" <> short 'r' <> value 8200 <> showDefault <> help "Port to make requests to."))) - <*> strOption (long "jwkurl" <> short 'j' <> value "https://mirza.au.auth0.com/.well-known/jwks.json" <> showDefault <> help "URL to fetch ") - <*> strOption (long "jwkclientid" <> short 'c' <> help "Audience Claim.") - +-- _optsParser :: Parser Opts +-- _optsParser = Opts +-- <$> (ServiceInfo +-- <$> (Hostname <$> strOption (long "host" <> short 'h' <> value "localhost" <> showDefault <> help "The host to run this service on.")) +-- <*> (Port <$> option auto (long "port" <> short 'p' <> value 8000 <> showDefault <> help "The port to run this service on.")) +-- ) +-- <*> (ServiceInfo +-- <$> (Hostname <$> strOption (long "desthost" <> short 'd' <> value "localhost" <> showDefault <> help "The host to make requests to.")) +-- <*> (Port <$> option auto (long "destport" <> short 'r' <> value 8200 <> showDefault <> help "Port to make requests to."))) +-- <*> (strOption (long "mode" <> short 'm' <> value Proxy <> showDefault <> help "Mode to run the app on. Available modes: Proxy | API")) +-- <*> strOption (long "jwkurl" <> short 'j' <> value "https://mirza.au.auth0.com/.well-known/jwks.json" <> showDefault <> help "URL to fetch ") +-- <*> strOption (long "jwkclientid" <> short 'k' <> help "Audience Claim.") +-- <*> strOption (long "conn" <> short 'c' <> help "Postgresql DB Connection String") diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/Types.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/Types.hs index 236bb717..0d41ac1d 100644 --- a/projects/entity-data-api/src/Mirza/EntityDataAPI/Types.hs +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/Types.hs @@ -1,38 +1,38 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TemplateHaskell #-} module Mirza.EntityDataAPI.Types where -import System.Envy (DefConfig (..), FromEnv (..), - Var (..), env, envMaybe, (.!=)) -import qualified System.Envy as Envy +import System.Envy (DefConfig (..), FromEnv (..), + Var (..), env, envMaybe, (.!=)) +import qualified System.Envy as Envy -import Network.HTTP.Req (HttpException) -import Network.HTTP.ReverseProxy (ProxyDest (..)) +import Network.HTTP.ReverseProxy (ProxyDest (..)) -import Control.Monad.Except (ExceptT (..), MonadError, - runExceptT) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, ReaderT, liftIO, - runReaderT) +import Control.Monad.Except (ExceptT (..), MonadError, + runExceptT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT, liftIO, + runReaderT) -import GHC.Generics (Generic) +import GHC.Generics (Generic) -import Network.HTTP.Client (Manager) +import Network.HTTP.Client (Manager) -import Control.Monad.Time (MonadTime (..)) -import Data.Time.Clock (getCurrentTime) +import Control.Monad.Time (MonadTime (..)) +import Data.Time.Clock (getCurrentTime) -import Text.Read (readMaybe) +import Text.Read (readMaybe) -import Crypto.JWT (AsError, AsJWTError, JWKSet, - StringOrURI) -import qualified Crypto.JWT as Jose +import Crypto.JWT (JWKSet, StringOrURI) + +import Data.Pool as Pool +import Database.PostgreSQL.Simple (Connection) + +import Data.ByteString (ByteString) -import Control.Lens (makeClassyPrisms, prism') -- ------------------- AppM ----------------------- -- runReaderT :: r -> m a @@ -66,6 +66,7 @@ data AuthContext = AuthContext , appManager :: Manager , jwtSigningKeys :: JWKSet , ctxJwkClientId :: StringOrURI + , dbConnPool :: Pool Connection } deriving (Generic) -- ------------------------------------------------ @@ -107,49 +108,41 @@ defaultJwkUrl = "https://mirza.au.auth0.com/.well-known/jwks.json" -- ----------------Opts---------------------------- + +data AppMode + = Proxy + | API -- placeholder + | Bootstrap + deriving (Show, Eq, Generic, Read) + +instance Var AppMode where + fromVar m = readMaybe m :: Maybe AppMode + toVar = show + data Opts = Opts { myServiceInfo :: ServiceInfo , destServiceInfo :: ServiceInfo + , appMode :: AppMode , jwkUrl :: String , jwkClientId :: String + , dbConnectionStr :: ByteString } deriving (Show, Generic, Eq) instance DefConfig Opts where defConfig = Opts { myServiceInfo = ServiceInfo{serviceHost=Hostname "localhost", servicePort=Port 8080 } , destServiceInfo = ServiceInfo{serviceHost=Hostname "localhost", servicePort=Port 8000 } + , appMode = Proxy , jwkUrl = defaultJwkUrl , jwkClientId = "" + , dbConnectionStr = "dbname=deventitydataapi" } instance FromEnv Opts where fromEnv = Opts <$> fromEnvMyServiceInfo <*> fromEnvDestServiceInfo + <*> envMaybe "EDAPI_MODE" .!= Proxy <*> envMaybe "JWK_URL" .!= defaultJwkUrl <*> env "JWK_CLIENT_ID" - --- ------------------------------------------------ - --- ---------------- Errors ------------------------ - - -data AppError - = JWKFetchFailed - | AuthFailed Jose.JWTError - | AppJoseError Jose.Error - | NoAuthHeader - | UrlParseFailed - | ReqFailure HttpException - | JWKParseFailure String - deriving (Show, Generic) -makeClassyPrisms ''AppError - -instance AsJWTError AppError where - _JWTError = prism' AuthFailed - (\err -> case err of - (AuthFailed e) -> Just e - _ -> Nothing - ) -instance AsError AppError where - _Error = _AppJoseError + <*> env "EDAPI_DB_CONN" diff --git a/projects/entity-data-api/src/Mirza/EntityDataAPI/Utils.hs b/projects/entity-data-api/src/Mirza/EntityDataAPI/Utils.hs index e0618bf4..349b90ae 100644 --- a/projects/entity-data-api/src/Mirza/EntityDataAPI/Utils.hs +++ b/projects/entity-data-api/src/Mirza/EntityDataAPI/Utils.hs @@ -2,7 +2,7 @@ module Mirza.EntityDataAPI.Utils where -import Mirza.EntityDataAPI.Types (AppError (..)) +import Mirza.EntityDataAPI.Errors (AppError (..)) import Network.HTTP.Client (Manager) import Network.HTTP.Req