{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} module Main where import Prelude as P import Crypto.JWT hiding (Context, header) import Control.Concurrent.STM (newTQueueIO) import Control.Concurrent (forkIO) import Servant import Servant.Server.Experimental.Auth import qualified Servant.OpenApi as OA import Servant.Swagger.UI import Servant.RawM.Server import Data.Set as S (empty) import qualified Data.ByteString.Lazy as B import Data.ByteString.Char8 as B8 hiding (putStrLn) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.String import Data.Yaml import Data.Version (showVersion) import qualified Data.OpenApi as OA hiding (Server) import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Migration import Database.PostgreSQL.Simple.Util import Network.Wai import Network.Wai.Logger import Network.Wai.Handler.Warp import Control.Monad.Reader import Control.Concurrent.STM.TVar import Control.Lens hiding (Context) import Options.Applicative import System.Clock (TimeSpec(..)) import System.Exit -- internal imports import API import Util (initDB, engageCourier) import Model as M import AppTypes import Types import Control import Janitor import Paths_mateamt (version) main :: IO () main = do (Options confLoc tMigLoc) <- execParser opts raw <- B8.readFile (T.unpack confLoc) case decodeEither' raw of Left msg -> error (T.unpack $ confLoc <> ":" <> " error: " <> fromString (prettyPrintParseException msg) ) Right (ServerConfig db_host db_port db_name db_user db_passwd sym currency_fraction lport lhost -- max_conn_per_client -- block_registration sendmail_path jwt_secret ) -> do conn <- connectPostgreSQL ( "host='" <> fromString (T.unpack db_host) <> "' " <> "port=" <> fromString (show db_port) <> " " <> "dbname='" <> fromString (T.unpack db_name) <> "' " <> "user='" <> fromString (T.unpack db_user) <> "' " <> "password='" <> fromString (T.unpack db_passwd) <> "'" ) store <- newTVarIO S.empty -- tracker <- newTVarIO M.empty migrationsExist <- existsTable conn "schema_migrations" unless migrationsExist $ do withTransaction conn $ void $ do void $ runMigration $ MigrationContext MigrationInitialization True conn initDB conn -- validate Migrations let migLoc = T.unpack tMigLoc ok <- withTransaction conn $ runMigration $ MigrationContext (MigrationValidation (MigrationDirectory migLoc)) True conn case ok of MigrationError err -> do putStrLn ("Migration validation error: " ++ err) putStrLn "Running Migrations!" void $ withTransaction conn $ runMigration $ MigrationContext (MigrationDirectory migLoc) True conn MigrationSuccess -> return () ok2 <- withTransaction conn $ runMigration $ MigrationContext (MigrationValidation (MigrationDirectory migLoc)) True conn case ok2 of MigrationError err -> do putStrLn ("Migration validation error: " ++ err) putStrLn "MIgration failure! exiting..." exitWith (ExitFailure 3) MigrationSuccess -> do putStrLn "Migration validation success!" putStrLn "starting up..." forkCleanProcess conn store mailQueue <- newTQueueIO void $ forkIO $ engageCourier mailQueue sendmail_path withStdoutLogger $ \ilog -> do let settings = setPort (fromIntegral lport) $ setHost (fromString $ T.unpack lhost) $ -- setOnOpen (addToTracker tracker max_conn_per_client) $ -- setOnClose (removeFromTracker tracker) $ setLogger ilog defaultSettings initState = ReadState { rsConnection = conn , rsTicketStore = store , rsCurrencySymbol = sym , rsCurrencyFraction = currency_fraction , rsSoftwareVersion = T.pack (showVersion version) , rsSendmailPath = sendmail_path , rsMailQueue = mailQueue , rsJWTSecret = fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret } expirationSpec = TimeSpec 5 0 -- five seconds runSettings settings (app initState) where opts = info (options <**> helper) ( fullDesc <> progDesc "Run the \"mateamt\" API-Server." <> header "mateamt - Your friendly mate distribution office" ) app :: ReadState -> Application -- app conn = serveWithContext userApi genAuthServerContext (users conn) app initState = serveWithContext combinedAPI (genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server where server :: Server CombinedAPI server = appToServer initState mateAPI thisApi :<|> swaggerSchemaUIServer mateSwagger appToServer initState myApi = hoistServerWithContext myApi authProxy (`runReaderT` initState) thisApi :: ServerT MateAPI MateHandler thisApi = authSend :<|> authLogout :<|> authManageList :<|> authManageNewAuth :<|> authManageDeleteAuth :<|> userNew :<|> userGet :<|> userUpdate :<|> userList :<|> userRecharge :<|> userTransfer :<|> productNew :<|> productOverview :<|> productStockRefill :<|> productStockUpdate :<|> productList :<|> productShortList :<|> buy :<|> journalShow :<|> journalCheck :<|> avatarGet :<|> avatarInsert :<|> avatarUpdate :<|> avatarList :<|> roleList :<|> roleNew :<|> roleUpdate :<|> roleDelete :<|> roleAssociationList :<|> roleAssociationSubmit :<|> roleAssociationDelete :<|> getSettings :<|> Control.updateSettings :<|> metaGet mateSwagger :: OA.OpenApi mateSwagger = OA.toOpenApi mateAPI & OA.info.OA.title .~ "Mateamt API" & OA.info.OA.version .~ "1.0" & OA.info.OA.description ?~ "AN API to buy Mate and other products from your local Hackerspace or event." & OA.info.OA.license ?~ ("AGPL" & OA.url ?~ OA.URL "https://www.gnu.org/licenses/agpl-3.0-standalone.html") mateAPI :: Proxy MateAPI mateAPI = Proxy combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy type CombinedAPI = MateAPI :<|> SwaggerSchemaUI "swagger-ui" "swagger.json" authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ] authProxy = Proxy genAuthServerContext :: JWK -> Connection -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ] genAuthServerContext key conn = authHandler key conn Servant.:. EmptyContext type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod) authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod)) authHandler key conn = mkAuthHandler handler where handler :: Request -> Handler (Maybe (Int, AuthMethod)) handler req = do let headers = requestHeaders req case lookup "Authorization" headers of Just hh -> do validateToken (B8.drop 7 hh) key conn _ -> return Nothing instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) where toOpenApi _ = OA.toOpenApi (Proxy :: Proxy sub) instance OA.HasOpenApi (RawM' Application) where toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent)) instance OA.HasOpenApi (JWS Identity () JWSHeader) where toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))