pdf-slave-server (empty) → 0.1.1.0
raw patch · 14 files changed
+1207/−0 lines, 14 filesdep +acid-statedep +aesondep +aeson-injectorsetup-changed
Dependencies added: acid-state, aeson, aeson-injector, base, base16-bytestring, bytestring, containers, cryptonite, hashable, http-client, http-client-tls, immortal, lens, memory, monad-control, monad-logger, mtl, optparse-applicative, pdf-slave, pdf-slave-server, pdf-slave-server-api, safecopy, scientific, servant, servant-auth-token, servant-auth-token-acid, servant-auth-token-api, servant-server, shelly, stm, text, time, transformers-base, unbounded-delays, unordered-containers, uuid, wai-extra, warp, wreq, yaml
Files
- CHANGELOG.md +9/−0
- LICENSE +30/−0
- README.md +27/−0
- Setup.hs +2/−0
- app/Main.hs +43/−0
- pdf-slave-server.cabal +113/−0
- src/Text/PDF/Slave/Server.hs +71/−0
- src/Text/PDF/Slave/Server/Config.hs +96/−0
- src/Text/PDF/Slave/Server/DB.hs +89/−0
- src/Text/PDF/Slave/Server/DB/Model.hs +205/−0
- src/Text/PDF/Slave/Server/Monad.hs +315/−0
- src/Text/PDF/Slave/Server/Notification.hs +90/−0
- src/Text/PDF/Slave/Server/Util.hs +32/−0
- stack.yaml +85/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+0.1.1.0+=======++* Port to `lts-8.19`++0.1.0.0+=======++* Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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" )
+ pdf-slave-server.cabal view
@@ -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
+ src/Text/PDF/Slave/Server.hs view
@@ -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 = []+ }
+ src/Text/PDF/Slave/Server/Config.hs view
@@ -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
+ src/Text/PDF/Slave/Server/DB.hs view
@@ -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
+ src/Text/PDF/Slave/Server/DB/Model.hs view
@@ -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
+ src/Text/PDF/Slave/Server/Monad.hs view
@@ -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
+ src/Text/PDF/Slave/Server/Notification.hs view
@@ -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
+ src/Text/PDF/Slave/Server/Util.hs view
@@ -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
+ stack.yaml view
@@ -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