From 7065a8cc1b8b01cd32d4b1d5317b323fec5238bd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 7 Mar 2017 14:16:21 +0100 Subject: Bump versions --- client/src/Thermoprint/Client.hs | 55 +++++++++-------------------------- client/thermoprint-client.cabal | 4 +-- client/thermoprint-client.nix | 2 +- default.nix | 2 ++ server/src/Thermoprint/Server/Push.hs | 2 +- server/thermoprint-server.cabal | 4 +-- spec/src/Thermoprint/API.hs | 8 ++--- spec/src/Thermoprint/Identifiers.hs | 8 ++--- spec/thermoprint-spec.cabal | 6 ++-- spec/thermoprint-spec.nix | 2 +- tp-bbcode/thermoprint-bbcode.cabal | 8 ++--- tp-bbcode/thermoprint-bbcode.nix | 2 +- tprint/src/Options.hs | 24 ++++++++++----- tprint/src/Options/Utils.hs | 1 + tprint/tprint.cabal | 8 ++--- tprint/tprint.nix | 2 +- webgui/src/Main.hs | 11 +++---- webgui/thermoprint-webgui.cabal | 6 ++-- webgui/thermoprint-webgui.nix | 2 +- 19 files changed, 72 insertions(+), 85 deletions(-) diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 448a912..46f6073 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs @@ -5,12 +5,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} -- | A client library for 'Thermoprint.API' module Thermoprint.Client ( Client(..) , mkClient, mkClient' - , throwNat, ioNat -- = Reexports , ServantError(..) , module Thermoprint.API @@ -27,10 +27,11 @@ import Data.Time (UTCTime) import Servant.Client hiding (HasClient(..)) 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 -import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Monad.Catch (Exception, MonadThrow(..)) @@ -92,29 +93,10 @@ withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI mkClientS :: Monad m => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors - -> ManagerSettings - -> BaseUrl -> Client m -- ^ Generate a 'Client' -mkClientS n mgrS url = Client - { printers = clientF n printers - , jobs = \a b c -> clientF n $ jobs a b c - , jobCreate = \a b -> clientF n $ jobCreate a b - , job = \a -> clientF n $ job a - , jobStatus = \a -> clientF n $ jobStatus a - , jobDelete = \a -> clientF n $ jobDelete a - , drafts = clientF n drafts - , draftCreate = \a b -> clientF n $ draftCreate a b - , draftReplace = \a b c -> clientF n $ draftReplace a b c - , draft = \a -> clientF n $ draft a - , draftDelete = \a -> clientF n $ draftDelete a - , draftPrint = \a b -> clientF n $ draftPrint a b - } +mkClientS n = Client{..} where - clientF :: Monad m => (ClientM :~> m) -> (Manager -> BaseUrl -> m a) -> m a - clientF n f = do - mgr <- unNat n $ (liftIO $ newManager mgrS :: ClientM Manager) - f mgr url printers :<|> (jobs :<|> jobCreate) :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete)) @@ -122,23 +104,14 @@ mkClientS n mgrS url = Client :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) = enter n $ client thermoprintAPI -mkClient :: Monad m - => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors - -> BaseUrl - -> Client m -mkClient n url = mkClientS n defaultManagerSettings url - -mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m --- ^ @mkClient' = mkClient $ ioNat . throwNat@ -mkClient' = mkClient $ ioNat . throwNat - -throwNat :: (Exception e, MonadThrow m) => ExceptT e m :~> m --- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM' -throwNat = Nat $ either throwM return <=< runExceptT - -ioNat :: MonadIO m => IO :~> m --- ^ @ioNat = Nat liftIO@ -ioNat = Nat liftIO +mkClient :: (MonadThrow m, MonadIO m) => ManagerSettings -> BaseUrl -> Client m +mkClient mSettings url = mkClientS $ Nat clientNat + where + clientNat :: forall m a. (MonadThrow m, MonadIO m) => ClientM a -> m a + clientNat cAct = do + mgr <- liftIO $ newManager mSettings + either throwM return =<< liftIO (runClientM cAct $ ClientEnv mgr url) -readerNat :: a -> ReaderT a m :~> m -readerNat a = Nat $ flip runReaderT a +mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m +-- ^ @mkClient' = mkClient defaultManagerSettings +mkClient' = mkClient defaultManagerSettings diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 0920773..1306542 100644 --- a/client/thermoprint-client.cabal +++ b/client/thermoprint-client.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-client -version: 1.0.1 +version: 2.0.0 synopsis: Client for thermoprint-spec -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -21,7 +21,7 @@ library -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 - , thermoprint-spec ==5.0.* + , thermoprint-spec ==6.0.* , servant >=0.4.4 && <1 , servant-client >=0.4.4 && <1 , servant-server >=0.4.4 && <1 diff --git a/client/thermoprint-client.nix b/client/thermoprint-client.nix index 8aadafb..7f83630 100644 --- a/client/thermoprint-client.nix +++ b/client/thermoprint-client.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "thermoprint-client"; - version = "1.0.1"; + version = "2.0.0"; src = ./.; libraryHaskellDepends = [ base containers either exceptions http-client mtl servant diff --git a/default.nix b/default.nix index 09e2b7b..f883c52 100644 --- a/default.nix +++ b/default.nix @@ -7,6 +7,8 @@ rec { 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; }; }; thermoprint-spec = haskellPackages.callPackage ./spec/thermoprint-spec.nix {}; diff --git a/server/src/Thermoprint/Server/Push.hs b/server/src/Thermoprint/Server/Push.hs index 07b81fb..7ae03a6 100644 --- a/server/src/Thermoprint/Server/Push.hs +++ b/server/src/Thermoprint/Server/Push.hs @@ -32,7 +32,7 @@ import qualified Data.Text as Text type Notification = URI withPush :: TChan Notification -> Application -> Application -withPush chan = websocketsOr defaultConnectionOptions $ flip acceptRequestWith (AcceptRequest $ Just protocolSpec) >=> handleClient chan +withPush chan = websocketsOr defaultConnectionOptions $ flip acceptRequestWith (AcceptRequest (Just protocolSpec) []) >=> handleClient chan protocolSpec :: ByteString protocolSpec = CBS.pack $ "thermoprint-server.notification." ++ showVersion version diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index eae3754..1ed55a6 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -50,7 +50,7 @@ library , servant-server >=0.4.4 && <1 , stm >=2.4.4 && <3 , text >=1.2.1 && <2 - , thermoprint-spec ==5.0.* + , thermoprint-spec ==6.0.* , time >=1.5.0 && <2 , wai >=3.0.4 && <4 , warp >=3.1.9 && <4 @@ -76,7 +76,7 @@ Test-Suite tests main-is: Spec.hs build-depends: base >=4.8.1 && <5 , thermoprint-server ==2.0.* - , thermoprint-client ==1.0.* + , thermoprint-client ==2.0.* , thermoprint-spec -any , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs index 8e98db8..5b24e54 100644 --- a/spec/src/Thermoprint/API.hs +++ b/spec/src/Thermoprint/API.hs @@ -55,11 +55,11 @@ import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) import Test.QuickCheck.Gen (scale, variant, oneof) import Test.QuickCheck.Instances -instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where - toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId) +-- instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where +-- toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId) -instance (Enum k, Ord k, FromJSON v) => FromJSON (Map k v) where - parseJSON = fmap (IntMap.foldMapWithKey $ Map.singleton . castId) . parseJSON +-- instance (Enum k, Ord k, FromJSON v) => FromJSON (Map k v) where +-- parseJSON = fmap (IntMap.foldMapWithKey $ Map.singleton . castId) . parseJSON data PrinterStatus = Busy JobId | Available diff --git a/spec/src/Thermoprint/Identifiers.hs b/spec/src/Thermoprint/Identifiers.hs index 2a07318..e90602c 100644 --- a/spec/src/Thermoprint/Identifiers.hs +++ b/spec/src/Thermoprint/Identifiers.hs @@ -13,16 +13,16 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Servant.API (ToHttpApiData, FromHttpApiData) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey) newtype PrinterId = PrinterId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, ToJSONKey, FromJSONKey, Typeable, Generic, NFData) newtype JobId = JobId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, ToJSONKey, FromJSONKey, Typeable, Generic, NFData) newtype DraftId = DraftId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, ToJSONKey, FromJSONKey, Typeable, Generic, NFData) castId :: (Integral a, Enum b) => a -> b castId = toEnum . fromInteger . toInteger diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal index 138a06e..4bcfe6a 100644 --- a/spec/thermoprint-spec.cabal +++ b/spec/thermoprint-spec.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-spec -version: 5.0.1 +version: 6.0.0 synopsis: A specification of the API and the payload datatypes and associated utilities -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -41,7 +41,7 @@ library , Cabal >=1.22.4 && <2 , cabal-test-quickcheck >=0.1.6 && <1 , servant >=0.4.4 && <1 - , aeson >=0.9.0 && <1 + , aeson >=1.0 && <2 , base64-bytestring >=1.0.0 && <2 , encoding >=0.8 && <1 , time >=1.5.0 && <2 @@ -62,4 +62,4 @@ Test-Suite tests , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <4 - , aeson >=0.9.0 && <1 \ No newline at end of file + , aeson >=1.0 && <2 \ No newline at end of file diff --git a/spec/thermoprint-spec.nix b/spec/thermoprint-spec.nix index a3093de..d28b405 100644 --- a/spec/thermoprint-spec.nix +++ b/spec/thermoprint-spec.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "thermoprint-spec"; - version = "5.0.1"; + version = "6.0.0"; src = ./.; libraryHaskellDepends = [ aeson base base64-bytestring bytestring Cabal cabal-test-quickcheck diff --git a/tp-bbcode/thermoprint-bbcode.cabal b/tp-bbcode/thermoprint-bbcode.cabal index 89ed326..9fdf216 100644 --- a/tp-bbcode/thermoprint-bbcode.cabal +++ b/tp-bbcode/thermoprint-bbcode.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-bbcode -version: 2.0.1 +version: 3.0.0 synopsis: Parse bbcode for use in thermoprint -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -24,7 +24,7 @@ library , OverloadedLists -- other-extensions: build-depends: base >=4.8.1 && <5 - , thermoprint-spec ==5.0.* + , thermoprint-spec ==6.0.* , bbcode >=3.1.1 && <4 , containers -any , text -any @@ -44,10 +44,10 @@ Test-Suite tests , OverloadedLists build-depends: base >=4.8.1 && <5 , thermoprint-bbcode -any - , thermoprint-spec ==5.0.* + , thermoprint-spec ==6.0.* , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <4 - , aeson >=0.9.0 && <1 + , aeson >=1.0 && <2 , containers -any , text -any \ No newline at end of file diff --git a/tp-bbcode/thermoprint-bbcode.nix b/tp-bbcode/thermoprint-bbcode.nix index 3c698f1..deab20e 100644 --- a/tp-bbcode/thermoprint-bbcode.nix +++ b/tp-bbcode/thermoprint-bbcode.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "thermoprint-bbcode"; - version = "2.0.1"; + version = "3.0.0"; src = ./.; libraryHaskellDepends = [ base bbcode bytestring case-insensitive containers text diff --git a/tprint/src/Options.hs b/tprint/src/Options.hs index e146f91..703c23b 100644 --- a/tprint/src/Options.hs +++ b/tprint/src/Options.hs @@ -26,8 +26,12 @@ import Instances () import Paths_tprint (version) import Data.Version (showVersion) +import Data.Maybe +import Data.Monoid import Data.Bifunctor (Bifunctor(..)) +import System.Environment (lookupEnv) + data TPrint = TPrint { baseUrl :: BaseUrl , dryRun :: Bool @@ -149,12 +153,15 @@ pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters ) (progDesc "Interact with drafts") ] -pTPrint :: Parser TPrint -pTPrint = TPrint <$> option (eitherReader $ first show . parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000 "") <> showDefaultWith showBaseUrl) - <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state") - <*> pOutput - <*> pOperation - <*> switch (long "dump-options" <> internal) +pTPrint :: IO (Parser TPrint) +pTPrint = do + baseUrl <- parseBaseUrl =<< (fromMaybe "http://localhost:3000/" <$> lookupEnv "TPRINT_BASEURL") + return $ + TPrint <$> option (eitherReader $ first show . parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with; also read from TPRINT_BASEURL when set" <> value baseUrl <> showDefaultWith showBaseUrl) + <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state") + <*> pOutput + <*> pOperation + <*> switch (long "dump-options" <> internal) pOutput :: Parser Output pOutput = (,) <$> pOutputFormat <*> pSink @@ -177,4 +184,7 @@ pInput = (,) <$> pInputFormat <*> pSource rSource' x = ReadFile x withArgs :: (TPrint -> IO a) -> IO a -withArgs a = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header ("tprint " ++ showVersion version) <> progDesc "A cli for Thermoprint.Client") >>= a +withArgs a = do + pTPrint' <- pTPrint + customExecParser (prefs $ showHelpOnError) (info pTPrint' $ header ("tprint " ++ showVersion version) <> progDesc "A cli for Thermoprint.Client") >>= a + diff --git a/tprint/src/Options/Utils.hs b/tprint/src/Options/Utils.hs index 237aa56..3fae250 100644 --- a/tprint/src/Options/Utils.hs +++ b/tprint/src/Options/Utils.hs @@ -13,6 +13,7 @@ import Options.Applicative import Data.Text (Text) import qualified Data.Text as T (pack) +import Data.Monoid import Data.Char import Data.Maybe import Data.List diff --git a/tprint/tprint.cabal b/tprint/tprint.cabal index 5fcd00b..94b0a8a 100644 --- a/tprint/tprint.cabal +++ b/tprint/tprint.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tprint -version: 2.0.0 +version: 3.0.0 synopsis: A CLI for thermoprint-client -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -23,15 +23,15 @@ executable tprint , Instances -- other-extensions: build-depends: base >=4.8 && <5 - , thermoprint-bbcode >=2.0.0 && <3 - , thermoprint-client ==1.0.* + , thermoprint-bbcode >=3.0.0 && <4 + , thermoprint-client ==2.0.* , optparse-applicative >=0.12.1 && <1 , containers >=0.5.6 && <1 , time >=1.5.0 && <2 , pretty-show >=1.6.9 && <2 , text >=1.2.2 && <2 , aeson-pretty >=0.7.2 && <1 - , aeson >=0.9.0 && <1 + , aeson >=1.0 && <2 , bytestring >=0.10.6 && <1 , exceptions >=0.8.2 && <1 , deepseq >=1.4.1 && <2 diff --git a/tprint/tprint.nix b/tprint/tprint.nix index 946a4ce..9ce247d 100644 --- a/tprint/tprint.nix +++ b/tprint/tprint.nix @@ -4,7 +4,7 @@ }: mkDerivation { pname = "tprint"; - version = "2.0.0"; + version = "3.0.0"; src = ./.; isLibrary = false; isExecutable = true; diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index 03cd318..65dbfc7 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -40,6 +40,7 @@ import Data.Time import Control.Concurrent import Control.Exception import Control.Monad.Catch +import Control.Monad.Catch.Pure import Control.Applicative import Control.Monad hiding (sequence) @@ -151,9 +152,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do status <- stepper init statusEvent return (status, triggerStatusChange) - Client{..} = mkClient (hoistNat $ Nat liftIO) server - withFatal :: ExceptT ServantError UI a -> UI a - withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runExceptT a + Client{..} = (mkClient' server :: Client (CatchT UI)) + withFatal :: CatchT UI a -> UI a + withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runCatchT a handleEditor selectedPrinter (_, modifyFocusedJobs) = do title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" @@ -259,7 +260,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" on UI.click enactDeletion . const $ do cMarking <- currentValue marking - mapM_ (runExceptT . draftDelete) cMarking + mapM_ (runCatchT . draftDelete) cMarking cDraft <- associatedDraft <$> currentValue editorState when (Set.member cDraft $ Set.map Just cMarking) $ changeEditorState (\s -> s { associatedDraft = Nothing } ) updateMarking Set.empty @@ -348,7 +349,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty enactAbortion <- fatal' "Could not find deletion button" =<< getElementById window "enactAbortion" - on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runExceptT . jobDelete) >> updateMarking Set.empty + on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runCatchT . jobDelete) >> updateMarking Set.empty (selectedPrinter, updatePrinter) <- do autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter" diff --git a/webgui/thermoprint-webgui.cabal b/webgui/thermoprint-webgui.cabal index 9c67a9c..dcd3c4f 100644 --- a/webgui/thermoprint-webgui.cabal +++ b/webgui/thermoprint-webgui.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-webgui -version: 1.0.2 +version: 2.0.0 synopsis: Threepenny interface for thermoprint-spec compliant servers -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -26,8 +26,8 @@ executable thermoprint-webgui -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 - , thermoprint-bbcode >=2.0.0 && <3 - , thermoprint-client ==1.0.* + , thermoprint-bbcode >=3.0.0 && <4 + , thermoprint-client ==2.0.* , threepenny-gui >=0.6.0 && <1 , optparse-applicative >=0.12.1 && <1 , bytestring >=0.10.6 && <1 diff --git a/webgui/thermoprint-webgui.nix b/webgui/thermoprint-webgui.nix index d4cafe8..bff836e 100644 --- a/webgui/thermoprint-webgui.nix +++ b/webgui/thermoprint-webgui.nix @@ -5,7 +5,7 @@ }: mkDerivation { pname = "thermoprint-webgui"; - version = "1.0.2"; + version = "2.0.0"; src = ./.; isLibrary = false; isExecutable = true; -- cgit v1.2.3