Fix build

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 <nixpkgs> {};
-  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