From e8e0cb7f36641ffb7901178bc54fef98eba9215c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Apr 2018 14:34:05 +0200 Subject: Fix build --- server/src/Thermoprint/Server.hs | 8 +++--- server/src/Thermoprint/Server/API.hs | 34 +++++++++++++----------- server/src/Thermoprint/Server/Printer.hs | 6 ++--- server/src/Thermoprint/Server/Printer/Generic.hs | 4 +-- server/src/Thermoprint/Server/Queue.hs | 2 +- server/src/Thermoprint/Server/Queue/Utils.hs | 2 +- 6 files changed, 30 insertions(+), 26 deletions(-) (limited to 'server/src') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 15fb651..a33a613 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -111,7 +111,7 @@ instance MonadIO m => Default (Config m) where } instance MonadIO m => Default (QMConfig m) where - def = QMConfig idQM $ Nat (liftIO . runIdentityT) + def = QMConfig idQM $ NT (liftIO . runIdentityT) withPrinters :: MonadResource m => Config m -> [(m PrinterMethod, QMConfig m)] -> m (Config m) -- ^ Add a list of printers to a 'Config' @@ -149,7 +149,7 @@ thermoprintServer dyre io cfg = do , Dyre.cacheDir = return <$> cacheDir } where - realMain cfg = unNat (io . Nat runResourceT) $ do + realMain cfg = (io . NT runResourceT) $$ do tMgr <- threadManager resourceForkIO flip finally (cleanup tMgr) $ do Config{..} <- cfg @@ -159,11 +159,11 @@ thermoprintServer dyre io cfg = do gcChan <- liftIO newTChanIO fork tMgr $ jobGC gcChan let - runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer + runQM' (queueManagers -> QMConfig qm nat) printer = nat $$ runQM gcChan qm printer mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers nChan <- liftIO $ newBroadcastTChanIO let printerUrl :: API.PrinterId -> URI - printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) . Just + printerUrl = linkURI . safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) . Just mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index f7a8576..30ef290 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -29,6 +29,7 @@ import qualified Data.Text as T import Servant hiding (Handler) import Servant.Server hiding (Handler) +import qualified Servant.Server as Servant (Handler(..)) import Servant.Utils.Enter import Servant.Utils.Links @@ -75,8 +76,8 @@ data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to intera handlerNat :: ( MonadReader ConnectionPool m , MonadLoggerIO m - ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> ExceptT ServantErr IO) --- ^ Servant requires its handlers to be 'ExceptT ServantErr IO' + ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> Servant.Handler) +-- ^ Servant requires its handlers to be essentially 'ExceptT ServantErr IO' -- -- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants handlerNat printerMap nChan = do @@ -89,8 +90,11 @@ handlerNat printerMap nChan = do , nChan = nChan } protoNat :: ProtoHandler :~> IO - protoNat = Nat runResourceT . Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput - return $ hoistNat protoNat + protoNat = NT runResourceT . NT (($ logFunc) . runLoggingT) . runReaderTNat handlerInput + return $ NT Servant.Handler . hoistNat protoNat + +runSql :: ReaderT SqlBackend ProtoHandler a -> Handler a +runSql act = lift $ runSqlPool act =<< asks sqlPool thermoprintServer :: ServerT ThermoprintAPI Handler -- ^ A 'servant-server' for 'ThermoprintAPI' @@ -157,7 +161,7 @@ listJobs pId idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a ) getJob :: API.JobId -> Handler Printout -getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool +getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSql (get $ castId jobId) jobStatus :: API.JobId -> Handler JobStatus jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing @@ -174,36 +178,36 @@ abortJob needle = do return . not $ ((==) `on` length) pending filtered when found $ do $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId') - notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) + notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) return found when (not found) $ throwError err404 listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle)) -listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap +listDrafts = runSql (selectSourceRes [] []) >>= lift . flip with toMap where toMap source = fmap Map.fromList . sourceToList $ (\(Entity key (Draft title _)) -> (castId key, title)) `mapOutput` source addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId addDraft title content = do - id <- fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool + id <- castId <$> runSql (insert $ Draft title content) $(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")" - notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle)))) + notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle)))) return id updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do - void . runSqlPool (updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool + void . runSql $ updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ] $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer)) - notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId + notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout) -getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool +getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSql (get $ castId draftId) deleteDraft :: API.DraftId -> Handler () deleteDraft draftId = do - runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool + runSql $ delete (castId draftId :: Key Draft) $(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted" - notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle)))) + notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle)))) printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId -printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool +printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSql (get $ castId draftId) diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs index 722d4ed..ae0c6a0 100644 --- a/server/src/Thermoprint/Server/Printer.hs +++ b/server/src/Thermoprint/Server/Printer.hs @@ -50,7 +50,7 @@ import Data.Time.Clock import Thermoprint.Server.Queue -newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m) => Printout -> m (Maybe PrintingError) } +newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m, MonadMask m, MonadUnliftIO m) => Printout -> m (Maybe PrintingError) } data Printer = Printer { print :: PrinterMethod @@ -68,7 +68,7 @@ atomically' = liftIO . atomically runPrinter :: ( MonadReader ConnectionPool m , MonadLogger m - , MonadBaseControl IO m + , MonadUnliftIO m , MonadResource m , MonadMask m ) => Printer -> m () @@ -95,7 +95,7 @@ runPrinter Printer{..} = forever $ do addToQueue :: ( MonadReader ConnectionPool m , MonadLogger m , MonadResource m - , MonadBaseControl IO m + , MonadUnliftIO m ) => Printout -> Printer -> m JobId addToQueue printout Printer{..} = do jobId <- runSqlPool (insert $ Job printout) =<< ask diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs index ce818ee..441c74d 100644 --- a/server/src/Thermoprint/Server/Printer/Generic.hs +++ b/server/src/Thermoprint/Server/Printer/Generic.hs @@ -63,10 +63,10 @@ import Prelude hiding (mapM_, sequence_, lines) genericPrint :: FilePath -> PrinterMethod genericPrint path = PM $ genericPrint' path -genericPrint' :: (MonadIO m, MonadMask m, MonadLogger m) => FilePath -> Printout -> m (Maybe PrintingError) +genericPrint' :: (MonadIO m, MonadMask m, MonadLogger m, MonadUnliftIO m) => FilePath -> Printout -> m (Maybe PrintingError) genericPrint' path = flip catches handlers . withFile path . print where - withFile path f = flip withEx f $ mkAcquire (openFile path WriteMode >>= (\h -> h <$ hSetBuffering h NoBuffering)) hClose + withFile path f = flip with f $ mkAcquire (openFile path WriteMode >>= (\h -> h <$ hSetBuffering h NoBuffering)) hClose handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String) , Handler $ return . Just . EncError , Handler $ return . Just diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs index aa26fe3..fb5deb9 100644 --- a/server/src/Thermoprint/Server/Queue.hs +++ b/server/src/Thermoprint/Server/Queue.hs @@ -180,7 +180,7 @@ runQM gcChan qm (extractQueue -> q) = sleep =<< qm' | otherwise = return () jobGC :: ( MonadReader ConnectionPool m - , MonadBaseControl IO m + , MonadUnliftIO m , MonadIO m ) => TChan JobId -> m () -- ^ Listen for 'JobId's on a 'TChan' and delete them from the database 'forever' diff --git a/server/src/Thermoprint/Server/Queue/Utils.hs b/server/src/Thermoprint/Server/Queue/Utils.hs index 745053e..0255250 100644 --- a/server/src/Thermoprint/Server/Queue/Utils.hs +++ b/server/src/Thermoprint/Server/Queue/Utils.hs @@ -22,7 +22,7 @@ import Servant.Utils.Enter import Thermoprint.Server.Queue standardCollapse :: MonadIO m => IdentityT IO :~> m -standardCollapse = Nat $ liftIO . runIdentityT +standardCollapse = NT $ liftIO . runIdentityT standardSleep :: Monad (QueueManagerM t) => QueueManager t -- ^ Instruct 'runQM' to sleep some standard amount of time -- cgit v1.2.3