mateamt/app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Main where

import Prelude as P

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

import Data.Set as S (empty)
import Data.ByteString.Char8 as B8 hiding (putStrLn)
import qualified Data.Text as T
import Data.String
import Data.Yaml
import Data.Version (showVersion)
import Data.IP
import qualified Data.OpenApi as OA hiding (Server)

import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util

import Network.Socket (defaultPort)

import Network.Wai
import Network.Wai.Logger
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Throttle

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
        ) -> 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
                  }
                expirationSpec = TimeSpec 5 0 -- five seconds
                throt = (defaultThrottleSettings expirationSpec)
                  { throttleSettingsRate   = 10
                  , throttleSettingsPeriod = 1000
                  }
            th <- initCustomThrottler throt
              (\req ->
                let headers = requestHeaders req
                in  case lookup "x-forwarded-for" headers of
                      Just addrs ->
                        let xaddr = fst (B8.break (== ',') addrs)
                        in  Right $ Address $ toSockAddr (read (B8.unpack xaddr), defaultPort)
                      Nothing -> Right $ Address $ remoteHost req
                )
            runSettings settings (throttle th (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 (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 =
  authGet :<|>
  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
  :: Connection
  -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext

type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)

authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler conn = mkAuthHandler handler
  where
    handler :: Request -> Handler (Maybe (Int, AuthMethod))
    handler req = do
      let headers = requestHeaders req
      case lookup "Authentication" headers of
        Just hh ->
          validateToken hh 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))