Fixes for GHC 8.0.1

8 files changed, 36 insertions, 35 deletions

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