diff --git a/projects/trails/src/Mirza/Trails/API.hs b/projects/trails/src/Mirza/Trails/API.hs new file mode 100644 index 00000000..8100a48c --- /dev/null +++ b/projects/trails/src/Mirza/Trails/API.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + + +module Mirza.Trails.API where + + +import Mirza.Common.Types (HealthResponse) + +import Servant +import Servant.Swagger.UI + + +type API + -- This serves both: swagger.json and swagger-ui + = SwaggerSchemaUI "swagger-ui" "swagger.json" + :<|> ServerAPI + + +api :: Proxy API +api = Proxy + + +type ServerAPI = PublicAPI + + +serverAPI :: Proxy ServerAPI +serverAPI = Proxy + + +type PublicAPI = + "healthz" :> Get '[JSON] HealthResponse + :<|> "version" :> Get '[JSON] String diff --git a/projects/trails/src/Mirza/Trails/Client/Servant.hs b/projects/trails/src/Mirza/Trails/Client/Servant.hs index 3652b504..24356058 100644 --- a/projects/trails/src/Mirza/Trails/Client/Servant.hs +++ b/projects/trails/src/Mirza/Trails/Client/Servant.hs @@ -1 +1,29 @@ -module Mirza.Trails.Client.Servant where +module Mirza.Trails.Client.Servant + ( + -- * Public API + health + , versionInfo + ) where + + +import Mirza.Trails.API + +import Mirza.Common.Types + +import Data.Proxy (Proxy (..)) +import Servant.API +import Servant.Client + + +health :: ClientM HealthResponse +versionInfo :: ClientM String + + +_api :: Client ClientM ServerAPI +_pubAPI :: Client ClientM PublicAPI +_api@( + _pubAPI@( + health + :<|> versionInfo + ) + ) = client (Proxy :: Proxy ServerAPI) diff --git a/projects/trails/src/Mirza/Trails/Handlers/Health.hs b/projects/trails/src/Mirza/Trails/Handlers/Health.hs new file mode 100644 index 00000000..9d0aac11 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Handlers/Health.hs @@ -0,0 +1,10 @@ +module Mirza.Trails.Handlers.Health where + + +import Mirza.Common.Types + + +-- | Currently the health check always returns success and is basically just a +-- confirmation that the process is still alive and hasn't died or blocked. +health :: AppM context err HealthResponse +health = pure HealthResponse diff --git a/projects/trails/src/Mirza/Trails/Main.hs b/projects/trails/src/Mirza/Trails/Main.hs index 73751d17..4e5b1af1 100644 --- a/projects/trails/src/Mirza/Trails/Main.hs +++ b/projects/trails/src/Mirza/Trails/Main.hs @@ -1,6 +1,228 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + + module Mirza.Trails.Main where + + +import Mirza.Trails.API +import Mirza.Trails.Service +import Mirza.Trails.Types + +import Mirza.Common.Types + +import Servant +import Servant.Swagger.UI + +import qualified Data.Pool as Pool +import Database.PostgreSQL.Simple + +import Network.Wai (Middleware) +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Cors as CorsMiddleware + +import Data.ByteString (ByteString) +import Data.Semigroup ((<>)) +import Data.Text (pack) +import Options.Applicative hiding (action) + +import Control.Exception (finally) +import Data.Maybe (fromMaybe) +import Katip as K +import System.IO (FilePath, IOMode (AppendMode), + hPutStr, openFile, stderr, stdout) + + +-------------------------------------------------------------------------------- +-- Constants +-------------------------------------------------------------------------------- + +-- | Port number changed so that OR and SCS can be run at the same time +defaultPortNumber :: Int +defaultPortNumber = 8300 + +defaultDatabaseConnectionString :: ByteString +defaultDatabaseConnectionString = "dbname=devtrails" + +corsOrigins :: [CorsMiddleware.Origin] +corsOrigins = [ + "http://localhost:8080" + , "https://demo.mirza.d61.io" + ] + +-------------------------------------------------------------------------------- +-- Command Line Options Data Types +-------------------------------------------------------------------------------- +data InitOptionsTrails = InitOptionsTrails + { iotGlobals :: ServerOptionsTrails + , iotExecMode :: ExecMode + } + +data ExecMode + = RunServer RunServerOptions + | InitDb + +data ServerOptionsTrails = ServerOptionsTrails + { mandatoryOptionsDbConnStr :: ByteString + , mandatoryOptionsLoggingLevel :: K.Severity + , mandatoryOptionsLogLocation :: Maybe FilePath + , mandatoryOptionsEnvType :: EnvType + } + +data RunServerOptions = RunServerOptions + { runServerOptionsPortNumber :: Int + } + + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + main :: IO () -main = putStrLn "Trails..." +main = multiplexInitOptions =<< execParser opts where + opts = Options.Applicative.info (serverOptions <**> helper) + (fullDesc + <> progDesc "Here to meet all your trail needs" + <> header "Trails Service") + + +-- Handles the overriding server options (this effectively defines the point +-- where the single binary could be split into multiple binaries. +multiplexInitOptions :: InitOptionsTrails -> IO () +multiplexInitOptions (InitOptionsTrails opts mode) = case mode of + RunServer rsOpts -> launchServer opts rsOpts + InitDb -> runMigration opts + + +-------------------------------------------------------------------------------- +-- Service +-------------------------------------------------------------------------------- + +launchServer :: ServerOptionsTrails -> RunServerOptions -> IO () +launchServer opts rso = do + let portNumber = runServerOptionsPortNumber rso + context <- initTrailsContext opts + app <- initApplication context + mids <- initMiddleware opts rso + putStrLn $ "http://localhost:" ++ show portNumber ++ "/swagger-ui/" + Warp.run (fromIntegral portNumber) (mids app) `finally` closeScribes (_trailsKatipLogEnv context) + +initTrailsContext :: ServerOptionsTrails -> IO TrailsContext +initTrailsContext (ServerOptionsTrails dbConnStr lev mlogPath envT) = do + logHandle <- maybe (pure stdout) (flip openFile AppendMode) mlogPath + hPutStr stderr $ "(Logging will be to: " ++ fromMaybe "stdout" mlogPath ++ ") " + handleScribe <- mkHandleScribe ColorIfTerminal logHandle lev V3 + logEnv <- initLogEnv "trailsService" (Environment . pack . show $ envT) + >>= registerScribe "stdout" handleScribe defaultScribeSettings + connpool <- Pool.createPool (connectPostgreSQL dbConnStr) close + 1 -- Number of "sub-pools", + 60 -- How long in seconds to keep a connection open for reuse + 10 -- Max number of connections to have open at any one time + -- TODO: Make this a config paramete + pure $ TrailsContext envT connpool logEnv mempty mempty + + +initApplication :: TrailsContext -> IO Application +initApplication ev = + pure $ serve api (server ev) + + +myCors :: Middleware +myCors = CorsMiddleware.cors (const $ Just policy) + where + policy = CorsMiddleware.simpleCorsResourcePolicy + { CorsMiddleware.corsRequestHeaders = ["Content-Type", "Authorization"] + , CorsMiddleware.corsMethods = "PUT" : CorsMiddleware.simpleMethods + , CorsMiddleware.corsOrigins = Just (corsOrigins, True) + } + +initMiddleware :: ServerOptionsTrails -> RunServerOptions -> IO Middleware +initMiddleware _ _ = pure myCors + +-- Implementation +server :: TrailsContext -> Server API +server context = + swaggerSchemaUIServer serveSwaggerAPI + :<|> hoistServer + (Proxy @ServerAPI) + (appMToHandler context) + (appHandlers) + + +-------------------------------------------------------------------------------- +-- Migration Command +-------------------------------------------------------------------------------- + +runMigration :: ServerOptionsTrails -> IO () +runMigration opts = do + _ctx <- initTrailsContext opts + --res <- runMigrationWithConfirmation @ORContextMinimal @SqlError ctx interactiveMigrationConfirm + --print res + pure () + +-------------------------------------------------------------------------------- +-- Command Line Options Argument Parsers +-------------------------------------------------------------------------------- + +standardCommand :: String -> Parser a -> String -> Mod CommandFields a +standardCommand name action desciption = + command name (info (action <**> helper) (progDesc desciption)) + + +-- The standard format of the main command line options is [Command] [Action], this applies to things like org and user. +serverOptions :: Parser InitOptionsTrails +serverOptions = InitOptionsTrails + <$> parsedServerOptions + <*> subparser + ( mconcat + [ standardCommand "server" runServer "Run HTTP server" + , standardCommand "initdb" initDb "Initialise the Database (Note: This command only works if the database \ + \is empty and can't be used for migrations or if the database already \ + \contains the schema." + ] + ) + + +runServer :: Parser ExecMode +runServer = RunServer <$> (RunServerOptions + <$> option auto + ( + long "port" + <> help "Port to run the service on." + <> showDefault + <> value defaultPortNumber + ) + ) + +parsedServerOptions :: Parser ServerOptionsTrails +parsedServerOptions = ServerOptionsTrails + <$> strOption + ( + long "conn" + <> short 'c' + <> help "Database connection string in libpq format. See: https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING" + <> showDefault + <> value defaultDatabaseConnectionString + ) + <*> option auto + ( long "log-level" + <> value InfoS + <> showDefault + <> help ("Logging level: " ++ show [minBound .. maxBound :: Severity]) + ) + <*> optional (strOption + ( long "log-path" + <> short 'l' + <> help "Path to write log output to (defaults to stdout)" + ) ) + <*> option auto + ( long "env" <> short 'e' + <> value Dev <> showDefault + <> help "Environment, Dev | Prod" + ) + -someFunc :: IO () -someFunc = putStrLn "someFunc" +-- TODO: Add flag to change from interactive confirmation to instead be automatic operation (so this command can be used from scripts or whatnot) (e.g. runIfSafe) . +initDb :: Parser ExecMode +initDb = pure InitDb diff --git a/projects/trails/src/Mirza/Trails/Service.hs b/projects/trails/src/Mirza/Trails/Service.hs new file mode 100644 index 00000000..84056703 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Service.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Mirza.Trails.Service where + + +import Mirza.Trails.API +import Mirza.Trails.Handlers.Health +import Mirza.Trails.Types + +import Mirza.Common.Types +import Mirza.Common.Utils + +import Katip + +import Servant +import Servant.Swagger + +import Control.Lens hiding ((.=)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans + +import Data.ByteString.Lazy.Char8 as BSL8 + +import Data.Swagger + + +-- Convenience class for contexts which require all possible error types that +-- could be thrown through the handlers. +class (AsORError err, AsSqlError err) + => APIPossibleErrors err where +instance (AsORError err, AsSqlError err) + => APIPossibleErrors err + + +appHandlers :: ( Member context '[HasDB] + , APIPossibleErrors err) + => ServerT ServerAPI (AppM context err) +appHandlers = publicServer + +publicServer :: ( Member context '[HasDB] + , APIPossibleErrors err) + => ServerT PublicAPI (AppM context err) +publicServer = + health + :<|> versionInfo + + + +appMToHandler :: (HasLogging context) => context -> AppM context ORError x -> Handler x +appMToHandler context act = do + res <- liftIO $ runAppM context act + case res of + Left err -> + runKatipContextT (context ^. katipLogEnv) () (context ^. katipNamespace) (orErrorToHttpError err) + Right a -> pure a + + +-- | Swagger spec for server API. +serveSwaggerAPI :: Swagger +serveSwaggerAPI = toSwagger serverAPI + & info.title .~ "Trails Registry Server API" + & info.version .~ "1.0" + & info.description ?~ "This is an API that tests swagger integration" + & info.license ?~ ("MIT" & url ?~ URL "https://opensource.org/licenses/MIT") + + +errorLogLevel :: ServantErr -> Severity +errorLogLevel httpStatus + | is5XXError(httpStatus) = ErrorS + | otherwise = WarningS + +-- | Is the servant error in the 5XX series? +is5XXError :: ServantErr -> Bool +is5XXError servantError = ((errHTTPCode servantError) `div` 100) == 5 + + +-- | This function simplifies the construction of errors by providing an +-- interface with just the arguments necessary. This function logs the error +-- and if the the status code is in the 5XX the log level is escalated. We log +-- all errors for now so that developers have the oppertunity to skim the logs +-- to look for potential issues. The error type contains all the information +-- that we know about the error at this point so we add it in entirity to the +-- log. +-- TODO: Transform Show error so that we can only log OR and ORKeyErrors to +-- further constrain the type and prevent accidental errors in the argument +-- provided, even though all we need is show. +throwHttpError :: (Show error) => error -> ServantErr -> ByteString -> KatipContextT Handler a +throwHttpError err httpStatus errorMessage = do + $(logTM) (errorLogLevel httpStatus) (logStr $ show err) + lift $ throwError $ httpStatus { errBody = errorMessage } + + +-- | Takes a ORError and converts it to an HTTP error. +orErrorToHttpError :: ORError -> KatipContextT Handler a +orErrorToHttpError orError = + let _httpError = throwHttpError orError + in case orError of + (DBErrorORE _) -> unexpectedError orError + (UnmatchedUniqueViolationORE _) -> unexpectedError orError + +-- | A generic internal server error has occured. We include no more information in the result returned to the user to +-- limit further potential for exploitation, under the expectation that we log the errors to somewhere that is reviewed +-- regularly so that the development team are informed and can identify and patch the underlying issues. +unexpectedError :: ORError -> KatipContextT Handler a +unexpectedError orError = throwHttpError orError err500 "An unknown error has occured." diff --git a/projects/trails/src/Mirza/Trails/Types.hs b/projects/trails/src/Mirza/Trails/Types.hs new file mode 100644 index 00000000..2b0913c6 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Types.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Mirza.Trails.Types where + + +import Mirza.Common.Types + +import Database.PostgreSQL.Simple (Connection, SqlError) + +import Katip as K + +import Control.Lens hiding ((.=)) + +import Data.Pool as Pool + + +-- ***************************************************************************** +-- Context Types +-- ***************************************************************************** + +data TrailsContext = TrailsContext + { _trailsEnvType :: EnvType + , _trailsDbConnPool :: Pool Connection + , _trailsKatipLogEnv :: K.LogEnv + , _trailsKatipLogContexts :: K.LogContexts + , _trailsKatipNamespace :: K.Namespace + } +$(makeLenses ''TrailsContext) + +instance HasEnvType (TrailsContext) where + envType = trailsEnvType +instance HasConnPool (TrailsContext) where + connPool = trailsDbConnPool +instance HasKatipLogEnv (TrailsContext) where + katipLogEnv = trailsKatipLogEnv +instance HasKatipContext (TrailsContext) where + katipContexts = trailsKatipLogContexts + katipNamespace = trailsKatipNamespace + + +-- ***************************************************************************** +-- Error Types +-- ***************************************************************************** + +data ORError + = DBErrorORE SqlError + | UnmatchedUniqueViolationORE SqlError + deriving (Show) +$(makeClassyPrisms ''ORError) + +instance AsSqlError ORError where _SqlError = _DBErrorORE diff --git a/projects/trails/stack.yaml b/projects/trails/stack.yaml index a692c96f..d1b87e0e 100644 --- a/projects/trails/stack.yaml +++ b/projects/trails/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-13.28 +resolver: lts-13.23 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/projects/trails/test/Mirza/Trails/Spec.hs b/projects/trails/test/Mirza/Trails/Spec.hs index 77f7ab13..9bd165b0 100644 --- a/projects/trails/test/Mirza/Trails/Spec.hs +++ b/projects/trails/test/Mirza/Trails/Spec.hs @@ -1,13 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + + module Main where + import Mirza.Trails.Tests.Client +import Mirza.Trails.Tests.Types + +import Mirza.Common.Tests.Utils import Test.Tasty hiding (withResource) import Test.Tasty.Runners (NumThreads (..)) -import Control.Exception (bracket) import Control.Monad.Except (liftIO, runExceptT) + main :: IO () main = do either (error . show) pure =<< (liftIO $ runExceptT $ makeDatabase testDbNameTrails) diff --git a/projects/trails/test/Mirza/Trails/Tests/Client.hs b/projects/trails/test/Mirza/Trails/Tests/Client.hs index 90da557c..1f33cc26 100644 --- a/projects/trails/test/Mirza/Trails/Tests/Client.hs +++ b/projects/trails/test/Mirza/Trails/Tests/Client.hs @@ -1,34 +1,33 @@ module Mirza.Trails.Tests.Client where -import Mirza.Trails.Client.Servant - import Mirza.Trails.Tests.InitClient +import Mirza.Trails.Client.Servant + import Mirza.Common.Tests.ServantUtils +import Mirza.Common.Types + import Test.Hspec.Expectations import Test.Tasty import Test.Tasty.HUnit import Control.Exception (bracket) +import Data.Either (isRight) --- === OR Servant Client tests +-- === Trails Servant Client tests clientSpec :: IO TestTree clientSpec = do - - - - let healthTests = testCaseSteps "Provides health status" $ \step -> - bracket runTrailsApp (\(a,b,_) -> endWaiApp (a,b)) $ \(_tid, baseurl) -> do + bracket runTrailsApp (\(a,b) -> endWaiApp (a,b)) $ \(_tid, baseurl) -> do let http = runClient baseurl step "Status results in 200" - -- healthResult <- http health - -- healthResult `shouldSatisfy` isRight - -- healthResult `shouldBe` (Right HealthResponse) + healthResult <- http health + healthResult `shouldSatisfy` isRight + healthResult `shouldBe` (Right HealthResponse) pure $ testGroup "Trails HTTP Client tests" diff --git a/projects/trails/test/Mirza/Trails/Tests/InitClient.hs b/projects/trails/test/Mirza/Trails/Tests/InitClient.hs new file mode 100644 index 00000000..1fa926bd --- /dev/null +++ b/projects/trails/test/Mirza/Trails/Tests/InitClient.hs @@ -0,0 +1,42 @@ +module Mirza.Trails.Tests.InitClient where + + +import Mirza.Trails.Tests.Types + +import Mirza.Trails.Main as TrailsMain + +import Mirza.Common.Tests.ServantUtils +import Mirza.Common.Tests.Utils (getDatabaseConnectionString) + +import Mirza.Common.Types + +import Katip (Severity (DebugS)) + +import Servant.Client (BaseUrl (..)) + +import System.IO.Temp (emptySystemTempFile) + +import Control.Concurrent (ThreadId) + + +trailsTestOptions :: Maybe FilePath -> ServerOptionsTrails +trailsTestOptions maybeFilepath = ServerOptionsTrails connectionString DebugS maybeFilepath Dev + where + connectionString = getDatabaseConnectionString testDbConnectionStringTrails + + +runTrailsApp :: IO (ThreadId, BaseUrl) +runTrailsApp = do + tempFile <- emptySystemTempFile "trailsServiceTests.log" + let currentTrailsOptions = trailsTestOptions (Just tempFile) + context <- initTrailsContext currentTrailsOptions + + -- let TrailsDB trailsTable = trailsDB + + -- flushDbResult <- runAppM @_ @TrailsError context $ runDb $ do + -- let deleteTable table = pg $ runDelete $ delete table (const (val_ True)) + -- deleteTable trailsTable + -- flushDbResult `shouldSatisfy` isRight + + (tid,orul) <- startWaiApp =<< TrailsMain.initApplication context + pure (tid, orul) diff --git a/projects/trails/test/Mirza/Trails/Tests/Types.hs b/projects/trails/test/Mirza/Trails/Tests/Types.hs new file mode 100644 index 00000000..b05f9bd3 --- /dev/null +++ b/projects/trails/test/Mirza/Trails/Tests/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Mirza.Trails.Tests.Types where + + +import Mirza.Common.Tests.Utils + + +-------------------------------------------------------------------------------- +-- Constants +-------------------------------------------------------------------------------- + +-- | Default database name when running tests for the Trials Service. Be careful +-- using this construct as it could lead to problems...users not specifying the +-- database and accidentally operating on the wrong database. +testDbNameTrails :: DatabaseName +testDbNameTrails = DatabaseName "testtrails" + + +-- | Default database connection string used when running tests for the Trails +-- Service. Be careful using this construct as it could lead to problems...users +-- not specifying the database and accidentally operating on the wrong database. +testDbConnectionStringTrails :: DatabaseConnectionString +testDbConnectionStringTrails = databaseNameToConnectionString testDbNameTrails diff --git a/projects/trails/trails.cabal b/projects/trails/trails.cabal index 0609f9a7..ac89fb96 100644 --- a/projects/trails/trails.cabal +++ b/projects/trails/trails.cabal @@ -26,15 +26,41 @@ source-repository head library exposed-modules: - Mirza.Trails.Main + Mirza.Trails.API Mirza.Trails.Client.Servant + Mirza.Trails.Handlers.Health + Mirza.Trails.Main + Mirza.Trails.Service + Mirza.Trails.Types other-modules: Paths_trails hs-source-dirs: src build-depends: base >=4.7 && <5 + , mirza-common-haskell , mirza-test-utils-haskell + , servant + , servant-client + , aeson + , attoparsec + , bytestring + , insert-ordered-containers + , katip + , lens + , mtl + , network-uri + , optparse-applicative + , postgresql-simple + , resource-pool + , servant-server + , servant-swagger + , servant-swagger-ui + , swagger2 + , text + , wai + , wai-cors + , warp default-language: Haskell2010 executable trails @@ -56,6 +82,7 @@ test-suite trails-test Paths_trails , Mirza.Trails.Tests.Client , Mirza.Trails.Tests.InitClient + , Mirza.Trails.Tests.Types hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror @@ -65,9 +92,12 @@ test-suite trails-test , mirza-common-haskell , mirza-test-utils-haskell , hspec-expectations + , katip , mtl + , servant-client , tasty , tasty-hunit + , temporary default-language: Haskell2010 source-repository head