From e8e0cb7f36641ffb7901178bc54fef98eba9215c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Apr 2018 14:34:05 +0200 Subject: Fix build --- client/src/Thermoprint/Client.hs | 11 ++++---- client/thermoprint-client.cabal | 4 ++- default.nix | 13 +++------ server/default-conf/Main.hs | 2 +- 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 +- server/test/Thermoprint/ServerSpec.hs | 6 ++--- server/thermoprint-server.cabal | 2 +- spec/thermoprint-spec.cabal | 3 ++- webgui/thermoprint-webgui.cabal | 2 +- 14 files changed, 50 insertions(+), 49 deletions(-) diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 8c4d99d..bb38268 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs @@ -17,7 +17,7 @@ module Thermoprint.Client -- = Reexports , ServantError(..) , module Thermoprint.API - , module Servant.Common.BaseUrl + , module Servant.Client , module Control.Monad.Except , module Control.Natural ) where @@ -27,10 +27,8 @@ import Data.Map (Map) import Data.Sequence (Seq) import Data.Time (UTCTime) -import Servant.Client hiding (HasClient(..)) +import Servant.Client hiding (HasClient(..), mkClient) import qualified Servant.Client as S -import Servant.Common.BaseUrl -import Servant.Common.Req import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings) import Servant.API -- import Servant.Utils.Enter @@ -42,6 +40,8 @@ import Control.Monad.Catch (Exception, MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans (lift) +import Control.Concurrent.STM.TVar (newTVarIO) + import Control.Monad import Control.Category import Prelude hiding (id, (.)) @@ -128,7 +128,8 @@ mkClient mSettings url = mkClientS clientNat clientNat :: forall m. (MonadThrow m, MonadIO m) => ClientM :~> m clientNat = NT $ \cAct -> do mgr <- liftIO $ newManager mSettings - either throwM return =<< liftIO (runClientM cAct $ ClientEnv mgr url) + cjar <- liftIO $ newTVarIO mempty + either throwM return =<< liftIO (runClientM cAct . ClientEnv mgr url $ Just cjar) mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m -- ^ @mkClient' = mkClient defaultManagerSettings diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 523b755..98fa962 100644 --- a/client/thermoprint-client.cabal +++ b/client/thermoprint-client.cabal @@ -24,15 +24,17 @@ library , thermoprint-spec ==6.0.* , servant >=0.4.4 && <1 , servant-client >=0.4.4 && <1 + , servant-client-core >=0.13 && <1 , servant-server >=0.4.4 && <1 , containers >=0.5.6 && <1 - , either >=4.4.1 && <5 + , either >=4.4.1 && <6 , time >=1.5.0 && <2 , exceptions >=0.8.2 && <1 , transformers >=0.4.2 && <1 , http-client >=0.4.28 && <1 , mtl >=2.2.1 && <3 , natural-transformation >=0.4 && <1 + , stm >=2.4 && <3 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/default.nix b/default.nix index 2b84d30..aafeb4a 100644 --- a/default.nix +++ b/default.nix @@ -1,19 +1,12 @@ args@{ - compilerName ? "ghc802" + compilerName ? null , extraPackages ? (p: []) , ... }: let defaultPackages = import {}; - haskellPackages = defaultPackages.haskell.packages."${compilerName}".override { - overrides = self: super: with super; { - # threepenny-gui = pkgs.haskell.lib.appendPatch threepenny-gui ./threepenny.patch; - encoding = pkgs.haskell.lib.doJailbreak encoding; - cabal-test-quickcheck = pkgs.haskell.lib.doJailbreak cabal-test-quickcheck; - extended-reals = pkgs.haskell.lib.doJailbreak extended-reals; - }; - }; + haskellPackages = defaultPackages.haskellPackages; pkgs = defaultPackages // haskellPackages // args; callPackage = pkgs.lib.callPackageWith (pkgs // self); self = { @@ -28,4 +21,4 @@ let tprint = callPackage ./tprint/tprint.nix {}; bbcode = callPackage ./bbcode/bbcode.nix {}; }; -in self +in self // { inherit haskellPackages; } diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs index 35088e8..6ea0ef7 100644 --- a/server/default-conf/Main.hs +++ b/server/default-conf/Main.hs @@ -15,7 +15,7 @@ import Control.Monad.Reader import Database.Persist.Sqlite main :: IO () -main = thermoprintServer True (Nat runSqlite) $ def `withPrinters` printers +main = thermoprintServer True (NT runSqlite) $ def `withPrinters` printers where runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a runSqlite = runStderrLoggingT . withSqlitePool "thermoprint.sqlite" 1 . runReaderT 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 diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs index 334f785..d1dadba 100644 --- a/server/test/Thermoprint/ServerSpec.hs +++ b/server/test/Thermoprint/ServerSpec.hs @@ -85,13 +85,13 @@ setup startup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> d runSqlite = runStderrLoggingT . filterLogger (const (> LevelDebug)) . withSqlitePool (T.pack fp) 1 . runReaderT printers = [ ( pure $ S.PM tPM - , S.QMConfig ((join . lift $ takeTMVar (manage tManager) <* signalTSem (ran tManager)) >> return 0) (Nat $ liftIO . runIdentityT) + , S.QMConfig ((join . lift $ takeTMVar (manage tManager) <* signalTSem (ran tManager)) >> return 0) (NT $ liftIO . runIdentityT) ) ] tPM :: MonadIO m => Printout -> m (Maybe PrintingError) tPM printout = liftIO . atomically $ putTMVar (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter) - RunningServer <$> forkFinally (S.thermoprintServer False (Nat runSqlite) $ def' `S.withPrinters` printers) (putMVar term) <*> pure term <*> pure startSem <*> pure tPrinter <*> pure tManager + RunningServer <$> forkFinally (S.thermoprintServer False (NT runSqlite) $ def' `S.withPrinters` printers) (putMVar term) <*> pure term <*> pure startSem <*> pure tPrinter <*> pure tManager where def' :: MonadIO m => S.Config m def' = S.def { S.warpSettings = setBeforeMainLoop (signalQSem startup) $ defaultSettings } @@ -158,7 +158,7 @@ spec = withSetup $ do where Client{..} = mkClient' $ BaseUrl Http "localhost" 3000 "" is404 :: ServantError -> Bool - is404 e@(FailureResponse {}) = statusCode (responseStatus e) == 404 + is404 (FailureResponse e) = statusCode (responseStatusCode e) == 404 is404 _ = False diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 1ed55a6..28c29d7 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -37,7 +37,7 @@ library , data-default-class >=0.0.1 && <1 , deepseq >=1.4.1 && <2 , dyre >=0.8.12 && <1 - , either >=4.4.1 && <5 + , either >=4.4.1 && <6 , exceptions >=0.8.0 && <1 , monad-control >=1.0.0 && <2 , monad-logger >=0.3.13 && <1 diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal index 4bcfe6a..555cdb8 100644 --- a/spec/thermoprint-spec.cabal +++ b/spec/thermoprint-spec.cabal @@ -38,13 +38,14 @@ library , deepseq >=1.4.1 && <2 , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <4 - , Cabal >=1.22.4 && <2 + , Cabal >=1.22.4 && <2.1 , cabal-test-quickcheck >=0.1.6 && <1 , servant >=0.4.4 && <1 , aeson >=1.0 && <2 , base64-bytestring >=1.0.0 && <2 , encoding >=0.8 && <1 , time >=1.5.0 && <2 + , unordered-containers >=0.2.8.0 && <1 -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall diff --git a/webgui/thermoprint-webgui.cabal b/webgui/thermoprint-webgui.cabal index dcd3c4f..e2a50dd 100644 --- a/webgui/thermoprint-webgui.cabal +++ b/webgui/thermoprint-webgui.cabal @@ -37,7 +37,7 @@ executable thermoprint-webgui , text >=1.2.2 && <2 , exceptions >=0.8.2 && <1 , containers >=0.5.6 && <1 - , either >=4.4.1 && <5 + , either >=4.4.1 && <6 , time >=1.5.0 && <2 , data-default-class >=0.0 && <1 hs-source-dirs: src -- cgit v1.2.3