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 --- bbcode/bbcode.cabal | 4 +- client/src/Thermoprint/Client.hs | 60 +++++++++++++++++----- client/thermoprint-client.cabal | 6 ++- default.nix | 2 +- 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 +-- shell.nix | 2 +- spec/src/Thermoprint/API.hs | 32 +++++------- spec/src/Thermoprint/Identifiers.hs | 8 +-- spec/src/Thermoprint/Printout.hs | 42 ++++++++++++--- spec/thermoprint-spec.cabal | 2 +- threepenny.patch | 51 +++++++++++++++--- tp-bbcode/src/Thermoprint/Printout/BBCode.hs | 2 +- .../src/Thermoprint/Printout/BBCode/Inverse.hs | 6 +-- tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs | 2 +- tp-bbcode/thermoprint-bbcode.cabal | 8 +-- tprint/src/Options.hs | 4 +- tprint/tprint.cabal | 8 +-- webgui/src/Main.hs | 9 ++-- webgui/thermoprint-webgui.cabal | 8 +-- 26 files changed, 214 insertions(+), 113 deletions(-) diff --git a/bbcode/bbcode.cabal b/bbcode/bbcode.cabal index 6309fc0..e26dfb7 100644 --- a/bbcode/bbcode.cabal +++ b/bbcode/bbcode.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: bbcode -version: 3.1.0 +version: 3.1.1 synopsis: A parser for bbcode -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -25,7 +25,7 @@ library , DeriveGeneric , DeriveAnyClass , OverloadedLists - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <5 , attoparsec >=0.13.0 && <1 , text >=1.2.1 && <2 , containers >=0.4.0 && <1 diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs index 7072ad0..448a912 100644 --- a/client/src/Thermoprint/Client.hs +++ b/client/src/Thermoprint/Client.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -- | A client library for 'Thermoprint.API' module Thermoprint.Client @@ -12,8 +15,8 @@ module Thermoprint.Client , ServantError(..) , module Thermoprint.API , module Servant.Common.BaseUrl - , module Control.Monad.Trans.Either - , module Servant.Server.Internal.Enter + , module Control.Monad.Except + , module Servant.Utils.Enter ) where import Thermoprint.API @@ -24,19 +27,20 @@ import Data.Time (UTCTime) import Servant.Client hiding (HasClient(..)) import qualified Servant.Client as S import Servant.Common.BaseUrl +import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings) import Servant.API -import Servant.Server.Internal.Enter -import Control.Monad.Trans.Either +import Servant.Utils.Enter +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Monad.Catch (Exception, MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans (lift) import Control.Monad import Control.Category import Prelude hiding (id, (.)) -instance Exception ServantError - -- | All 'ThermoprintAPI'-functions as a record -- -- Use like this: @@ -46,7 +50,7 @@ instance Exception ServantError -- > main :: IO () -- > -- ^ Display a list of printers with their status -- > main = print =<< printers --- > where Client{..} = mkClient' $ Http "localhost" 3000 +-- > where Client{..} = mkClient' defaultManagerSettings $ Http "localhost" 3000 data Client m = Client { printers :: m (Map PrinterId PrinterStatus) -- ^ List all printers @@ -86,27 +90,55 @@ withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b)) -- ^ Undo factoring of APIs withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI -mkClient :: (EitherT ServantError IO :~> 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 +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' -mkClient n url = 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 + } 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)) :<|> (drafts :<|> draftCreate) :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint))) - = enter n $ client thermoprintAPI url + = 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) => EitherT e m :~> m +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 <=< runEitherT +throwNat = Nat $ either throwM return <=< runExceptT ioNat :: MonadIO m => IO :~> m -- ^ @ioNat = Nat liftIO@ ioNat = Nat liftIO + +readerNat :: a -> ReaderT a m :~> m +readerNat a = Nat $ flip runReaderT a diff --git a/client/thermoprint-client.cabal b/client/thermoprint-client.cabal index 9567971..9c481e3 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: 0.0.0 +version: 1.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 ==3.0.* + , thermoprint-spec ==4.0.* , servant >=0.4.4 && <1 , servant-client >=0.4.4 && <1 , servant-server >=0.4.4 && <1 @@ -30,6 +30,8 @@ library , 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 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/default.nix b/default.nix index 7ffadea..0aa8c9e 100644 --- a/default.nix +++ b/default.nix @@ -1,5 +1,5 @@ { pkgs ? (import {}) -, compilerName ? "ghc7103" +, compilerName ? "ghc801" }: rec { 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 diff --git a/shell.nix b/shell.nix index 638a9df..f0a69b4 100644 --- a/shell.nix +++ b/shell.nix @@ -6,7 +6,7 @@ let thermoprintPackages = builtins.attrValues (import ./default.nix {}); ghc = haskellPackages.ghcWithPackages (ps: thermoprintPackages ++ utilities ps ++ testDeps ps); - utilities = (ps: with ps; [ hlint cabal2nix cabal-install ]); + utilities = (ps: with ps; [ hlint cabal2nix ]); testDeps = (ps: with ps; [ temporary hspec ]); in pkgs.stdenv.mkDerivation rec { diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs index 9e91487..8e98db8 100644 --- a/spec/src/Thermoprint/API.hs +++ b/spec/src/Thermoprint/API.hs @@ -100,12 +100,6 @@ instance Exception PrintingError type DraftTitle = Text -instance FromText UTCTime where - fromText = parseTimeM True defaultTimeLocale "%F_%T%Q" . T.unpack - -instance ToText UTCTime where - toText = T.pack . formatTime defaultTimeLocale "%F_%T%Q" - data Range a = Min a | Max a | Through a a deriving (Show, Eq, Generic) @@ -121,17 +115,19 @@ contains (Min min) x = min <= x contains (Max max) x = max >= x contains (Through min max) x = min <= x && x <= max -instance ToText a => ToText (Range a) where - toText (Min min) = toText min <> "-" - toText (Max max) = "-" <> toText max - toText (Through min max) = toText min <> "-" <> toText max +instance ToHttpApiData a => ToHttpApiData (Range a) where + toUrlPiece (Min min) = toUrlPiece min <> "-" + toUrlPiece (Max max) = "-" <> toUrlPiece max + toUrlPiece (Through min max) = toUrlPiece min <> "-" <> toUrlPiece max -instance FromText a => FromText (Range a) where - fromText t = listToMaybe $ through <> max <> min +instance FromHttpApiData a => FromHttpApiData (Range a) where + parseUrlPiece t = listToEither $ through <> max <> min where - through = [ Through min max | ((fromText -> Just min), (T.uncons -> Just ('-', (fromText -> Just max)))) <- zip (T.inits t) (T.tails t) ] - min = [ Min min | (fromText -> Just min) <- T.inits t ] - max = [ Max max | (fromText -> Just max) <- T.tails t ] + through = [ Through min max | ((parseUrlPiece -> Right min), (T.uncons -> Just ('-', (parseUrlPiece -> Right max)))) <- zip (T.inits t) (T.tails t) ] + min = [ Min min | (parseUrlPiece -> Right min) <- T.inits t ] + max = [ Max max | (parseUrlPiece -> Right max) <- T.tails t ] + listToEither [x] = Right x + listToEither _ = Left t type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus) :<|> "jobs" :> ( @@ -144,16 +140,16 @@ type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus) :<|> "job" :> Capture "jobId" JobId :> ( Get '[JSON] Printout :<|> "status" :> Get '[JSON] JobStatus - :<|> Delete '[PlainText] () + :<|> Delete '[JSON] () ) :<|> "drafts" :> ( Get '[JSON] (Map DraftId (Maybe DraftTitle)) :<|> QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Post '[JSON] DraftId ) :<|> "draft" :> Capture "draftId" DraftId :> ( - QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Put '[PlainText] () + QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Put '[JSON] () :<|> Get '[JSON] (Maybe DraftTitle, Printout) - :<|> Delete '[PlainText] () + :<|> Delete '[JSON] () :<|> QueryParam "printer" PrinterId :> Post '[JSON] JobId ) diff --git a/spec/src/Thermoprint/Identifiers.hs b/spec/src/Thermoprint/Identifiers.hs index ed8534e..2a07318 100644 --- a/spec/src/Thermoprint/Identifiers.hs +++ b/spec/src/Thermoprint/Identifiers.hs @@ -12,17 +12,17 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import Control.DeepSeq (NFData) -import Servant.API (ToText, FromText) +import Servant.API (ToHttpApiData, FromHttpApiData) import Data.Aeson (FromJSON, ToJSON) newtype PrinterId = PrinterId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) newtype JobId = JobId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) newtype DraftId = DraftId Integer - deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData) + deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData) castId :: (Integral a, Enum b) => a -> b castId = toEnum . fromInteger . toInteger diff --git a/spec/src/Thermoprint/Printout.hs b/spec/src/Thermoprint/Printout.hs index 2be0a83..8c33e07 100644 --- a/spec/src/Thermoprint/Printout.hs +++ b/spec/src/Thermoprint/Printout.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job @@ -63,19 +63,47 @@ import Prelude hiding (fold) -- | A 'Printout' is a sequence of visually seperated 'Paragraph's -type Printout = Seq Paragraph +newtype Printout = Printout { getParagraphs :: Seq Paragraph } + deriving (Show, Generic, NFData) + +instance Eq Paragraph => Eq Printout where + (==) = (==) `on` getParagraphs + +instance Monoid Printout where + mempty = Printout mempty + mappend a b = Printout $ (mappend `on` getParagraphs) a b + +instance FromJSON Printout where + parseJSON = fmap Printout . parseJSON + +instance ToJSON Printout where + toJSON = toJSON . getParagraphs + +instance Arbitrary Printout where + arbitrary = Printout <$> arbitrary -- | A 'Paragraph' is a non-seperated sequence of 'Chunk's -type Paragraph = Seq Chunk +newtype Paragraph = Paragraph { getChunks :: Seq Chunk } + deriving (Show, Generic, NFData) + +instance Eq Chunk => Eq Paragraph where + (==) = (==) `on` getChunks + +instance Monoid Paragraph where + mempty = Paragraph mempty + mappend a b = Paragraph $ (mappend `on` getChunks) a b + +instance Arbitrary Paragraph where + arbitrary = Paragraph <$> arbitrary instance FromJSON Paragraph where - parseJSON o@(Array _) = Seq.fromList <$> parseJSON o - parseJSON o@(Object _) = Seq.singleton <$> parseJSON o - parseJSON o@(String _) = Seq.singleton <$> parseJSON o + parseJSON o@(Array _) = Paragraph . Seq.fromList <$> parseJSON o + parseJSON o@(Object _) = Paragraph . Seq.singleton <$> parseJSON o + parseJSON o@(String _) = Paragraph . Seq.singleton <$> parseJSON o parseJSON v = typeMismatch "Paragraph" v instance ToJSON Paragraph where - toJSON cs + toJSON (Paragraph cs) | (a :< as) <- viewl cs , Seq.null as = toJSON a | otherwise = toJSON $ toList cs diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal index e236e05..28680fb 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: 3.0.0 +version: 4.0.0 synopsis: A specification of the API and the payload datatypes and associated utilities -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html diff --git a/threepenny.patch b/threepenny.patch index 1feb733..5dbb84f 100644 --- a/threepenny.patch +++ b/threepenny.patch @@ -1,7 +1,46 @@ -From 480675cba32803ab74ec064e14ed6b2001c8e071 Mon Sep 17 00:00:00 2001 +From 86574dffb26128252159a6f25a3ea29be965047f Mon Sep 17 00:00:00 2001 +From: Heinrich Apfelmus +Date: Fri, 27 May 2016 22:47:04 +0200 +Subject: [PATCH 1/3] Fix #138: Update the use of `GHC.mkWeak#` to GHC 8.0.1 + +--- + src/Foreign/RemotePtr.hs | 10 +++++++--- + 1 file changed, 7 insertions(+), 3 deletions(-) + +diff --git a/src/Foreign/RemotePtr.hs b/src/Foreign/RemotePtr.hs +index b534b74..fce37bc 100644 +--- a/src/Foreign/RemotePtr.hs ++++ b/src/Foreign/RemotePtr.hs +@@ -33,14 +33,18 @@ import qualified GHC.IORef as GHC + import qualified GHC.STRef as GHC + + mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value) +-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> +- case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) +- + #if CABAL + #if MIN_VERSION_base(4,6,0) + #else + atomicModifyIORef' = atomicModifyIORef + #endif ++#if MIN_VERSION_base(4,9,0) ++mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> ++ case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) ++#endif ++#else ++mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> ++ case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) + #endif + + type Map = Map.Map +-- +2.9.0 + + +From 0ed2c2ebb64b24fdcded4e273bfda1583763a815 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Feb 2016 18:14:48 +0000 -Subject: [PATCH 1/2] Switched to using location.host +Subject: [PATCH 2/3] Switched to using location.host --- js/comm.js | 2 +- @@ -21,13 +60,13 @@ index 2d24f08..01763ba 100644 // Close WebSocket when the browser window is closed. -- -2.7.0 +2.9.0 -From 52f45089ccf786c13d185faf1ad7436a63c13002 Mon Sep 17 00:00:00 2001 +From 4fb9b3304467a48d8ebeec85803464ec1a2aeeb6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 1 Mar 2016 00:22:01 +0100 -Subject: [PATCH 2/2] Now manipulating the location object +Subject: [PATCH 3/3] Now manipulating the location object --- js/comm.js | 3 +- @@ -148,5 +187,5 @@ index 0d2a564..ceec6f4 100644 , [include|js/comm.js|] , [include|js/ffi.js|] -- -2.7.0 +2.9.0 diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs index cbe2618..dd5edb0 100644 --- a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs +++ b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs @@ -104,7 +104,7 @@ morph :: DomForest -> Either SemanticError Printout -- ^ Parse a list of paragraphs -- -- Since we permit only cooked input via 'Raw' 'Paragraph' is identical to 'Block' -morph = fmap Seq.fromList . mapM (\t -> Seq.singleton . Cooked <$> parse BlockCtx t) +morph = fmap (Printout . Seq.fromList) . mapM (\t -> Paragraph . Seq.singleton . Cooked <$> parse BlockCtx t) parseDom :: DomTree -> ParseResult -- ^ Invoke 'asLine' and 'asBlock' to parse a single 'DomTree' diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs index edd4c5a..8e15417 100644 --- a/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs +++ b/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs @@ -24,10 +24,10 @@ import Data.Monoid import Thermoprint.Printout cobbcode :: Printout -> Either UnicodeException Text -cobbcode (toList -> ps) = mconcat . intersperse "\n\n" <$> mapM handlePar ps +cobbcode (toList . getParagraphs -> ps) = mconcat . intersperse "\n\n" <$> mapM handlePar ps -handlePar :: Seq Chunk -> Either UnicodeException Text -handlePar (toList -> cs) = mconcat <$> mapM handleChunk cs +handlePar :: Paragraph -> Either UnicodeException Text +handlePar (toList . getChunks -> cs) = mconcat <$> mapM handleChunk cs handleChunk :: Chunk -> Either UnicodeException Text handleChunk (Cooked b) = Right $ handleBlock b diff --git a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs index 09b3147..7909360 100644 --- a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs +++ b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs @@ -53,7 +53,7 @@ normalize = (!! 3) . iterate normalize' . first (const ()) join' _ = Left () pOut :: Seq Block -> Printout -pOut = fmap (pure . Cooked) +pOut = Printout . fmap (Paragraph . pure . Cooked) examples :: [(Text, Either BBCodeError (Seq Block))] examples = [ ("Hello World!" diff --git a/tp-bbcode/thermoprint-bbcode.cabal b/tp-bbcode/thermoprint-bbcode.cabal index 8773b89..29855e2 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: 1.0.0 +version: 2.0.0 synopsis: Parse bbcode for use in thermoprint -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -24,8 +24,8 @@ library , OverloadedLists -- other-extensions: build-depends: base >=4.8.1 && <5 - , thermoprint-spec ==3.0.* - , bbcode >=3.0 && <4 + , thermoprint-spec ==4.0.* + , bbcode >=3.1.1 && <4 , containers -any , text -any , case-insensitive -any @@ -44,7 +44,7 @@ Test-Suite tests , OverloadedLists build-depends: base >=4.8.1 && <5 , thermoprint-bbcode -any - , thermoprint-spec ==3.0.* + , thermoprint-spec ==4.0.* , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <4 diff --git a/tprint/src/Options.hs b/tprint/src/Options.hs index 1ad6c47..e146f91 100644 --- a/tprint/src/Options.hs +++ b/tprint/src/Options.hs @@ -26,6 +26,8 @@ import Instances () import Paths_tprint (version) import Data.Version (showVersion) +import Data.Bifunctor (Bifunctor(..)) + data TPrint = TPrint { baseUrl :: BaseUrl , dryRun :: Bool @@ -148,7 +150,7 @@ pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters ] pTPrint :: Parser TPrint -pTPrint = TPrint <$> option (eitherReader parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000) <> showDefaultWith showBaseUrl) +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 diff --git a/tprint/tprint.cabal b/tprint/tprint.cabal index d6fc422..5fcd00b 100644 --- a/tprint/tprint.cabal +++ b/tprint/tprint.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tprint -version: 1.0.0 +version: 2.0.0 synopsis: A CLI for thermoprint-client -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -22,9 +22,9 @@ executable tprint , Options.Utils , Instances -- other-extensions: - build-depends: base >=4.8 && <4.9 - , thermoprint-bbcode >=1.0.0 && <2 - , thermoprint-client ==0.0.* + build-depends: base >=4.8 && <5 + , thermoprint-bbcode >=2.0.0 && <3 + , thermoprint-client ==1.0.* , optparse-applicative >=0.12.1 && <1 , containers >=0.5.6 && <1 , time >=1.5.0 && <2 diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index a295fd9..252e933 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -86,6 +86,7 @@ config = do <*> (BaseUrl Http <$> Opt.strOption (Opt.long "target-addr" <> Opt.short 'A' <> Opt.metavar "HOST" <> Opt.help "Host to connect to" <> Opt.value "localhost" <> Opt.showDefault) <*> Opt.option Opt.auto (Opt.long "target-port" <> Opt.short 'P' <> Opt.metavar "PORT" <> Opt.help "Port to connect to" <> Opt.value 3000 <> Opt.showDefault) + <*> Opt.strOption (Opt.long "target-path" <> Opt.short 'F' <> Opt.metavar "PATH" <> Opt.help "Path we expect to find Thermoprint.Server under" <> Opt.value "" <> Opt.showDefault) ) where port def = Opt.long "port" @@ -151,8 +152,8 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do return (status, triggerStatusChange) Client{..} = mkClient (hoistNat $ Nat liftIO) server - withFatal :: EitherT ServantError UI a -> UI a - withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runEitherT a + withFatal :: ExceptT ServantError UI a -> UI a + withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runExceptT a handleEditor selectedPrinter (_, modifyFocusedJobs) = do title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" @@ -256,7 +257,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" - on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runEitherT . draftDelete) >> updateMarking Set.empty + on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runExceptT . draftDelete) >> updateMarking Set.empty -- deletion' <- allowDeletion # get UI.checked let updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking @@ -342,7 +343,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_ (runEitherT . jobDelete) >> updateMarking Set.empty + on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runExceptT . 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 024bcf6..03aa9b2 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: 0.0.0 +version: 1.0.0 synopsis: Threepenny interface for thermoprint-spec compliant servers -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html @@ -25,9 +25,9 @@ executable thermoprint-webgui main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <4.9 - , thermoprint-bbcode >=1.0.0 && <2 - , thermoprint-client ==0.0.* + build-depends: base >=4.8 && <5 + , thermoprint-bbcode >=2.0.0 && <3 + , thermoprint-client ==1.0.* , threepenny-gui >=0.6.0 && <1 , optparse-applicative >=0.12.1 && <1 , bytestring >=0.10.6 && <1 -- cgit v1.2.3