diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +0.1.1.0 +======= + +* Port to `lts-8.19` + +0.1.0.0 +======= + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anton Gushcha nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# pdf-slave-server + +Web server for `pdf-slave` that renders posted templates. + +# Building + +``` +stack setup +stack build +``` + +# Debug deploy + +``` +pdf-slave-server --conf config.yaml +``` +Note: default login/password is `admin/123456` + +# Production deploy + +The repo has scripts to cook deb packages for Ubuntu 16. Simply run `makedeb.sh`, you need [fpm](https://github.com/jordansissel/fpm) installed. The simple way to install it is: + +``` bash +dnf install ruby-devel gcc make rpm-build libffi-devel # Fedora (yep, i'm biased) +# apt-get install ruby ruby-dev rubygems build-essential # Ubuntu +gem install --no-ri --no-rdoc fpm +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Data.Monoid +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import Options.Applicative + +import Text.PDF.Slave.Server + +-- | Argument line options +data Options = Options { + -- | Path to config, if not set, the app will not start + configPath :: FilePath +} + +-- | Command line parser +optionsParser :: Parser Options +optionsParser = Options + <$> strOption ( + long "conf" + <> metavar "CONFIG" + <> help "Path to configuration file" + ) + +-- | Execute server with given options +runServer :: Options -> IO () +runServer Options{..} = do + cfg <- readConfig configPath + env <- newServerEnv cfg + let logger = makeLogger $ serverDetailedLogging cfg + run (serverPort cfg) $ logger $ pdfSlaveServerApp env + where + makeLogger b = if b + then logStdoutDev + else logStdout + +main :: IO () +main = execParser opts >>= runServer + where + opts = info (helper <*> optionsParser) + ( fullDesc + <> progDesc "Web server for pdf-slave tool" + <> header "pdf-slave-server - provides web service for pdf-slave tool" ) diff --git a/pdf-slave-server.cabal b/pdf-slave-server.cabal new file mode 100644 --- /dev/null +++ b/pdf-slave-server.cabal @@ -0,0 +1,113 @@ +name: pdf-slave-server +version: 0.1.1.0 +synopsis: Web service for pdf-slave tool +description: Please see README.md +homepage: https://github.com/NCrashed/pdf-slave-server#readme +license: BSD3 +license-file: LICENSE +author: Anton Gushcha +maintainer: ncrashed@gmail.com +copyright: 2016 Anton Gushcha +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + README.md + CHANGELOG.md + stack.yaml + +library + hs-source-dirs: src + exposed-modules: + Text.PDF.Slave.Server + Text.PDF.Slave.Server.Config + Text.PDF.Slave.Server.DB + Text.PDF.Slave.Server.DB.Model + Text.PDF.Slave.Server.Monad + Text.PDF.Slave.Server.Notification + Text.PDF.Slave.Server.Util + default-language: Haskell2010 + build-depends: + base >= 4.7 && < 5 + , acid-state >= 0.14 && < 0.15 + , aeson >= 0.11 && < 1.3 + , aeson-injector >= 1.0 && < 1.1 + , base16-bytestring >= 0.1 && < 0.2 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , cryptonite >= 0.21 && < 0.22 + , hashable >= 1.2 && < 1.3 + , http-client >= 0.4 && < 0.6 + , http-client-tls >= 0.2 && < 0.4 + , immortal >= 0.2 && < 0.3 + , lens >= 4.14 && < 4.16 + , memory >= 0.13 && < 0.15 + , monad-control >= 1.0 && < 1.1 + , monad-logger >= 0.3 && < 0.4 + , mtl >= 2.2 && < 2.3 + , pdf-slave >= 1.3 && < 1.4 + , pdf-slave-server-api + , safecopy >= 0.9 && < 0.10 + , scientific >= 0.3 && < 0.4 + , servant >= 0.11 && < 0.12 + , servant-auth-token >= 0.4 && < 0.5 + , servant-auth-token-acid >= 0.4 && < 0.5 + , servant-auth-token-api >= 0.4 && < 0.5 + , servant-server >= 0.11 && < 0.12 + , shelly >= 1.6 && < 1.7 + , stm >= 2.4 && < 2.5 + , text >= 1.2 && < 1.3 + , time >= 1.6 && < 1.7 + , transformers-base >= 0.4 && < 0.5 + , unbounded-delays >= 0.1 && < 0.2 + , unordered-containers >= 0.2 && < 0.3 + , uuid >= 1.3 && < 1.4 + , wreq >= 0.4 && < 0.6 + , yaml >= 0.8 && < 0.9 + default-extensions: + BangPatterns + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + UndecidableInstances + +executable pdf-slave-server + hs-source-dirs: app + main-is: Main.hs + default-language: Haskell2010 + build-depends: + base >= 4.7 && < 5 + , optparse-applicative >= 0.12 && < 0.14 + , pdf-slave-server + , wai-extra >= 3.0 && < 3.1 + , warp >= 3.2 && < 3.3 + default-extensions: + BangPatterns + DeriveGeneric + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies diff --git a/src/Text/PDF/Slave/Server.hs b/src/Text/PDF/Slave/Server.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server.hs @@ -0,0 +1,71 @@ +module Text.PDF.Slave.Server( + -- * Server config + ServerConfig(..) + , readConfig + -- * Server environment + , ServerEnv + , newServerEnv + -- * Execution of server + , pdfSlaveServerApp + ) where + +import Control.Monad +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import Data.Aeson.WithField +import Data.Maybe +import Data.Proxy +import Servant.API +import Servant.API.Auth.Token +import Servant.Server +import Servant.Server.Auth.Token + +import qualified Data.UUID.V4 as UUID + +import Text.PDF.Slave.Server.API +import Text.PDF.Slave.Server.Config +import Text.PDF.Slave.Server.DB +import Text.PDF.Slave.Server.Monad + +-- | Full Server API +type ServerAPI = PDFSlaveAPI :<|> AuthAPI + +-- | WAI application of server +pdfSlaveServerApp :: ServerEnv -> Application +pdfSlaveServerApp e = serve (Proxy :: Proxy ServerAPI) $ enter (serverMtoHandler e) $ + pdfSlaveServer + :<|> enter authToServerM (authServer :: ServerT AuthAPI AuthM) + +-- | Implementation of main server API +pdfSlaveServer :: ServerT PDFSlaveAPI ServerM +pdfSlaveServer = renderTemplateEndpoint + +-- | Implementation of 'RenderTemplateEndpoint' +renderTemplateEndpoint :: APIRenderBody + -> MToken' '["render"] + -> ServerM (OnlyId APIRenderId) +renderTemplateEndpoint APIRenderBody{..} token = do + runAuth $ guardAuthToken token + ServerConfig{..} <- getConfig + n <- runQuery GetRenderQueueSize + whenJust serverMaximumQueue $ \n' -> unless (n < n') $ + throwError $ err507 { errBody = "Rendering queue is full"} + i <- maybe (liftIO UUID.nextRandom) (return . fromAPIRenderId) apiRenderBodyId + runUpdate . AddRenderItem $ RenderItem { + renderId = RenderId i + , renderTemplate = apiRenderBodyTemplate + , renderInput = apiRenderBodyInput + , renderUrl = apiRenderBodyUrl + , renderToken = unToken $ fromJust token -- already guarded Nothing + } + emitRenderItem -- awake workers + return $ OnlyField . toAPIRenderId $ i + +-- | Definition of 507 HTTP error `Insufficient Storage` +err507 :: ServantErr +err507 = ServantErr { + errHTTPCode = 507 + , errReasonPhrase = "Insufficient Storage" + , errBody = "" + , errHeaders = [] + } diff --git a/src/Text/PDF/Slave/Server/Config.hs b/src/Text/PDF/Slave/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/Config.hs @@ -0,0 +1,96 @@ +-- | Configuration file of server +module Text.PDF.Slave.Server.Config( + ServerConfig(..) + , DatabaseConfig(..) + , readConfig + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Text +import Data.Time +import Data.Yaml +import Data.Yaml.Config +import GHC.Generics +import Servant.Server.Auth.Token.Config + +-- | Configuration for database connection +data DatabaseConfig = DatabaseConfig { + -- | Path to acid-state storage folder + databasePath :: !Text + -- | How often to make a checkpoint +, databaseCheckpointTime :: !(Maybe NominalDiffTime) + -- | How often to make a archive +, databaseArchiveTime :: !(Maybe NominalDiffTime) +} deriving (Generic, Show) + +-- | Helper to parse nominal diff time with default value +parseNominalDiff :: Object -> Text -> Parser (Maybe NominalDiffTime) +parseNominalDiff o label = do + t :: Maybe Double <- o .:? label + return $ fmap realToFrac t + +instance FromJSON DatabaseConfig where + parseJSON (Object o) = do + databasePath <- o .: "path" + databaseCheckpointTime <- parseNominalDiff o "checkpoint-time" + databaseArchiveTime <- parseNominalDiff o "archive-time" + return DatabaseConfig{..} + parseJSON _ = mzero + +-- | Startup configuration of server +data ServerConfig = ServerConfig { + -- | Server host name + serverHost :: !Text + -- | Server port number +, serverPort :: !Int + -- | If set, HTTP log would be more readable +, serverDetailedLogging :: !Bool + -- | Database connection options +, serverDatabaseConf :: !DatabaseConfig + -- | Maximum allowed queue of templates to render +, serverMaximumQueue :: !(Maybe Int) + -- | Number of rendering workers +, serverRenderWorkers :: !Int + -- | Number of notification workers +, serverNotificationWorkers :: !Int + -- | Delays between notification tries +, serverNotificationDelay :: !NominalDiffTime + -- | Maximum number of failed notification delivers +, serverMaxNotificationTries :: !(Maybe Int) + -- | Fixed password for admin account +, serverAdminPassword :: !Text + -- | Server authorisation config +, serverAuthConfig :: !AuthConfig +} deriving (Generic) + +-- | Prepare 'AuthConfig' from JSON object +parseAuthConfig :: Value -> Parser AuthConfig +parseAuthConfig (Object o) = do + tokenExpire <- o .: "token-expire" + strength <- o .: "password-strength" + maxExpire <- o .: "maximum-expire" + return defaultAuthConfig { + defaultExpire = tokenExpire + , passwordsStrength = strength + , maximumExpire = maxExpire + } +parseAuthConfig _ = mzero + +instance FromJSON ServerConfig where + parseJSON v@(Object o) = ServerConfig + <$> o .: "host" + <*> o .: "port" + <*> o .: "detailed-logging" + <*> o .: "database" + <*> o .:? "max-queue-size" + <*> o .: "render-workers" + <*> o .: "notification-workers" + <*> o .: "notification-delay" + <*> o .:? "notification-tries" + <*> o .: "admin-password" + <*> parseAuthConfig v + parseJSON _ = mzero + +readConfig :: MonadIO m => FilePath -> m ServerConfig +readConfig f = liftIO $ loadYamlSettings [f] [] useEnv diff --git a/src/Text/PDF/Slave/Server/DB.hs b/src/Text/PDF/Slave/Server/DB.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/DB.hs @@ -0,0 +1,89 @@ +module Text.PDF.Slave.Server.DB( + Model + , AcidState + , createDB + -- * Execution DB queries + , HasAcidState(..) + , runQuery + , runUpdate + -- * Persistent entities + , RenderId(..) + , RenderItem(..) + , Notification(..) + -- * Queries + -- ** Render queue + , AddRenderItem(..) + , GetRenderQueueSize(..) + , CheckNextRenderItem(..) + , FetchRenderItem(..) + -- ** Notification queue + , AddNotification(..) + , GetNotificationQueueSize(..) + , CheckNextNotification(..) + , FetchNotification(..) + , GetNotificationNextTime(..) + ) where + +import Control.Concurrent.Thread.Delay +import Control.Monad (void, forever) +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.Acid +import Data.Text (unpack) +import Data.Time + +import Text.PDF.Slave.Server.Config +import Text.PDF.Slave.Server.DB.Model +import Text.PDF.Slave.Server.Util + +import qualified Control.Immortal as Immortal + +-- | Create connection pool for DB +createDB :: (MonadIO m, MonadBaseControl IO m) + => DatabaseConfig -- ^ Connection configuration + -> m (AcidState Model) +createDB DatabaseConfig{..} = do + db <- liftIO $ openLocalStateFrom (unpack databasePath) initialModel + whenJust databaseCheckpointTime $ \dt -> checkpointWorker dt db + whenJust databaseArchiveTime $ \dt -> archiveWorker dt db + return db + +-- | Describes monads that has internal acid-state storage +class HasAcidState a m | m -> a where + getAcidState :: m (AcidState a) + +-- | Run acid-state query in monad with internal acid storage +runQuery :: (MonadIO m, HasAcidState (EventState event) m, QueryEvent event) + => event -- ^ Event constructed from query with 'makeAcidic' + -> m (EventResult event) +runQuery e = do + db <- getAcidState + liftIO $ query db e + +-- | Run acid-state update query in monad with internal acid storage +runUpdate :: (MonadIO m, HasAcidState (EventState event) m, UpdateEvent event) + => event -- ^ Event constructed from query with 'makeAcidic' + -> m (EventResult event) +runUpdate e = do + db <- getAcidState + liftIO $ update db e + +-- | Worker thread that creates DB checkpoints in given interval +checkpointWorker :: (MonadIO m, MonadBaseControl IO m) + => NominalDiffTime -- ^ Time interval of creation of checkpoints + -> AcidState Model -- ^ DB to make checkpoint from + -> m () +checkpointWorker dt db = liftIO . void . Immortal.createWithLabel "checkpointWorker" $ + const $ forever $ do + delay . toMicroseconds $ dt + createCheckpoint db + +-- | Worker thread that creates archives from DB in given interval +archiveWorker :: (MonadIO m, MonadBaseControl IO m) + => NominalDiffTime -- ^ Time interval of creation of checkpoints + -> AcidState Model -- ^ DB to make checkpoint from + -> m () +archiveWorker dt db = liftIO . void . Immortal.createWithLabel "archiveWorker" $ + const $ forever $ do + delay . toMicroseconds $ dt + createArchive db diff --git a/src/Text/PDF/Slave/Server/DB/Model.hs b/src/Text/PDF/Slave/Server/DB/Model.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/DB/Model.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module Text.PDF.Slave.Server.DB.Model where + +import Control.Lens +import Data.Acid +import Data.Aeson (Value) +import Data.Hashable +import Data.Ord +import Data.SafeCopy +import Data.Scientific +import Data.Sequence +import Data.Text +import Data.Time +import Data.UUID +import GHC.Generics +import Servant.API.Auth.Token +import Text.PDF.Slave + +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S +import qualified Servant.Server.Auth.Token.Acid.Schema as A + +-- | Wrapper around UUID +newtype RenderId = RenderId { unRenderId :: UUID } + deriving (Generic, Show, Eq) + +deriveSafeCopy 0 'base ''UUID +deriveSafeCopy 0 'base ''RenderId + +-- | Element of rendering queue +data RenderItem = RenderItem { + renderId :: RenderId + -- | Template to render +, renderTemplate :: Template + -- | Optional input data +, renderInput :: Maybe Value + -- | Notification URL for positing results +, renderUrl :: Text + -- | Saved token that is used to create the render +, renderToken :: SimpleToken +} deriving (Generic) + +deriveSafeCopy 0 'base ''RenderItem +deriveSafeCopy 0 'base ''Template +deriveSafeCopy 0 'base ''TemplateDependency + +-- | Notification about finished rendering +data Notification = Notification { + -- | Corresponding rendering task id + notifRenderId :: RenderId + -- | URL to send notification to +, notifTarget :: Text + -- | Content of document or rendering error +, notifDocument :: Either Text PDFContent + -- | Number of tries to send the document +, notifTries :: Int + -- | If last notification sending failed the field stores error message +, notifLastError :: Maybe Text + -- | After the time the notification should be tried to be delivered +, notifNextTry :: UTCTime + -- | Saved token that is used to sign notification +, notifToken :: SimpleToken +} deriving (Generic, Show) + +deriveSafeCopy 0 'base ''Notification + +-- | DB persistent model +data Model = Model { + -- | Rendering queue + _modelRenderQueue :: Seq RenderItem + -- | Notification queue +, _modelNotificationQueue :: Seq Notification + -- | Authentification state +, _modelAuth :: A.Model +} + +makeLenses ''Model +deriveSafeCopy 0 'base ''Model + +-- | Initialisation value of empty DB +initialModel :: Model +initialModel = Model { + _modelRenderQueue = mempty + , _modelNotificationQueue = mempty + , _modelAuth = A.newModel + } + +-- | Register new item in queue +addQueueItem :: Setter' Model (Seq a) -> a -> Update Model () +addQueueItem queueField i = queueField %= (\q -> q S.|> i) + +-- | Check if queue is not empty +checkNextQueueItem :: Getter Model (Seq a) -> Query Model Bool +checkNextQueueItem queueField = do + q <- view queueField + return $ case S.viewl q of + EmptyL -> False + _ -> True + +-- | Get current size of queue +getQueueSize :: Getter Model (Seq a) -> Query Model Int +getQueueSize queueField = S.length <$> view queueField + +-- | Get next item from rendering queue +fetchQueueItem :: Lens' Model (Seq a) -> Update Model (Maybe a) +fetchQueueItem queueField = do + q <- use queueField + let (mi, qleft) = case S.viewl q of + EmptyL -> (Nothing, S.empty) + i S.:< is -> (Just i, is) + queueField .= qleft + return mi + +-- | Register new render item in queue +addRenderItem :: RenderItem -> Update Model () +addRenderItem = addQueueItem modelRenderQueue + +-- | Check if queue is not empty +checkNextRenderItem :: Query Model Bool +checkNextRenderItem = checkNextQueueItem modelRenderQueue + +-- | Get current size of render queue +getRenderQueueSize :: Query Model Int +getRenderQueueSize = getQueueSize modelRenderQueue + +-- | Get next item from rendering queue +fetchRenderItem :: Update Model (Maybe RenderItem) +fetchRenderItem = fetchQueueItem modelRenderQueue + +-- | Register new notification item in queue +addNotification :: Notification -> Update Model () +addNotification = addQueueItem modelNotificationQueue + +-- | Check if notification queue is not empty +checkNextNotification :: UTCTime -- ^ Fetch only those whom 'notifNextTry' is less than the value + -> Query Model Bool +checkNextNotification t = do + q <- view modelNotificationQueue + return $ case S.viewl . S.filter ((t >=) . notifNextTry) $ q of + EmptyL -> False + _ -> True + +-- | Get current size of notification queue +getNotificationQueueSize :: Query Model Int +getNotificationQueueSize = getQueueSize modelNotificationQueue + +-- | Get next item from notification queue with minimum expected deliver time +fetchNotification :: UTCTime -- ^ Fetch only those whom 'notifNextTry' is less than the value + -> Update Model (Maybe Notification) +fetchNotification t = do + q <- use modelNotificationQueue + -- first, remove notifications whose time have not come yet and sort in ascending order + let q' = S.sortBy (comparing notifNextTry) . S.filter ((t >=) . notifNextTry) $ q + (mi, qleft) = case S.viewl q' of + EmptyL -> (Nothing, S.empty) + i S.:< is -> (Just i, is) + modelNotificationQueue .= qleft + return mi + +-- | Get time when next notification should be sended to client +getNotificationNextTime :: Query Model (Maybe UTCTime) +getNotificationNextTime = do + q <- view modelNotificationQueue + return $ case S.viewl . S.sort . fmap notifNextTry $ q of + EmptyL -> Nothing + t S.:< _ -> Just t + +-- ACID for authentification + +-- | Extraction of Auth model from global state +instance A.HasModelRead Model where + askModel = _modelAuth + +-- | Extraction of Auth model from global state +instance A.HasModelWrite Model where + putModel db m = db { _modelAuth = m } + +-- Mixin auth state queries and derive acid-state instances for them +A.deriveQueries ''Model + +-- | ACID for aeson + +deriveSafeCopy 0 'base ''Value +deriveSafeCopy 0 'base ''Scientific + +-- | An instance of SafeCopy for the Object Value. +instance (SafeCopy a, Eq a, Hashable a, SafeCopy b) => SafeCopy (H.HashMap a b) where + getCopy = contain $ fmap H.fromList safeGet + putCopy = contain . safePut . H.toList + + +makeAcidic ''Model $ [ + 'addRenderItem + , 'checkNextRenderItem + , 'fetchRenderItem + , 'getRenderQueueSize + , 'addNotification + , 'checkNextNotification + , 'getNotificationQueueSize + , 'fetchNotification + , 'getNotificationNextTime + ] + ++ A.acidQueries diff --git a/src/Text/PDF/Slave/Server/Monad.hs b/src/Text/PDF/Slave/Server/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/Monad.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Text.PDF.Slave.Server.Monad( + -- * Monad + ServerM + , runServerM + , serverMtoHandler + -- ** Monad environment + , ServerEnv(..) + , newServerEnv + -- * Auth monad + , AuthM + , runAuth + , authToServerM + -- * Utilities + , getConfig + , emitRenderItem + , module Text.PDF.Slave.Server.Util + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.STM.TChan +import Control.Concurrent.Thread.Delay +import Control.Monad +import Control.Monad.Base +import Control.Monad.Error.Class +import Control.Monad.Except +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.STM +import Control.Monad.Trans.Control +import Data.Monoid +import Data.Text (pack, Text) +import Data.Time (getCurrentTime, diffUTCTime, addUTCTime) +import Data.Yaml (encode, ToJSON) +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Servant.Server +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model +import Text.PDF.Slave.Server.DB.Model + +import Text.PDF.Slave +import Text.PDF.Slave.Server.API (APINotificationBody(..), toAPIRenderId) +import Text.PDF.Slave.Server.Config +import Text.PDF.Slave.Server.DB +import Text.PDF.Slave.Server.Notification +import Text.PDF.Slave.Server.Util + +import qualified Servant.Server.Auth.Token.Acid as A +import qualified Control.Immortal as Immortal +import qualified Shelly as Sh + +-- | Server private environment +data ServerEnv = ServerEnv { + envConfig :: ServerConfig -- ^ Configuration used to create the server +, envDB :: AcidState Model -- ^ Server DB +-- | Coordination channel that is pushed when new item arrived. Workers wait for +-- new value in the channel when they finished all available work from rendering +-- queue. Thats helps to avoid polling when there is no work to do. +, envRenderChan :: TChan () +-- | Coordination channel that is pushed when new item arrived. Workers wait for +-- new value in the channel when they finished all available work from notification +-- queue. Thats helps to avoid polling when there is no work to do. +, envNotificationChan :: TChan () +-- | Connection manager for sending notifications +, envManager :: Manager +} + +-- Derive HasStorage for 'AcidBackendT' with 'Model'. +-- It is important that it is come before the below newtype +A.deriveAcidHasStorage ''Model + +-- | Special monad for authorisation actions +newtype AuthM a = AuthM { unAuthM :: A.AcidBackendT Model IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage) + +-- | Execution of authorisation actions that require 'AuthHandler' context +runAuth :: AuthM a -> ServerM a +runAuth m = do + cfg <- asks (serverAuthConfig . envConfig) + db <- asks envDB + liftHandler $ Handler . ExceptT $ A.runAcidBackendT cfg db $ unAuthM m + +-- | Transformation from 'AuthM' monad to 'ServerM' +authToServerM :: AuthM :~> ServerM +authToServerM = NT runAuth + +-- | Create new server environment +newServerEnv :: (MonadIO m, MonadBaseControl IO m) + => ServerConfig -> m ServerEnv +newServerEnv cfg = do + acid <- createDB (serverDatabaseConf cfg) + renderChan <- liftIO newTChanIO + notificChan <- liftIO newTChanIO + mng <- liftIO $ newManager tlsManagerSettings + let env = ServerEnv { + envConfig = cfg + , envDB = acid + , envRenderChan = renderChan + , envNotificationChan = notificChan + , envManager = mng + } + liftIO . runServerMIO env $ do + runAuth $ ensureAdmin (passwordsStrength . serverAuthConfig $ cfg) "admin" (serverAdminPassword cfg) "admin@localhost" + replicateM_ (serverRenderWorkers cfg) spawnRendererWorker + replicateM_ (serverNotificationWorkers cfg) spawnNotificationWorker + return env + +-- | Server monad that holds internal environment +newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv + , MonadLogger, MonadLoggerIO, MonadError ServantErr) + +newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } + +instance MonadBaseControl IO ServerM where + type StM ServerM a = StMServerM a + liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) + restoreM = ServerM . restoreM . unStMServerM + +instance HasAcidState Model ServerM where + getAcidState = asks envDB + +-- | Lift servant monad to server monad +liftHandler :: Handler a -> ServerM a +liftHandler = ServerM . lift . lift + +-- | Execution of 'ServerM' +runServerM :: ServerEnv -> ServerM a -> Handler a +runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM + +-- | Execution of 'ServerM' in IO monad +runServerMIO :: ServerEnv -> ServerM a -> IO a +runServerMIO env m = do + ea <- runHandler $ runServerM env m + case ea of + Left e -> fail $ "runServerMIO: " <> show e + Right a -> return a + +-- | Transformation to Servant 'Handler' +serverMtoHandler :: ServerEnv -> ServerM :~> Handler +serverMtoHandler e = NT (runServerM e) + +-- | Getting server configuration +getConfig :: ServerM ServerConfig +getConfig = asks envConfig + +-- | Awake sleeping workers when we have a work to do +emitRenderItem :: ServerM () +emitRenderItem = do + chan <- asks envRenderChan + liftIO . atomically $ writeTChan chan () + +-- | Awake sleeping workers when we have a work to do +emitNotificationItem :: ServerM () +emitNotificationItem = do + chan <- asks envNotificationChan + liftIO . atomically $ writeTChan chan () + +-- | Spawn a worker that reads next available render task from queue and executes it +spawnRendererWorker :: ServerM () +spawnRendererWorker = void . Immortal.createWithLabel "rendererWorker" $ const $ do + $logDebug "Spawning renderer worker" + work + where + work = do + hasWork <- runQuery CheckNextRenderItem + if hasWork then do + mitem <- runUpdate FetchRenderItem + case mitem of + Nothing -> work + Just item -> do + let ri = renderId item + $logInfo $ "Start rendering of " <> showt ri + renderRes <- renderDocument item + $logInfo $ "Finished rendering of " <> showt ri + case renderRes of + Left er -> $logWarn $ "Rendering failed with: " <> er + Right _ -> $logInfo $ "Rendering finished successfully" + registerNotification item renderRes + work + else sleep + + sleep = do + chan <- asks envRenderChan + _ <- liftIO . atomically $ readTChan chan + work + +-- | Write down YAML file +writeYaml :: ToJSON a => Sh.FilePath -> a -> Sh.Sh () +writeYaml path a = Sh.writeBinary path $ encode a + +-- | Render given item +renderDocument :: RenderItem -> ServerM (Either Text PDFContent) +renderDocument RenderItem{..} = do + let template = maybe renderTemplate (\i -> renderTemplate { templateInput = Just i }) renderInput + Sh.shelly $ Sh.handleany_sh (return . Left . pack . show) $ Sh.withTmpDir $ \tempDir -> Sh.chdir tempDir $ do + let templateFilename = tempDir <> "bundle.yaml" + outputFilename = tempDir <> "output.pdf" + writeYaml templateFilename template + _ <- Sh.bash "stack" [ "exec" + , "--package=aeson" -- TODO: add packages dependencies to API + , "--package=bytestring" + , "--package=HaTeX" + , "--" + , "pdf-slave" + , "pdf" + , "--template=" <> Sh.toTextIgnore templateFilename + , "--output=" <> Sh.toTextIgnore outputFilename ] + Right <$> Sh.readBinary outputFilename + +-- | Convert rendering result to notification and save it +registerNotification :: RenderItem -> Either Text PDFContent -> ServerM () +registerNotification RenderItem{..} res = do + $logInfo $ "Registering notification for " <> showt renderId + t <- liftIO getCurrentTime + let notification = Notification { + notifTarget = renderUrl + , notifRenderId = renderId + , notifDocument = res + , notifTries = 0 + , notifLastError = Nothing + , notifNextTry = t + , notifToken = renderToken + } + runUpdate . AddNotification $ notification + emitNotificationItem -- awake notification workers + +-- | Spawn a worker that waits for notifications and tries to deliver them. +spawnNotificationWorker :: ServerM () +spawnNotificationWorker = void . Immortal.createWithLabel "rendererWorker" $ const $ do + $logDebug "Spawning notification worker" + work + where + work = do + $logDebug "Check pending notifications" + t <- liftIO getCurrentTime + hasWork <- runQuery $ CheckNextNotification t + if hasWork then do + $logDebug $ "Detected unprocessed notifications..." + mitem <- runUpdate $ FetchNotification t + case mitem of + Nothing -> do + $logDebug $ "But there is no work actually" + work + Just notification -> do + mnotification <- deliverNotification notification + whenJust mnotification $ runUpdate . AddNotification + work + else do + $logDebug "No work for notification worker, sleep" + sleep + + sleep = do + chan <- asks envNotificationChan + -- run thread that will awake the worker when next notification is ready + mt <- runQuery GetNotificationNextTime + whenJust mt $ \t -> do + curTime <- liftIO getCurrentTime + let dt = toMicroseconds $ diffUTCTime t curTime + $logDebug $ "Next notification in " <> showt dt <> " ms" + void . liftIO . forkIO $ do + delay dt + atomically $ writeTChan chan () + -- wait for new notifications + _ <- liftIO . atomically $ readTChan chan + work + +-- | Try to send notification to client, if failed, delay notification for additional +-- try. If maximum count of tries is hit, the notification is deleted. +deliverNotification :: Notification -> ServerM (Maybe Notification) +deliverNotification n@Notification{..} = do + $logInfo $ "Trying to deliver notification for " <> showt notifRenderId + let body = APINotificationBody { + apiNotificationId = toAPIRenderId . unRenderId $ notifRenderId + , apiNotificationError = either Just (const Nothing) notifDocument + , apiNotificationDocument = either (const Nothing) Just notifDocument + } + mng <- asks envManager + res <- postNotification mng notifTarget body notifToken + case res of + Left (BadBaseUrl e) -> do + $logError $ "Notification for " <> showt notifRenderId + <> " is failed, wrong url " <> notifTarget <> ": " <> showt e + return Nothing + Left HasRedirectError -> do + $logError $ "Notification for " <> showt notifRenderId + <> " is failed, forbidden redirections" + return Nothing + Left (WrongSuccessStatus s) -> do + $logWarn $ "Notification for " <> showt notifRenderId + <> " is succeded, but returned strage status " <> showt s + return Nothing + Left (NotificationFail e) -> do + $logWarn $ "Notification for " <> showt notifRenderId + <> " is failed, reason: " <> showt e <> ", will retry later." + ServerConfig{..} <- asks envConfig + case (notifTries >=) <$> serverMaxNotificationTries of + Just True -> do + $logError $ "Notification for " <> showt notifRenderId + <> " is not delivered! Maximum count of tries is hit." + return Nothing + _ -> do + t <- liftIO getCurrentTime + let n' = n { + notifTries = notifTries + 1 + , notifLastError = Just $ showt e + , notifNextTry = serverNotificationDelay `addUTCTime` t + } + return $ Just n' + Right () -> do + $logInfo $ "Notification for " <> showt notifRenderId + <> " is succeded!" + return Nothing diff --git a/src/Text/PDF/Slave/Server/Notification.hs b/src/Text/PDF/Slave/Server/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/Notification.hs @@ -0,0 +1,90 @@ +module Text.PDF.Slave.Server.Notification( + NotificationError(..) + , postNotification + ) where + +import Control.Exception (try) +import Control.Lens +import Control.Monad (unless) +import Control.Monad.Except (ExceptT (..), throwError, runExceptT) +import Control.Monad.IO.Class (MonadIO(..)) +import Crypto.Hash (Digest, SHA256, hashlazy) +import Data.Aeson (encode) +import Data.Bifunctor (first) +import Data.ByteArray (convert) +import Data.Monoid +import Data.Text (Text, unpack, pack) +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Network.HTTP.Client (HttpException (..), Manager, HttpExceptionContent(..)) +import Network.Wreq +import Servant.API.Auth.Token + +import Text.PDF.Slave.Server.API + +import qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Lazy as BSL (ByteString, fromStrict) + +-- | Wrapper around client 'HttpException' to distinguish errors when an ill +-- formatted base url is specified and when an error that requires retry is +-- occured. +data NotificationError = + -- | Ill formated base url, don't retry + BadBaseUrl !String + -- | The url leads to redirection what is forbidden + | HasRedirectError + -- | The request succeeded with 2xx status but not equal to 200 + | WrongSuccessStatus !Status + -- | Other error that requires retry + | NotificationFail !HttpException + deriving (Generic, Show) + +-- | Convert http exception to semantically rich 'NotificationError' +toNotificationError :: HttpException -> NotificationError +toNotificationError e = case e of + InvalidUrlException s1 s2 -> BadBaseUrl (s1 <> " : " <> s2) + HttpExceptionRequest _ TooManyRedirects{} -> HasRedirectError + _ -> NotificationFail e + +-- | Send notification to remote server. +postNotification :: MonadIO m + -- | Connection manager + => Manager + -- | Base url of shop endpoint + -> Text + -- | Body of notification + -> APINotificationBody + -- | Token that was used at registration of rendering + -> SimpleToken + -- | If returned 'Right' then notification is + -- succeded, else it should be retried + -> m (Either NotificationError ()) +postNotification mng baseUrl' notification token = liftIO . runExceptT $ do + let baseUrl = unpack baseUrl' + body = encode notification + sign = makeSignature baseUrl body token + opts = defaults & manager .~ Right mng + & redirects .~ 1 + & header "X-Signature" .~ [sign] + & header "Content-Type" .~ ["application/json"] + response <- catchHttpException $ postWith opts baseUrl body + unless (response ^. responseStatus . statusCode == 200) $ + throwError $ WrongSuccessStatus (response ^. responseStatus) + where + catchHttpException = ExceptT . fmap (first toNotificationError) . try + +-- | Make 'X-Signature' header for 'postNotification'. +-- +-- The request is signed with SHA256. The hash is applied to URI, full body of +-- query, authorisation token that are separated by commas. The signatures +-- is placed in 'X-Signature' header. Header content is encoded in Base16. +makeSignature :: String -- ^ Base url of shop endpoint + -> BSL.ByteString -- ^ Request body that we sign + -> SimpleToken -- ^ Authorisation token that is used to request the render + -> BS.ByteString -- ^ SHA256 hash aka signature +makeSignature url body token = B16.encode . convert $ digets + where + toBs = BSL.fromStrict . encodeUtf8 . pack + signBody = toBs url <> "," <> body <> "," <> toBs (show token) + digets = hashlazy signBody :: Digest SHA256 diff --git a/src/Text/PDF/Slave/Server/Util.hs b/src/Text/PDF/Slave/Server/Util.hs new file mode 100644 --- /dev/null +++ b/src/Text/PDF/Slave/Server/Util.hs @@ -0,0 +1,32 @@ +module Text.PDF.Slave.Server.Util( + ffor + , whenJust + , showl + , showt + , toMicroseconds + ) where + +import Control.Monad.Logger +import Data.Text +import Data.Time + +-- | Fliped fmap +ffor :: Functor f => f a -> (a -> b) -> f b +ffor = flip fmap + +-- | Execute applicative action only when the value is 'Just' +whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () +whenJust (Just a) m = m a +whenJust Nothing _ = pure () + +-- | Convert anything to log string +showl :: Show a => a -> LogStr +showl = toLogStr . show + +-- | Convert anything to log string +showt :: Show a => a -> Text +showt = pack . show + +-- | Convert time internval to count of microseconds +toMicroseconds :: NominalDiffTime -> Integer +toMicroseconds dt = round $ (realToFrac dt :: Rational) * 1000000 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,85 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-8.19 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +- 'pdf-slave-server-api' +- 'pdf-slave-server-cli' +- location: + git: https://github.com/NCrashed/haskintex.git + commit: ebbc70b803b51e52cfc4433338516cdbb2998e13 + extra-dep: true + +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: +- aeson-1.2.1.0 +- haskell-src-exts-1.19.1 +- pdf-slave-1.3.2.0 +- pdf-slave-template-1.2.1.0 +- servant-0.11 +- servant-auth-token-0.4.7.1 +- servant-auth-token-api-0.4.2.2 +- servant-auth-token-acid-0.4.1.1 +- servant-client-0.11 +- servant-docs-0.10.0.1 +- servant-server-0.11 +- servant-swagger-1.1.3 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.3" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor