From 2b9ceaead3f3cd80e973cccecb9a3eebc51154f7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 17 Jul 2016 19:21:56 +0200 Subject: Fixes for GHC 8.0.1 --- server/default-conf/Main.hs | 4 +++ server/src/Thermoprint/Server.hs | 14 +++++----- server/src/Thermoprint/Server/API.hs | 33 +++++++++++------------- server/src/Thermoprint/Server/Printer/Debug.hs | 2 +- server/src/Thermoprint/Server/Printer/Generic.hs | 4 +-- server/src/Thermoprint/Server/Queue/Utils.hs | 2 +- server/test/Thermoprint/ServerSpec.hs | 4 +-- server/thermoprint-server.cabal | 8 +++--- 8 files changed, 36 insertions(+), 35 deletions(-) (limited to 'server') diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs index 7c4bfc7..35088e8 100644 --- a/server/default-conf/Main.hs +++ b/server/default-conf/Main.hs @@ -20,6 +20,10 @@ main = thermoprintServer True (Nat runSqlite) $ def `withPrinters` printers runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a runSqlite = runStderrLoggingT . withSqlitePool "thermoprint.sqlite" 1 . runReaderT + printers :: [( ResourceT (ReaderT ConnectionPool (LoggingT IO)) PrinterMethod + , QMConfig (ResourceT (ReaderT ConnectionPool (LoggingT IO))) + ) + ] printers = [ (pure debugPrint, def) , (pure $ delayedDebugPrint (10 * 10^6), def) ] diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 07462da..15fb651 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -13,7 +13,7 @@ module Thermoprint.Server , Config(..), QMConfig(..) , withPrinters , module Data.Default.Class - , module Servant.Server.Internal.Enter + , module Servant.Utils.Enter , module Thermoprint.Server.Printer , module Thermoprint.Server.Queue , module Thermoprint.Server.Queue.Utils @@ -62,7 +62,7 @@ import qualified Network.Wai.Handler.Warp as Warp import Network.Wai (Application) import Servant.Server (serve) -import Servant.Server.Internal.Enter (enter, (:~>)(..)) +import Servant.Utils.Enter (enter, (:~>)(..)) import Servant.API import Servant.Utils.Links import Network.URI @@ -137,16 +137,16 @@ thermoprintServer :: ( MonadLoggerIO m -> (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack. -> ResourceT m (Config (ResourceT m)) -> IO () -- ^ Run the server -thermoprintServer dyre io = do +thermoprintServer dyre io cfg = do cfgDir <- lookupEnv "THERMOPRINT_CONFIG" cacheDir <- lookupEnv "THERMOPRINT_CACHE" - Dyre.wrapMain $ Dyre.defaultParams + flip Dyre.wrapMain cfg $ Dyre.defaultParams { Dyre.projectName = "thermoprint-server" , Dyre.realMain = realMain , Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg })) , Dyre.configCheck = dyre - , Dyre.configDir = cfgDir - , Dyre.cacheDir = cacheDir + , Dyre.configDir = return <$> cfgDir + , Dyre.cacheDir = return <$> cacheDir } where realMain cfg = unNat (io . Nat runResourceT) $ do @@ -164,6 +164,6 @@ thermoprintServer dyre io = do 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)))) + printerUrl = 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 cbf727c..8e17eb4 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -27,15 +27,15 @@ import qualified Data.Map as Map import qualified Data.Text as T -import Servant -import Servant.Server -import Servant.Server.Internal.Enter +import Servant hiding (Handler) +import Servant.Server hiding (Handler) +import Servant.Utils.Enter import Servant.Utils.Links import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource -import Control.Monad.Trans.Either +import Control.Monad.Except import Control.Monad.IO.Class import Control.Concurrent.STM @@ -65,7 +65,7 @@ import Control.Monad.Catch (handle, catch) import Data.Time type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO)) -type Handler = EitherT ServantErr ProtoHandler +type Handler = ExceptT ServantErr ProtoHandler -- ^ Runtime configuration of our handlers data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage @@ -73,13 +73,10 @@ data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to intera , nChan :: TChan Notification } -instance MonadLogger m => MonadLogger (EitherT a m) where - monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl - handlerNat :: ( MonadReader ConnectionPool m , MonadLoggerIO m - ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> EitherT ServantErr IO) --- ^ Servant requires its handlers to be 'EitherT ServantErr IO' + ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> ExceptT ServantErr IO) +-- ^ Servant requires its handlers to be '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 @@ -116,11 +113,11 @@ lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer) lookupPrinter pId = asks printers >>= maybePrinter' pId where maybePrinter' Nothing printerMap - | Map.null printerMap = left $ err501 { errBody = "No printers available" } + | Map.null printerMap = throwError $ err501 { errBody = "No printers available" } | otherwise = return $ Map.findMin printerMap maybePrinter' (Just pId) printerMap | Just printer <- Map.lookup pId printerMap = return (pId, printer) - | otherwise = left $ err404 { errBody = "No such printer" } + | otherwise = throwError $ err404 { errBody = "No such printer" } queue' :: MonadIO m => Printer -> m Queue -- ^ Call 'queue' and handle concurrency @@ -160,10 +157,10 @@ listJobs pId idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a ) getJob :: API.JobId -> Handler Printout -getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool +getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool jobStatus :: API.JobId -> Handler JobStatus -jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing +jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing abortJob :: API.JobId -> Handler () abortJob needle = do @@ -179,7 +176,7 @@ abortJob needle = 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)))) return found - when (not found) $ left err404 + when (not found) $ throwError err404 listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle)) listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap @@ -194,13 +191,13 @@ addDraft title content = do return id updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () -updateDraft draftId title content = handle (\(KeyNotFound _) -> left $ err404) $ do +updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool $(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 getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout) -getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool +getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool deleteDraft :: API.DraftId -> Handler () deleteDraft draftId = do @@ -209,4 +206,4 @@ deleteDraft draftId = do notify $ 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 (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool +printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs index d7ee12a..b8580b8 100644 --- a/server/src/Thermoprint/Server/Printer/Debug.hs +++ b/server/src/Thermoprint/Server/Printer/Debug.hs @@ -26,7 +26,7 @@ debugPrint :: PrinterMethod debugPrint = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext' cotext' :: Printout -> Text -cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList +cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList . getChunks) . toList . getParagraphs where cotext'' (Cooked b) = cotext b cotext'' (Raw _) = "[Raw]" diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs index df84e06..f431e4f 100644 --- a/server/src/Thermoprint/Server/Printer/Generic.hs +++ b/server/src/Thermoprint/Server/Printer/Generic.hs @@ -114,10 +114,10 @@ intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m () intersperse' b f = sequence_ . intersperse b f render :: Printout -> Put -render = intersperse' (newls' 2) renderPar +render = intersperse' (newls' 2) renderPar . getParagraphs renderPar :: Paragraph -> Put -renderPar = mapM_ renderChunk +renderPar = mapM_ renderChunk . getChunks where renderChunk (Raw bs) = mapM_ pushWord8 $ LBS.unpack bs renderChunk (Cooked block) = renderDoc $ execState (renderBlock block) (initDoc width) diff --git a/server/src/Thermoprint/Server/Queue/Utils.hs b/server/src/Thermoprint/Server/Queue/Utils.hs index 86b0162..745053e 100644 --- a/server/src/Thermoprint/Server/Queue/Utils.hs +++ b/server/src/Thermoprint/Server/Queue/Utils.hs @@ -17,7 +17,7 @@ import Data.Time import Control.Monad.State import Control.Monad.IO.Class import Control.Monad.Trans.Identity -import Servant.Server.Internal.Enter +import Servant.Utils.Enter import Thermoprint.Server.Queue diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs index 028ba2d..8af210d 100644 --- a/server/test/Thermoprint/ServerSpec.hs +++ b/server/test/Thermoprint/ServerSpec.hs @@ -145,7 +145,7 @@ spec = withSetup $ do drafts `shouldReturn` [] dId <- draftCreate Nothing mempty draft dId `shouldReturn` (Nothing, mempty) - drafts `shouldReturn` [(dId, mempty)] + drafts `shouldReturn` [(dId, Nothing :: Maybe DraftTitle)] p <- generate arbitrary draftReplace dId (Just "Title") p draft dId `shouldReturn` (Just "Title", p) @@ -154,6 +154,6 @@ spec = withSetup $ do draftDelete dId drafts `shouldReturn` [] where - Client{..} = mkClient' $ BaseUrl Http "localhost" 3000 + Client{..} = mkClient' $ BaseUrl Http "localhost" 3000 "" diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 62eb0ca..37cf065 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-server -version: 1.1.0 +version: 2.0.0 synopsis: Server for thermoprint-spec -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -50,7 +50,7 @@ library , servant-server >=0.4.4 && <1 , stm >=2.4.4 && <3 , text >=1.2.1 && <2 - , thermoprint-spec ==3.0.* + , thermoprint-spec ==4.0.* , time >=1.5.0 && <2 , wai >=3.0.4 && <4 , warp >=3.1.9 && <4 @@ -75,8 +75,8 @@ Test-Suite tests hs-source-dirs: test main-is: Spec.hs build-depends: base >=4.8.1 && <5 - , thermoprint-server ==1.1.* - , thermoprint-client ==0.0.* + , thermoprint-server ==2.0.* + , thermoprint-client ==1.0.* , thermoprint-spec -any , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 -- cgit v1.2.3